diff --git a/README.md b/README.md index e69de29..e47cd58 100644 --- a/README.md +++ b/README.md @@ -0,0 +1 @@ +TODO: Figure out sbcl/quicklisp auto install diff --git a/quicklisp.lisp b/quicklisp.lisp new file mode 100644 index 0000000..6cda472 --- /dev/null +++ b/quicklisp.lisp @@ -0,0 +1,1757 @@ +;;;; +;;;; This is quicklisp.lisp, the quickstart file for Quicklisp. To use +;;;; it, start Lisp, then (load "quicklisp.lisp") +;;;; +;;;; Quicklisp is beta software and comes with no warranty of any kind. +;;;; +;;;; For more information about the Quicklisp beta, see: +;;;; +;;;; http://www.quicklisp.org/beta/ +;;;; +;;;; If you have any questions or comments about Quicklisp, please +;;;; contact: +;;;; +;;;; Zach Beane +;;;; + +(cl:in-package #:cl-user) +(cl:defpackage #:qlqs-user + (:use #:cl)) +(cl:in-package #:qlqs-user) + +(defpackage #:qlqs-info + (:export #:*version*)) + +(defvar qlqs-info:*version* "2015-01-28") + +(defpackage #:qlqs-impl + (:use #:cl) + (:export #:*implementation*) + (:export #:definterface + #:defimplementation) + (:export #:lisp + #:abcl + #:allegro + #:ccl + #:clasp + #:clisp + #:cmucl + #:cormanlisp + #:ecl + #:gcl + #:lispworks + #:mkcl + #:scl + #:sbcl)) + +(defpackage #:qlqs-impl-util + (:use #:cl #:qlqs-impl) + (:export #:call-with-quiet-compilation)) + +(defpackage #:qlqs-network + (:use #:cl #:qlqs-impl) + (:export #:open-connection + #:write-octets + #:read-octets + #:close-connection + #:with-connection)) + +(defpackage #:qlqs-progress + (:use #:cl) + (:export #:make-progress-bar + #:start-display + #:update-progress + #:finish-display)) + +(defpackage #:qlqs-http + (:use #:cl #:qlqs-network #:qlqs-progress) + (:export #:fetch + #:*proxy-url* + #:*maximum-redirects* + #:*default-url-defaults*)) + +(defpackage #:qlqs-minitar + (:use #:cl) + (:export #:unpack-tarball)) + +(defpackage #:quicklisp-quickstart + (:use #:cl #:qlqs-impl #:qlqs-impl-util #:qlqs-http #:qlqs-minitar) + (:export #:install + #:help + #:*proxy-url* + #:*asdf-url* + #:*quicklisp-tar-url* + #:*setup-url* + #:*help-message* + #:*after-load-message* + #:*after-initial-setup-message*)) + + +;;; +;;; Defining implementation-specific packages and functionality +;;; + +(in-package #:qlqs-impl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun error-unimplemented (&rest args) + (declare (ignore args)) + (error "Not implemented"))) + +(defmacro neuter-package (name) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((definition (fdefinition 'error-unimplemented))) + (do-external-symbols (symbol ,(string name)) + (unless (fboundp symbol) + (setf (fdefinition symbol) definition)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun feature-expression-passes-p (expression) + (cond ((keywordp expression) + (member expression *features*)) + ((consp expression) + (case (first expression) + (or + (some 'feature-expression-passes-p (rest expression))) + (and + (every 'feature-expression-passes-p (rest expression))))) + (t (error "Unrecognized feature expression -- ~S" expression))))) + + +(defmacro define-implementation-package (feature package-name &rest options) + (let* ((output-options '((:use) + (:export #:lisp))) + (prep (cdr (assoc :prep options))) + (class-option (cdr (assoc :class options))) + (class (first class-option)) + (superclasses (rest class-option)) + (import-options '()) + (effectivep (feature-expression-passes-p feature))) + (dolist (option options) + (ecase (first option) + ((:prep :class)) + ((:import-from + :import) + (push option import-options)) + ((:export + :shadow + :intern + :documentation) + (push option output-options)) + ((:reexport-from) + (push (cons :export (cddr option)) output-options) + (push (cons :import-from (cdr option)) import-options)))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(when effectivep + prep) + (defclass ,class ,superclasses ()) + (defpackage ,package-name ,@output-options + ,@(when effectivep + import-options)) + ,@(when effectivep + `((setf *implementation* (make-instance ',class)))) + ,@(unless effectivep + `((neuter-package ,package-name)))))) + +(defmacro definterface (name lambda-list &body options) + (let* ((forbidden (intersection lambda-list lambda-list-keywords)) + (gf-options (remove :implementation options :key #'first)) + (implementations (set-difference options gf-options))) + (when forbidden + (error "~S not allowed in definterface lambda list" forbidden)) + (flet ((method-option (class body) + `(:method ((*implementation* ,class) ,@lambda-list) + ,@body))) + (let ((generic-name (intern (format nil "%~A" name)))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defgeneric ,generic-name (lisp ,@lambda-list) + ,@gf-options + ,@(mapcar (lambda (implementation) + (destructuring-bind (class &rest body) + (rest implementation) + (method-option class body))) + implementations)) + (defun ,name ,lambda-list + (,generic-name *implementation* ,@lambda-list))))))) + +(defmacro defimplementation (name-and-options + lambda-list &body body) + (destructuring-bind (name &key (for t) qualifier) + (if (consp name-and-options) + name-and-options + (list name-and-options)) + (unless for + (error "You must specify an implementation name.")) + (let ((generic-name (find-symbol (format nil "%~A" name)))) + (unless (and generic-name + (fboundp generic-name)) + (error "~S does not name an implementation function" name)) + `(defmethod ,generic-name + ,@(when qualifier (list qualifier)) + ,(list* `(*implementation* ,for) lambda-list) ,@body)))) + + +;;; Bootstrap implementations + +(defvar *implementation* nil) +(defclass lisp () ()) + + +;;; Allegro Common Lisp + +(define-implementation-package :allegro #:qlqs-allegro + (:documentation + "Allegro Common Lisp - http://www.franz.com/products/allegrocl/") + (:class allegro) + (:reexport-from #:socket + #:make-socket) + (:reexport-from #:excl + #:read-vector)) + + +;;; Armed Bear Common Lisp + +(define-implementation-package :abcl #:qlqs-abcl + (:documentation + "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/") + (:class abcl) + (:reexport-from #:system + #:make-socket + #:get-socket-stream)) + +;;; Clozure CL + +(define-implementation-package :ccl #:qlqs-ccl + (:documentation + "Clozure Common Lisp - http://www.clozure.com/clozurecl.html") + (:class ccl) + (:reexport-from #:ccl + #:make-socket)) + + +;;; CLASP + +(define-implementation-package :clasp #:qlqs-clasp + (:documentation "CLASP - http://github.com/drmeister/clasp") + (:class clasp) + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:host-ent-address + #:socket-connect + #:socket-make-stream + #:inet-socket)) + + +;;; GNU CLISP + +(define-implementation-package :clisp #:qlqs-clisp + (:documentation "GNU CLISP - http://clisp.cons.org/") + (:class clisp) + (:reexport-from #:socket + #:socket-connect) + (:reexport-from #:ext + #:read-byte-sequence)) + + +;;; CMUCL + +(define-implementation-package :cmu #:qlqs-cmucl + (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/") + (:class cmucl) + (:reexport-from #:ext + #:*gc-verbose*) + (:reexport-from #:system + #:make-fd-stream) + (:reexport-from #:extensions + #:connect-to-inet-socket)) + +(defvar qlqs-cmucl:*gc-verbose* nil) + + +;;; Scieneer CL + +(define-implementation-package :scl #:qlqs-scl + (:documentation "Scieneer Common Lisp - http://www.scieneer.com/scl/") + (:class scl) + (:reexport-from #:system + #:make-fd-stream) + (:reexport-from #:extensions + #:connect-to-inet-socket)) + +;;; ECL + +(define-implementation-package :ecl #:qlqs-ecl + (:documentation "ECL - http://ecls.sourceforge.net/") + (:class ecl) + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:host-ent-address + #:socket-connect + #:socket-make-stream + #:inet-socket)) + + +;;; LispWorks + +(define-implementation-package :lispworks #:qlqs-lispworks + (:documentation "LispWorks - http://www.lispworks.com/") + (:class lispworks) + (:prep + (require "comm")) + (:reexport-from #:comm + #:open-tcp-stream + #:get-host-entry)) + + +;;; SBCL + +(define-implementation-package :sbcl #:qlqs-sbcl + (:class sbcl) + (:documentation + "Steel Bank Common Lisp - http://www.sbcl.org/") + (:prep + (require 'sb-bsd-sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-ext + #:compiler-note) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:inet-socket + #:host-ent-address + #:socket-connect + #:socket-make-stream)) + +;;; MKCL + +(define-implementation-package :mkcl #:qlqs-mkcl + (:class mkcl) + (:documentation + "ManKai Common Lisp - http://common-lisp.net/project/mkcl/") + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:inet-socket + #:host-ent-address + #:socket-connect + #:socket-make-stream)) + +;;; +;;; Utility function +;;; + +(in-package #:qlqs-impl-util) + +(definterface call-with-quiet-compilation (fun) + (:implementation t + (let ((*load-verbose* nil) + (*compile-verbose* nil) + (*load-print* nil) + (*compile-print* nil)) + (handler-bind ((warning #'muffle-warning)) + (funcall fun))))) + +(defimplementation (call-with-quiet-compilation :for sbcl :qualifier :around) + (fun) + (declare (ignorable fun)) + (handler-bind ((qlqs-sbcl:compiler-note #'muffle-warning)) + (call-next-method))) + +(defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around) + (fun) + (declare (ignorable fun)) + (let ((qlqs-cmucl:*gc-verbose* nil)) + (call-next-method))) + + +;;; +;;; Low-level networking implementations +;;; + +(in-package #:qlqs-network) + +(definterface host-address (host) + (:implementation t + host) + (:implementation mkcl + (qlqs-mkcl:host-ent-address (qlqs-mkcl:get-host-by-name host))) + (:implementation sbcl + (qlqs-sbcl:host-ent-address (qlqs-sbcl:get-host-by-name host)))) + +(definterface open-connection (host port) + (:implementation t + (declare (ignorable host port)) + (error "Sorry, quicklisp in implementation ~S is not supported yet." + (lisp-implementation-type))) + (:implementation allegro + (qlqs-allegro:make-socket :remote-host host + :remote-port port)) + (:implementation abcl + (let ((socket (qlqs-abcl:make-socket host port))) + (qlqs-abcl:get-socket-stream socket :element-type '(unsigned-byte 8)))) + (:implementation ccl + (qlqs-ccl:make-socket :remote-host host + :remote-port port)) + (:implementation clasp + (let* ((endpoint (qlqs-clasp:host-ent-address + (qlqs-clasp:get-host-by-name host))) + (socket (make-instance 'qlqs-clasp:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-clasp:socket-connect socket endpoint port) + (qlqs-clasp:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation clisp + (qlqs-clisp:socket-connect port host :element-type '(unsigned-byte 8))) + (:implementation cmucl + (let ((fd (qlqs-cmucl:connect-to-inet-socket host port))) + (qlqs-cmucl:make-fd-stream fd + :element-type '(unsigned-byte 8) + :binary-stream-p t + :input t + :output t))) + (:implementation scl + (let ((fd (qlqs-scl:connect-to-inet-socket host port))) + (qlqs-scl:make-fd-stream fd + :element-type '(unsigned-byte 8) + :input t + :output t))) + (:implementation ecl + (let* ((endpoint (qlqs-ecl:host-ent-address + (qlqs-ecl:get-host-by-name host))) + (socket (make-instance 'qlqs-ecl:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-ecl:socket-connect socket endpoint port) + (qlqs-ecl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation lispworks + (qlqs-lispworks:open-tcp-stream host port + :direction :io + :errorp t + :read-timeout nil + :element-type '(unsigned-byte 8) + :timeout 5)) + (:implementation mkcl + (let* ((endpoint (qlqs-mkcl:host-ent-address + (qlqs-mkcl:get-host-by-name host))) + (socket (make-instance 'qlqs-mkcl:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-mkcl:socket-connect socket endpoint port) + (qlqs-mkcl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation sbcl + (let* ((endpoint (qlqs-sbcl:host-ent-address + (qlqs-sbcl:get-host-by-name host))) + (socket (make-instance 'qlqs-sbcl:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-sbcl:socket-connect socket endpoint port) + (qlqs-sbcl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full)))) + +(definterface read-octets (buffer connection) + (:implementation t + (read-sequence buffer connection)) + (:implementation allegro + (qlqs-allegro:read-vector buffer connection)) + (:implementation clisp + (qlqs-clisp:read-byte-sequence buffer connection + :no-hang nil + :interactive t))) + +(definterface write-octets (buffer connection) + (:implementation t + (write-sequence buffer connection) + (finish-output connection))) + +(definterface close-connection (connection) + (:implementation t + (ignore-errors (close connection)))) + +(definterface call-with-connection (host port fun) + (:implementation t + (let (connection) + (unwind-protect + (progn + (setf connection (open-connection host port)) + (funcall fun connection)) + (when connection + (close connection)))))) + +(defmacro with-connection ((connection host port) &body body) + `(call-with-connection ,host ,port (lambda (,connection) ,@body))) + + +;;; +;;; A text progress bar +;;; + +(in-package #:qlqs-progress) + +(defclass progress-bar () + ((start-time + :initarg :start-time + :accessor start-time) + (end-time + :initarg :end-time + :accessor end-time) + (progress-character + :initarg :progress-character + :accessor progress-character) + (character-count + :initarg :character-count + :accessor character-count + :documentation "How many characters wide is the progress bar?") + (characters-so-far + :initarg :characters-so-far + :accessor characters-so-far) + (update-interval + :initarg :update-interval + :accessor update-interval + :documentation "Update the progress bar display after this many + internal-time units.") + (last-update-time + :initarg :last-update-time + :accessor last-update-time + :documentation "The display was last updated at this time.") + (total + :initarg :total + :accessor total + :documentation "The total number of units tracked by this progress bar.") + (progress + :initarg :progress + :accessor progress + :documentation "How far in the progress are we?") + (pending + :initarg :pending + :accessor pending + :documentation "How many raw units should be tracked in the next + display update?")) + (:default-initargs + :progress-character #\= + :character-count 50 + :characters-so-far 0 + :update-interval (floor internal-time-units-per-second 4) + :last-update-time 0 + :total 0 + :progress 0 + :pending 0)) + +(defgeneric start-display (progress-bar)) +(defgeneric update-progress (progress-bar unit-count)) +(defgeneric update-display (progress-bar)) +(defgeneric finish-display (progress-bar)) +(defgeneric elapsed-time (progress-bar)) +(defgeneric units-per-second (progress-bar)) + +(defmethod start-display (progress-bar) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (setf (start-time progress-bar) (get-internal-real-time)) + (fresh-line) + (finish-output)) + +(defmethod update-display (progress-bar) + (incf (progress progress-bar) (pending progress-bar)) + (setf (pending progress-bar) 0) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (let* ((showable (floor (character-count progress-bar) + (/ (total progress-bar) (progress progress-bar)))) + (needed (- showable (characters-so-far progress-bar)))) + (setf (characters-so-far progress-bar) showable) + (dotimes (i needed) + (write-char (progress-character progress-bar))) + (finish-output))) + +(defmethod update-progress (progress-bar unit-count) + (incf (pending progress-bar) unit-count) + (let ((now (get-internal-real-time))) + (when (< (update-interval progress-bar) + (- now (last-update-time progress-bar))) + (update-display progress-bar)))) + +(defmethod finish-display (progress-bar) + (update-display progress-bar) + (setf (end-time progress-bar) (get-internal-real-time)) + (terpri) + (format t "~:D bytes in ~$ seconds (~$KB/sec)" + (total progress-bar) + (elapsed-time progress-bar) + (/ (units-per-second progress-bar) 1024)) + (finish-output)) + +(defmethod elapsed-time (progress-bar) + (/ (- (end-time progress-bar) (start-time progress-bar)) + internal-time-units-per-second)) + +(defmethod units-per-second (progress-bar) + (if (plusp (elapsed-time progress-bar)) + (/ (total progress-bar) (elapsed-time progress-bar)) + 0)) + +(defun kb/sec (progress-bar) + (/ (units-per-second progress-bar) 1024)) + + + +(defparameter *uncertain-progress-chars* "?") + +(defclass uncertain-size-progress-bar (progress-bar) + ((progress-char-index + :initarg :progress-char-index + :accessor progress-char-index) + (units-per-char + :initarg :units-per-char + :accessor units-per-char)) + (:default-initargs + :total 0 + :progress-char-index 0 + :units-per-char (floor (expt 1024 2) 50))) + +(defmethod update-progress :after ((progress-bar uncertain-size-progress-bar) + unit-count) + (incf (total progress-bar) unit-count)) + +(defmethod progress-character ((progress-bar uncertain-size-progress-bar)) + (let ((index (progress-char-index progress-bar))) + (prog1 + (char *uncertain-progress-chars* index) + (setf (progress-char-index progress-bar) + (mod (1+ index) (length *uncertain-progress-chars*)))))) + +(defmethod update-display ((progress-bar uncertain-size-progress-bar)) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (multiple-value-bind (chars pend) + (floor (pending progress-bar) (units-per-char progress-bar)) + (setf (pending progress-bar) pend) + (dotimes (i chars) + (write-char (progress-character progress-bar)) + (incf (characters-so-far progress-bar)) + (when (<= (character-count progress-bar) + (characters-so-far progress-bar)) + (terpri) + (setf (characters-so-far progress-bar) 0) + (finish-output))) + (finish-output))) + +(defun make-progress-bar (total) + (if (or (not total) (zerop total)) + (make-instance 'uncertain-size-progress-bar) + (make-instance 'progress-bar :total total))) + +;;; +;;; A simple HTTP client +;;; + +(in-package #:qlqs-http) + +;;; Octet data + +(deftype octet () + '(unsigned-byte 8)) + +(defun make-octet-vector (size) + (make-array size :element-type 'octet + :initial-element 0)) + +(defun octet-vector (&rest octets) + (make-array (length octets) :element-type 'octet + :initial-contents octets)) + +;;; ASCII characters as integers + +(defun acode (char) + (cond ((eql char :cr) + 13) + ((eql char :lf) + 10) + (t + (let ((code (char-code char))) + (if (<= 0 code 127) + code + (error "Character ~S is not in the ASCII character set" + char)))))) + +(defvar *whitespace* + (list (acode #\Space) (acode #\Tab) (acode :cr) (acode :lf))) + +(defun whitep (code) + (member code *whitespace*)) + +(defun ascii-vector (string) + (let ((vector (make-octet-vector (length string)))) + (loop for char across string + for code = (char-code char) + for i from 0 + if (< 127 code) do + (error "Invalid character for ASCII -- ~A" char) + else + do (setf (aref vector i) code)) + vector)) + +(defun ascii-subseq (vector start end) + "Return a subseq of octet-specialized VECTOR as a string." + (let ((string (make-string (- end start)))) + (loop for i from 0 + for j from start below end + do (setf (char string i) (code-char (aref vector j)))) + string)) + +(defun ascii-downcase (code) + (if (<= 65 code 90) + (+ code 32) + code)) + +(defun ascii-equal (a b) + (eql (ascii-downcase a) (ascii-downcase b))) + +(defmacro acase (value &body cases) + (flet ((convert-case-keys (keys) + (mapcar (lambda (key) + (etypecase key + (integer key) + (character (char-code key)) + (symbol + (ecase key + (:cr 13) + (:lf 10) + ((t) t))))) + (if (consp keys) keys (list keys))))) + `(case ,value + ,@(mapcar (lambda (case) + (destructuring-bind (keys &rest body) + case + `(,(if (eql keys t) + t + (convert-case-keys keys)) + ,@body))) + cases)))) + +;;; Pattern matching (for finding headers) + +(defclass matcher () + ((pattern + :initarg :pattern + :reader pattern) + (pos + :initform 0 + :accessor match-pos) + (matchedp + :initform nil + :accessor matchedp))) + +(defun reset-match (matcher) + (setf (match-pos matcher) 0 + (matchedp matcher) nil)) + +(define-condition match-failure (error) ()) + +(defun match (matcher input &key (start 0) end error) + (let ((i start) + (end (or end (length input))) + (match-end (length (pattern matcher)))) + (with-slots (pattern pos) + matcher + (loop + (cond ((= pos match-end) + (let ((match-start (- i pos))) + (setf pos 0) + (setf (matchedp matcher) t) + (return (values match-start (+ match-start match-end))))) + ((= i end) + (return nil)) + ((= (aref pattern pos) + (aref input i)) + (incf i) + (incf pos)) + (t + (if error + (error 'match-failure) + (if (zerop pos) + (incf i) + (setf pos 0))))))))) + +(defun ascii-matcher (string) + (make-instance 'matcher + :pattern (ascii-vector string))) + +(defun octet-matcher (&rest octets) + (make-instance 'matcher + :pattern (apply 'octet-vector octets))) + +(defun acode-matcher (&rest codes) + (make-instance 'matcher + :pattern (make-array (length codes) + :element-type 'octet + :initial-contents + (mapcar 'acode codes)))) + + +;;; "Connection Buffers" are a kind of callback-driven, +;;; pattern-matching chunky stream. Callbacks can be called for a +;;; certain number of octets or until one or more patterns are seen in +;;; the input. cbufs automatically refill themselves from a +;;; connection as needed. + +(defvar *cbuf-buffer-size* 8192) + +(define-condition end-of-data (error) ()) + +(defclass cbuf () + ((data + :initarg :data + :accessor data) + (connection + :initarg :connection + :accessor connection) + (start + :initarg :start + :accessor start) + (end + :initarg :end + :accessor end) + (eofp + :initarg :eofp + :accessor eofp)) + (:default-initargs + :data (make-octet-vector *cbuf-buffer-size*) + :connection nil + :start 0 + :end 0 + :eofp nil) + (:documentation "A CBUF is a connection buffer that keeps track of + incoming data from a connection. Several functions make it easy to + treat a CBUF as a kind of chunky, callback-driven stream.")) + +(define-condition cbuf-progress () + ((size + :initarg :size + :accessor cbuf-progress-size + :initform 0))) + +(defun call-processor (fun cbuf start end) + (signal 'cbuf-progress :size (- end start)) + (funcall fun (data cbuf) start end)) + +(defun make-cbuf (connection) + (make-instance 'cbuf :connection connection)) + +(defun make-stream-writer (stream) + "Create a callback for writing data to STREAM." + (lambda (data start end) + (write-sequence data stream :start start :end end))) + +(defgeneric size (cbuf) + (:method ((cbuf cbuf)) + (- (end cbuf) (start cbuf)))) + +(defgeneric emptyp (cbuf) + (:method ((cbuf cbuf)) + (zerop (size cbuf)))) + +(defgeneric refill (cbuf) + (:method ((cbuf cbuf)) + (when (eofp cbuf) + (error 'end-of-data)) + (setf (start cbuf) 0) + (setf (end cbuf) + (read-octets (data cbuf) + (connection cbuf))) + (cond ((emptyp cbuf) + (setf (eofp cbuf) t) + (error 'end-of-data)) + (t (size cbuf))))) + +(defun process-all (fun cbuf) + (unless (emptyp cbuf) + (call-processor fun cbuf (start cbuf) (end cbuf)))) + +(defun multi-cmatch (matchers cbuf) + (let (start end) + (dolist (matcher matchers (values start end)) + (multiple-value-bind (s e) + (match matcher (data cbuf) + :start (start cbuf) + :end (end cbuf)) + (when (and s (or (null start) (< s start))) + (setf start s + end e)))))) + +(defun cmatch (matcher cbuf) + (if (consp matcher) + (multi-cmatch matcher cbuf) + (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)))) + +(defun call-until-end (fun cbuf) + (handler-case + (loop + (process-all fun cbuf) + (refill cbuf)) + (end-of-data () + (return-from call-until-end)))) + +(defun show-cbuf (context cbuf) + (format t "cbuf: ~A ~D - ~D~%" context (start cbuf) (end cbuf))) + +(defun call-for-n-octets (n fun cbuf) + (let ((remaining n)) + (loop + (when (<= remaining (size cbuf)) + (let ((end (+ (start cbuf) remaining))) + (call-processor fun cbuf (start cbuf) end) + (setf (start cbuf) end) + (return))) + (process-all fun cbuf) + (decf remaining (size cbuf)) + (refill cbuf)))) + +(defun call-until-matching (matcher fun cbuf) + (loop + (multiple-value-bind (start end) + (cmatch matcher cbuf) + (when start + (call-processor fun cbuf (start cbuf) end) + (setf (start cbuf) end) + (return))) + (process-all fun cbuf) + (refill cbuf))) + +(defun ignore-data (data start end) + (declare (ignore data start end))) + +(defun skip-until-matching (matcher cbuf) + (call-until-matching matcher 'ignore-data cbuf)) + + +;;; Creating HTTP requests as octet buffers + +(defclass octet-sink () + ((storage + :initarg :storage + :accessor storage)) + (:default-initargs + :storage (make-array 1024 :element-type 'octet + :fill-pointer 0 + :adjustable t)) + (:documentation "A simple stream-like target for collecting + octets.")) + +(defun add-octet (octet sink) + (vector-push-extend octet (storage sink))) + +(defun add-octets (octets sink &key (start 0) end) + (setf end (or end (length octets))) + (loop for i from start below end + do (add-octet (aref octets i) sink))) + +(defun add-string (string sink) + (loop for char across string + for code = (char-code char) + do (add-octet code sink))) + +(defun add-strings (sink &rest strings) + (mapc (lambda (string) (add-string string sink)) strings)) + +(defun add-newline (sink) + (add-octet 13 sink) + (add-octet 10 sink)) + +(defun sink-buffer (sink) + (subseq (storage sink) 0)) + +(defvar *proxy-url* nil) + +(defun full-proxy-path (host port path) + (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A" + (= port 443) + host + (or (= port 80) + (= port 443)) + port + path)) + +(defun make-request-buffer (host port path &key (method "GET")) + (setf method (string method)) + (when *proxy-url* + (setf path (full-proxy-path host port path))) + (let ((sink (make-instance 'octet-sink))) + (flet ((add-line (&rest strings) + (apply #'add-strings sink strings) + (add-newline sink))) + (add-line method " " path " HTTP/1.1") + (add-line "Host: " host (if (= port 80) "" + (format nil ":~D" port))) + (add-line "Connection: close") + ;; FIXME: get this version string from somewhere else. + (add-line "User-Agent: quicklisp-bootstrap/" + qlqs-info:*version*) + (add-newline sink) + (sink-buffer sink)))) + +(defun sink-until-matching (matcher cbuf) + (let ((sink (make-instance 'octet-sink))) + (call-until-matching + matcher + (lambda (buffer start end) + (add-octets buffer sink :start start :end end)) + cbuf) + (sink-buffer sink))) + + +;;; HTTP headers + +(defclass header () + ((data + :initarg :data + :accessor data) + (status + :initarg :status + :accessor status) + (name-starts + :initarg :name-starts + :accessor name-starts) + (name-ends + :initarg :name-ends + :accessor name-ends) + (value-starts + :initarg :value-starts + :accessor value-starts) + (value-ends + :initarg :value-ends + :accessor value-ends))) + +(defmethod print-object ((header header) stream) + (print-unreadable-object (header stream :type t) + (prin1 (status header) stream))) + +(defun matches-at (pattern target pos) + (= (mismatch pattern target :start2 pos) (length pattern))) + +(defun header-value-indexes (field-name header) + (loop with data = (data header) + with pattern = (ascii-vector (string-downcase field-name)) + for start across (name-starts header) + for i from 0 + when (matches-at pattern data start) + return (values (aref (value-starts header) i) + (aref (value-ends header) i)))) + +(defun ascii-header-value (field-name header) + (multiple-value-bind (start end) + (header-value-indexes field-name header) + (when start + (ascii-subseq (data header) start end)))) + +(defun all-field-names (header) + (map 'list + (lambda (start end) + (ascii-subseq (data header) start end)) + (name-starts header) + (name-ends header))) + +(defun headers-alist (header) + (mapcar (lambda (name) + (cons name (ascii-header-value name header))) + (all-field-names header))) + +(defmethod describe-object :after ((header header) stream) + (format stream "~&Decoded headers:~% ~S~%" (headers-alist header))) + +(defun content-length (header) + (let ((field-value (ascii-header-value "content-length" header))) + (when field-value + (let ((value (ignore-errors (parse-integer field-value)))) + (or value + (error "Content-Length header field value is not a number -- ~A" + field-value)))))) + +(defun chunkedp (header) + (string= (ascii-header-value "transfer-encoding" header) "chunked")) + +(defun location (header) + (ascii-header-value "location" header)) + +(defun status-code (vector) + (let* ((space (position (acode #\Space) vector)) + (c1 (- (aref vector (incf space)) 48)) + (c2 (- (aref vector (incf space)) 48)) + (c3 (- (aref vector (incf space)) 48))) + (+ (* c1 100) + (* c2 10) + (* c3 1)))) + +(defun force-downcase-field-names (header) + (loop with data = (data header) + for start across (name-starts header) + for end across (name-ends header) + do (loop for i from start below end + for code = (aref data i) + do (setf (aref data i) (ascii-downcase code))))) + +(defun skip-white-forward (pos vector) + (position-if-not 'whitep vector :start pos)) + +(defun skip-white-backward (pos vector) + (let ((nonwhite (position-if-not 'whitep vector :end pos :from-end t))) + (if nonwhite + (1+ nonwhite) + pos))) + +(defun contract-field-value-indexes (header) + "Header field values exclude leading and trailing whitespace; adjust +the indexes in the header accordingly." + (loop with starts = (value-starts header) + with ends = (value-ends header) + with data = (data header) + for i from 0 + for start across starts + for end across ends + do + (setf (aref starts i) (skip-white-forward start data)) + (setf (aref ends i) (skip-white-backward end data)))) + +(defun next-line-pos (vector) + (let ((pos 0)) + (labels ((finish (&optional (i pos)) + (return-from next-line-pos i)) + (after-cr (code) + (acase code + (:lf (finish pos)) + (t (finish (1- pos))))) + (pending (code) + (acase code + (:cr #'after-cr) + (:lf (finish pos)) + (t #'pending)))) + (let ((state #'pending)) + (loop + (setf state (funcall state (aref vector pos))) + (incf pos)))))) + +(defun make-hvector () + (make-array 16 :fill-pointer 0 :adjustable t)) + +(defun process-header (vector) + "Create a HEADER instance from the octet data in VECTOR." + (let* ((name-starts (make-hvector)) + (name-ends (make-hvector)) + (value-starts (make-hvector)) + (value-ends (make-hvector)) + (header (make-instance 'header + :data vector + :status 999 + :name-starts name-starts + :name-ends name-ends + :value-starts value-starts + :value-ends value-ends)) + (mark nil) + (pos (next-line-pos vector))) + (unless pos + (error "Unable to process HTTP header")) + (setf (status header) (status-code vector)) + (labels ((save (value vector) + (vector-push-extend value vector)) + (mark () + (setf mark pos)) + (clear-mark () + (setf mark nil)) + (finish () + (if mark + (save mark value-ends) + (save pos value-ends)) + (force-downcase-field-names header) + (contract-field-value-indexes header) + (return-from process-header header)) + (in-new-line (code) + (acase code + ((#\Tab #\Space) (setf mark nil) #'in-value) + (t + (when mark + (save mark value-ends)) + (clear-mark) + (save pos name-starts) + (in-name code)))) + (after-cr (code) + (acase code + (:lf #'in-new-line) + (t (in-new-line code)))) + (pending-value (code) + (acase code + ((#\Tab #\Space) #'pending-value) + (:cr #'after-cr) + (:lf #'in-new-line) + (t (save pos value-starts) #'in-value))) + (in-name (code) + (acase code + (#\: + (save pos name-ends) + (save (1+ pos) value-starts) + #'in-value) + ((:cr :lf) + (finish)) + ((#\Tab #\Space) + (error "Unexpected whitespace in header field name")) + (t + (unless (<= 0 code 127) + (error "Unexpected non-ASCII header field name")) + #'in-name))) + (in-value (code) + (acase code + (:lf (mark) #'in-new-line) + (:cr (mark) #'after-cr) + (t #'in-value)))) + (let ((state #'in-new-line)) + (loop + (incf pos) + (when (<= (length vector) pos) + (error "No header found in response")) + (setf state (funcall state (aref vector pos)))))))) + + +;;; HTTP URL parsing + +(defclass url () + ((hostname + :initarg :hostname + :accessor hostname + :initform nil) + (port + :initarg :port + :accessor port + :initform 80) + (path + :initarg :path + :accessor path + :initform "/"))) + +(defun parse-urlstring (urlstring) + (setf urlstring (string-trim " " urlstring)) + (let* ((pos (mismatch urlstring "http://" :test 'char-equal)) + (mark pos) + (url (make-instance 'url))) + (labels ((save () + (subseq urlstring mark pos)) + (mark () + (setf mark pos)) + (finish () + (return-from parse-urlstring url)) + (hostname-char-p (char) + (position char "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." + :test 'char-equal)) + (at-start (char) + (case char + (#\/ + (setf (port url) nil) + (mark) + #'in-path) + (t + #'in-host))) + (in-host (char) + (case char + ((#\/ :end) + (setf (hostname url) (save)) + (mark) + #'in-path) + (#\: + (setf (hostname url) (save)) + (mark) + #'in-port) + (t + (unless (hostname-char-p char) + (error "~S is not a valid URL" urlstring)) + #'in-host))) + (in-port (char) + (case char + ((#\/ :end) + (setf (port url) + (parse-integer urlstring + :start (1+ mark) + :end pos)) + (mark) + #'in-path) + (t + (unless (digit-char-p char) + (error "Bad port in URL ~S" urlstring)) + #'in-port))) + (in-path (char) + (case char + ((#\# :end) + (setf (path url) (save)) + (finish))) + #'in-path)) + (let ((state #'at-start)) + (loop + (when (<= (length urlstring) pos) + (funcall state :end) + (finish)) + (setf state (funcall state (aref urlstring pos))) + (incf pos)))))) + +(defun url (thing) + (if (stringp thing) + (parse-urlstring thing) + thing)) + +(defgeneric request-buffer (method url) + (:method (method url) + (setf url (url url)) + (make-request-buffer (hostname url) (port url) (path url) + :method method))) + +(defun urlstring (url) + (format nil "~@[http://~A~]~@[:~D~]~A" + (hostname url) + (and (/= 80 (port url)) (port url)) + (path url))) + +(defmethod print-object ((url url) stream) + (print-unreadable-object (url stream :type t) + (prin1 (urlstring url) stream))) + +(defun merge-urls (url1 url2) + (setf url1 (url url1)) + (setf url2 (url url2)) + (make-instance 'url + :hostname (or (hostname url1) + (hostname url2)) + :port (or (port url1) + (port url2)) + :path (or (path url1) + (path url2)))) + + +;;; Requesting an URL and saving it to a file + +(defparameter *maximum-redirects* 10) +(defvar *default-url-defaults* (url "http://src.quicklisp.org/")) + +(defun read-http-header (cbuf) + (let ((header-data (sink-until-matching (list (acode-matcher :lf :lf) + (acode-matcher :cr :cr) + (acode-matcher :cr :lf :cr :lf)) + cbuf))) + (process-header header-data))) + +(defun read-chunk-header (cbuf) + (let* ((header-data (sink-until-matching (acode-matcher :cr :lf) cbuf)) + (end (or (position (acode :cr) header-data) + (position (acode #\;) header-data)))) + (values (parse-integer (ascii-subseq header-data 0 end) :radix 16)))) + +(defun save-chunk-response (stream cbuf) + "For a chunked response, read all chunks and write them to STREAM." + (let ((fun (make-stream-writer stream)) + (matcher (acode-matcher :cr :lf))) + (loop + (let ((chunk-size (read-chunk-header cbuf))) + (when (zerop chunk-size) + (return)) + (call-for-n-octets chunk-size fun cbuf) + (skip-until-matching matcher cbuf))))) + +(defun save-response (file header cbuf) + (with-open-file (stream file + :direction :output + :if-exists :supersede + :element-type 'octet) + (let ((content-length (content-length header))) + (cond ((chunkedp header) + (save-chunk-response stream cbuf)) + (content-length + (call-for-n-octets content-length + (make-stream-writer stream) + cbuf)) + (t + (call-until-end (make-stream-writer stream) cbuf)))))) + +(defun call-with-progress-bar (size fun) + (let ((progress-bar (make-progress-bar size))) + (start-display progress-bar) + (flet ((update (condition) + (update-progress progress-bar + (cbuf-progress-size condition)))) + (handler-bind ((cbuf-progress #'update)) + (funcall fun))) + (finish-display progress-bar))) + +(defun fetch (url file &key (follow-redirects t) quietly + (maximum-redirects *maximum-redirects*)) + "Request URL and write the body of the response to FILE." + (setf url (merge-urls url *default-url-defaults*)) + (setf file (merge-pathnames file)) + (let ((redirect-count 0) + (original-url url) + (connect-url (or (url *proxy-url*) url)) + (stream (if quietly + (make-broadcast-stream) + *trace-output*))) + (loop + (when (<= maximum-redirects redirect-count) + (error "Too many redirects for ~A" original-url)) + (with-connection (connection (hostname connect-url) (port connect-url)) + (let ((cbuf (make-instance 'cbuf :connection connection)) + (request (request-buffer "GET" url))) + (write-octets request connection) + (let ((header (read-http-header cbuf))) + (loop while (= (status header) 100) + do (setf header (read-http-header cbuf))) + (cond ((= (status header) 200) + (let ((size (content-length header))) + (format stream "~&; Fetching ~A~%" url) + (if (and (numberp size) + (plusp size)) + (format stream "; ~$KB~%" (/ size 1024)) + (format stream "; Unknown size~%")) + (if quietly + (save-response file header cbuf) + (call-with-progress-bar (content-length header) + (lambda () + (save-response file header cbuf)))))) + ((not (<= 300 (status header) 399)) + (error "Unexpected status for ~A: ~A" + url (status header)))) + (if (and follow-redirects (<= 300 (status header) 399)) + (let ((new-urlstring (ascii-header-value "location" header))) + (when (not new-urlstring) + (error "Redirect code ~D received, but no Location: header" + (status header))) + (incf redirect-count) + (setf url (merge-urls new-urlstring + url)) + (format stream "~&; Redirecting to ~A~%" url)) + (return (values header (and file (probe-file file))))))))))) + + +;;; A primitive tar unpacker + +(in-package #:qlqs-minitar) + +(defun make-block-buffer () + (make-array 512 :element-type '(unsigned-byte 8) :initial-element 0)) + +(defun skip-n-blocks (n stream) + (let ((block (make-block-buffer))) + (dotimes (i n) + (read-sequence block stream)))) + +(defun ascii-subseq (vector start end) + (let ((string (make-string (- end start)))) + (loop for i from 0 + for j from start below end + do (setf (char string i) (code-char (aref vector j)))) + string)) + +(defun block-asciiz-string (block start length) + (let* ((end (+ start length)) + (eos (or (position 0 block :start start :end end) + end))) + (ascii-subseq block start eos))) + +(defun prefix (header) + (when (plusp (aref header 345)) + (block-asciiz-string header 345 155))) + +(defun name (header) + (block-asciiz-string header 0 100)) + +(defun payload-size (header) + (values (parse-integer (block-asciiz-string header 124 12) :radix 8))) + +(defun nth-block (n file) + (with-open-file (stream file :element-type '(unsigned-byte 8)) + (let ((block (make-block-buffer))) + (skip-n-blocks (1- n) stream) + (read-sequence block stream) + block))) + +(defun payload-type (code) + (case code + (0 :file) + (48 :file) + (53 :directory) + (t :unsupported))) + +(defun full-path (header) + (let ((prefix (prefix header)) + (name (name header))) + (if prefix + (format nil "~A/~A" prefix name) + name))) + +(defun save-file (file size stream) + (multiple-value-bind (full-blocks partial) + (truncate size 512) + (ensure-directories-exist file) + (with-open-file (outstream file + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (let ((block (make-block-buffer))) + (dotimes (i full-blocks) + (read-sequence block stream) + (write-sequence block outstream)) + (when (plusp partial) + (read-sequence block stream) + (write-sequence block outstream :end partial)))))) + +(defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*)) + (let ((block (make-block-buffer))) + (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) + (loop + (let ((size (read-sequence block stream))) + (when (zerop size) + (return)) + (unless (= size 512) + (error "Bad size on tarfile")) + (when (every #'zerop block) + (return)) + (let* ((payload-code (aref block 156)) + (payload-type (payload-type payload-code)) + (tar-path (full-path block)) + (full-path (merge-pathnames tar-path directory)) + (payload-size (payload-size block))) + (case payload-type + (:file + (save-file full-path payload-size stream)) + (:directory + (ensure-directories-exist full-path)) + (t + (warn "Unknown tar block payload code -- ~D" payload-code) + (skip-n-blocks (ceiling (payload-size block) 512) stream))))))))) + +(defun contents (tarfile) + (let ((block (make-block-buffer)) + (result '())) + (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) + (loop + (let ((size (read-sequence block stream))) + (when (zerop size) + (return (nreverse result))) + (unless (= size 512) + (error "Bad size on tarfile")) + (when (every #'zerop block) + (return (nreverse result))) + (let* ((payload-type (payload-type (aref block 156))) + (tar-path (full-path block)) + (payload-size (payload-size block))) + (skip-n-blocks (ceiling payload-size 512) stream) + (case payload-type + (:file + (push tar-path result)) + (:directory + (push tar-path result))))))))) + + +;;; +;;; The actual bootstrapping work +;;; + +(in-package #:quicklisp-quickstart) + +(defvar *home* + (merge-pathnames (make-pathname :directory '(:relative "quicklisp")) + (user-homedir-pathname))) + +(defun qmerge (pathname) + (merge-pathnames pathname *home*)) + +(defun renaming-fetch (url file) + (let ((tmpfile (qmerge "tmp/fetch.dat"))) + (fetch url tmpfile) + (rename-file tmpfile file))) + +(defvar *quickstart-parameters* nil + "This plist is populated with parameters that may carry over to the + initial configuration of the client, e.g. :proxy-url + or :initial-dist-url") + +(defvar *quicklisp-hostname* "beta.quicklisp.org") + +(defvar *client-info-url* + (format nil "http://~A/client/quicklisp.sexp" + *quicklisp-hostname*)) + +(defclass client-info () + ((setup-url + :reader setup-url + :initarg :setup-url) + (asdf-url + :reader asdf-url + :initarg :asdf-url) + (client-tar-url + :reader client-tar-url + :initarg :client-tar-url) + (version + :reader version + :initarg :version) + (plist + :reader plist + :initarg :plist) + (source-file + :reader source-file + :initarg :source-file))) + +(defmethod print-object ((client-info client-info) stream) + (print-unreadable-object (client-info stream :type t) + (prin1 (version client-info) stream))) + +(defun safely-read (stream) + (let ((*read-eval* nil)) + (read stream))) + +(defun fetch-client-info-plist (url) + "Fetch and return the client info data at URL." + (let ((local-client-info-file (qmerge "tmp/client-info.sexp"))) + (ensure-directories-exist local-client-info-file) + (renaming-fetch url local-client-info-file) + (with-open-file (stream local-client-info-file) + (list* :source-file local-client-info-file + (safely-read stream))))) + +(defun fetch-client-info (url) + (let ((plist (fetch-client-info-plist url))) + (destructuring-bind (&key setup asdf client-tar version + source-file + &allow-other-keys) + plist + (unless (and setup asdf client-tar version) + (error "Invalid data from client info URL -- ~A" url)) + (make-instance 'client-info + :setup-url (getf setup :url) + :asdf-url (getf asdf :url) + :client-tar-url (getf client-tar :url) + :version version + :plist plist + :source-file source-file)))) + +(defun client-info-url-from-version (version) + (format nil "http://~A/client/~A/client-info.sexp" + *quicklisp-hostname* + version)) + +(defun distinfo-url-from-version (version) + (format nil "http://~A/dist/~A/distinfo.txt" + *quicklisp-hostname* + version)) + +(defvar *help-message* + (format nil "~&~% ==== quicklisp quickstart install help ====~%~% ~ + quicklisp-quickstart:install can take the following ~ + optional arguments:~%~% ~ + :path \"/path/to/installation/\"~%~% ~ + :proxy \"http://your.proxy:port/\"~%~% ~ + :client-url ~%~% ~ + :client-version ~%~% ~ + :dist-url ~%~% ~ + :dist-version ~%~%")) + +(defvar *after-load-message* + (format nil "~&~% ==== quicklisp quickstart ~A loaded ====~%~% ~ + To continue with installation, evaluate: (quicklisp-quickstart:install)~%~% ~ + For installation options, evaluate: (quicklisp-quickstart:help)~%~%" + qlqs-info:*version*)) + +(defvar *after-initial-setup-message* + (with-output-to-string (*standard-output*) + (format t "~&~% ==== quicklisp installed ====~%~%") + (format t " To load a system, use: (ql:quickload \"system-name\")~%~%") + (format t " To find systems, use: (ql:system-apropos \"term\")~%~%") + (format t " To load Quicklisp every time you start Lisp, use: (ql:add-to-init-file)~%~%") + (format t " For more information, see http://www.quicklisp.org/beta/~%~%"))) + +(defun initial-install (&key (client-url *client-info-url*) dist-url) + (setf *quickstart-parameters* + (list :proxy-url *proxy-url* + :initial-dist-url dist-url)) + (ensure-directories-exist (qmerge "tmp/")) + (let ((client-info (fetch-client-info client-url)) + (tmptar (qmerge "tmp/quicklisp.tar")) + (setup (qmerge "setup.lisp")) + (asdf (qmerge "asdf.lisp"))) + (renaming-fetch (client-tar-url client-info) tmptar) + (unpack-tarball tmptar :directory (qmerge "./")) + (renaming-fetch (setup-url client-info) setup) + (renaming-fetch (asdf-url client-info) asdf) + (rename-file (source-file client-info) (qmerge "client-info.sexp")) + (load setup :verbose nil :print nil) + (write-string *after-initial-setup-message*) + (finish-output))) + +(defun help () + (write-string *help-message*) + t) + +(defun non-empty-file-namestring (pathname) + (let ((string (file-namestring pathname))) + (unless (or (null string) + (equal string "")) + string))) + +(defun install (&key ((:path *home*) *home*) + ((:proxy *proxy-url*) *proxy-url*) + client-url + client-version + dist-url + dist-version) + (setf *home* (merge-pathnames *home* (truename *default-pathname-defaults*))) + (let ((name (non-empty-file-namestring *home*))) + (when name + (warn "Making ~A part of the install pathname directory" + name) + ;; This corrects a pathname like "/foo/bar" to "/foo/bar/" and + ;; "foo" to "foo/" + (setf *home* + (make-pathname :defaults *home* + :directory (append (pathname-directory *home*) + (list name)))))) + (let ((setup-file (qmerge "setup.lisp"))) + (when (probe-file setup-file) + (multiple-value-bind (result proceed) + (with-simple-restart (load-setup "Load ~S" setup-file) + (error "Quicklisp has already been installed. Load ~S instead." + setup-file)) + (declare (ignore result)) + (when proceed + (return-from install (load setup-file)))))) + (if (find-package '#:ql) + (progn + (write-line "!!! Quicklisp has already been set up. !!!") + (write-string *after-initial-setup-message*) + t) + (call-with-quiet-compilation + (lambda () + (let ((client-url (or client-url + (and client-version + (client-info-url-from-version client-version)) + *client-info-url*)) + ;; It's ok for dist-url to be nil; there's a default in + ;; the client + (dist-url (or dist-url + (and dist-version + (distinfo-url-from-version dist-version))))) + (initial-install :client-url client-url + :dist-url dist-url)))))) + +(write-string *after-load-message*) + +;;; End of quicklisp.lisp diff --git a/sbcl/.quicklisp/asdf.lisp b/sbcl/.quicklisp/asdf.lisp new file mode 100644 index 0000000..283ad86 --- /dev/null +++ b/sbcl/.quicklisp/asdf.lisp @@ -0,0 +1,4516 @@ +;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- +;;; This is ASDF 2.26: Another System Definition Facility. +;;; +;;; Feedback, bug reports, and patches are all welcome: +;;; please mail to . +;;; Note first that the canonical source for ASDF is presently +;;; . +;;; +;;; If you obtained this copy from anywhere else, and you experience +;;; trouble using it, or find bugs, you may want to check at the +;;; location above for a more recent version (and for documentation +;;; and test files, if your copy came without them) before reporting +;;; bugs. There are usually two "supported" revisions - the git master +;;; branch is the latest development version, whereas the git release +;;; branch may be slightly older but is considered `stable' + +;;; -- LICENSE START +;;; (This is the MIT / X Consortium license as taken from +;;; http://www.opensource.org/licenses/mit-license.html on or about +;;; Monday; July 13, 2009) +;;; +;;; Copyright (c) 2001-2012 Daniel Barlow and contributors +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining +;;; a copy of this software and associated documentation files (the +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;;; +;;; -- LICENSE END + +;;; The problem with writing a defsystem replacement is bootstrapping: +;;; we can't use defsystem to compile it. Hence, all in one file. + +#+xcvb (module ()) + +(cl:in-package :common-lisp-user) +#+genera (in-package :future-common-lisp-user) + +#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) +(error "ASDF is not supported on your implementation. Please help us port it.") + +;;;; Create and setup packages in a way that is compatible with hot-upgrade. +;;;; See https://bugs.launchpad.net/asdf/+bug/485687 +;;;; See these two eval-when forms, and more near the end of the file. + +#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this + +(eval-when (:load-toplevel :compile-toplevel :execute) + ;;; Before we do anything, some implementation-dependent tweaks + ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. + #+allegro + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below + #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 + (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all + (and (= system::*gcl-major-version* 2) + (< system::*gcl-minor-version* 7))) + (pushnew :gcl-pre2.7 *features*)) + #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) + clozure lispworks (and sbcl sb-unicode) scl) + (pushnew :asdf-unicode *features*) + ;;; make package if it doesn't exist yet. + ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. + (unless (find-package :asdf) + (make-package :asdf :use '(:common-lisp)))) + +(in-package :asdf) + +(eval-when (:load-toplevel :compile-toplevel :execute) + ;;; This would belong amongst implementation-dependent tweaks above, + ;;; except that the defun has to be in package asdf. + #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) + #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) + #+mkcl (require :cmp) + #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics + + ;;; Package setup, step 2. + (defvar *asdf-version* nil) + (defvar *upgraded-p* nil) + (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. + (defun find-symbol* (s p) + (find-symbol (string s) p)) + ;; Strip out formatting that is not supported on Genera. + ;; Has to be inside the eval-when to make Lispworks happy (!) + (defun strcat (&rest strings) + (apply 'concatenate 'string strings)) + (defmacro compatfmt (format) + #-(or gcl genera) format + #+(or gcl genera) + (loop :for (unsupported . replacement) :in + (append + '(("~3i~_" . "")) + #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do + (loop :for found = (search unsupported format) :while found :do + (setf format (strcat (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) + format) + (let* (;; For bug reporting sanity, please always bump this version when you modify this file. + ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version + ;; can help you do these changes in synch (look at the source for documentation). + ;; Relying on its automation, the version is now redundantly present on top of this file. + ;; "2.345" would be an official release + ;; "2.345.6" would be a development version in the official upstream + ;; "2.345.0.7" would be your seventh local modification of official release 2.345 + ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 + (asdf-version "2.26") + (existing-asdf (find-class 'component nil)) + (existing-version *asdf-version*) + (already-there (equal asdf-version existing-version))) + (unless (and existing-asdf already-there) + (when (and existing-asdf *asdf-verbose*) + (format *trace-output* + (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") + existing-version asdf-version)) + (labels + ((present-symbol-p (symbol package) + (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external))) + (present-symbols (package) + ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera + (let (l) + (do-symbols (s package) + (when (present-symbol-p s package) (push s l))) + (reverse l))) + (unlink-package (package) + (let ((u (find-package package))) + (when u + (ensure-unintern u (present-symbols u)) + (loop :for p :in (package-used-by-list u) :do + (unuse-package u p)) + (delete-package u)))) + (ensure-exists (name nicknames use) + (let ((previous + (remove-duplicates + (mapcar #'find-package (cons name nicknames)) + :from-end t))) + ;; do away with packages with conflicting (nick)names + (map () #'unlink-package (cdr previous)) + ;; reuse previous package with same name + (let ((p (car previous))) + (cond + (p + (rename-package p name nicknames) + (ensure-use p use) + p) + (t + (make-package name :nicknames nicknames :use use)))))) + (intern* (symbol package) + (intern (string symbol) package)) + (remove-symbol (symbol package) + (let ((sym (find-symbol* symbol package))) + (when sym + #-cormanlisp (unexport sym package) + (unintern sym package) + sym))) + (ensure-unintern (package symbols) + (loop :with packages = (list-all-packages) + :for sym :in symbols + :for removed = (remove-symbol sym package) + :when removed :do + (loop :for p :in packages :do + (when (eq removed (find-symbol* sym p)) + (unintern removed p))))) + (ensure-shadow (package symbols) + (shadow symbols package)) + (ensure-use (package use) + (dolist (used (package-use-list package)) + (unless (member (package-name used) use :test 'string=) + (unuse-package used) + (do-external-symbols (sym used) + (when (eq sym (find-symbol* sym package)) + (remove-symbol sym package))))) + (dolist (used (reverse use)) + (do-external-symbols (sym used) + (unless (eq sym (find-symbol* sym package)) + (remove-symbol sym package))) + (use-package used package))) + (ensure-fmakunbound (package symbols) + (loop :for name :in symbols + :for sym = (find-symbol* name package) + :when sym :do (fmakunbound sym))) + (ensure-export (package export) + (let ((formerly-exported-symbols nil) + (bothly-exported-symbols nil) + (newly-exported-symbols nil)) + (do-external-symbols (sym package) + (if (member sym export :test 'string-equal) + (push sym bothly-exported-symbols) + (push sym formerly-exported-symbols))) + (loop :for sym :in export :do + (unless (member sym bothly-exported-symbols :test 'equal) + (push sym newly-exported-symbols))) + (loop :for user :in (package-used-by-list package) + :for shadowing = (package-shadowing-symbols user) :do + (loop :for new :in newly-exported-symbols + :for old = (find-symbol* new user) + :when (and old (not (member old shadowing))) + :do (unintern old user))) + (loop :for x :in newly-exported-symbols :do + (export (intern* x package))))) + (ensure-package (name &key nicknames use unintern + shadow export redefined-functions) + (let* ((p (ensure-exists name nicknames use))) + (ensure-unintern p (append unintern #+cmu redefined-functions)) + (ensure-shadow p shadow) + (ensure-export p export) + #-cmu (ensure-fmakunbound p redefined-functions) + p))) + (macrolet + ((pkgdcl (name &key nicknames use export + redefined-functions unintern shadow) + `(ensure-package + ',name :nicknames ',nicknames :use ',use :export ',export + :shadow ',shadow + :unintern ',unintern + :redefined-functions ',redefined-functions))) + (pkgdcl + :asdf + :use (:common-lisp) + :redefined-functions + (#:perform #:explain #:output-files #:operation-done-p + #:perform-with-restarts #:component-relative-pathname + #:system-source-file #:operate #:find-component #:find-system + #:apply-output-translations #:translate-pathname* #:resolve-location + #:system-relative-pathname + #:inherit-source-registry #:process-source-registry + #:process-source-registry-directive + #:compile-file* #:source-file-type) + :unintern + (#:*asdf-revision* #:around #:asdf-method-combination + #:split #:make-collector #:do-dep #:do-one-dep + #:resolve-relative-location-component #:resolve-absolute-location-component + #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function + :export + (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command + #:system-definition-pathname #:with-system-definitions + #:search-for-system-definition #:find-component #:component-find-path + #:compile-system #:load-system #:load-systems + #:require-system #:test-system #:clear-system + #:operation #:compile-op #:load-op #:load-source-op #:test-op + #:feature #:version #:version-satisfies + #:upgrade-asdf + #:implementation-identifier #:implementation-type #:hostname + #:input-files #:output-files #:output-file #:perform + #:operation-done-p #:explain + + #:component #:source-file + #:c-source-file #:cl-source-file #:java-source-file + #:cl-source-file.cl #:cl-source-file.lsp + #:static-file + #:doc-file + #:html-file + #:text-file + #:source-file-type + #:module ; components + #:system + #:unix-dso + + #:module-components ; component accessors + #:module-components-by-name + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + #:component-depends-on + #:component-encoding + #:component-external-format + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + #:system-licence + #:system-source-file + #:system-source-directory + #:system-relative-pathname + #:map-systems + + #:operation-description + #:operation-on-warnings + #:operation-on-failure + #:component-visited-p + + #:*system-definition-search-functions* ; variables + #:*central-registry* + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*resolve-symlinks* + #:*load-system-operation* + #:*asdf-verbose* + #:*verbose-out* + + #:asdf-version + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-name + #:error-pathname + #:load-system-definition-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-component-of-version + #:missing-dependency + #:missing-dependency-of-version + #:circular-dependency ; errors + #:duplicate-names + + #:try-recompiling + #:retry + #:accept ; restarts + #:coerce-entry-to-directory + #:remove-entry-from-registry + + #:*encoding-detection-hook* + #:*encoding-external-format-hook* + #:*default-encoding* + #:*utf-8-external-format* + + #:clear-configuration + #:*output-translations-parameter* + #:initialize-output-translations + #:disable-output-translations + #:clear-output-translations + #:ensure-output-translations + #:apply-output-translations + #:compile-file* + #:compile-file-pathname* + #:enable-asdf-binary-locations-compatibility + #:*default-source-registries* + #:*source-registry-parameter* + #:initialize-source-registry + #:compute-source-registry + #:clear-source-registry + #:ensure-source-registry + #:process-source-registry + #:system-registered-p #:registered-systems #:loaded-systems + #:resolve-location + #:asdf-message + #:user-output-translations-pathname + #:system-output-translations-pathname + #:user-output-translations-directory-pathname + #:system-output-translations-directory-pathname + #:user-source-registry + #:system-source-registry + #:user-source-registry-directory + #:system-source-registry-directory + + ;; Utilities: please use asdf-utils instead + #| + ;; #:aif #:it + ;; #:appendf #:orf + #:length=n-p + #:remove-keys #:remove-keyword + #:first-char #:last-char #:string-suffix-p + #:coerce-name + #:directory-pathname-p #:ensure-directory-pathname + #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root + #:getenv #:getenv-pathname #:getenv-pathnames + #:getenv-absolute-directory #:getenv-absolute-directories + #:probe-file* + #:find-symbol* #:strcat + #:make-pathname-component-logical #:make-pathname-logical + #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname* + #:pathname-directory-pathname #:pathname-parent-directory-pathname + #:read-file-forms + #:resolve-symlinks #:truenamize + #:split-string + #:component-name-to-pathname-components + #:split-name-type + #:subdirectories #:directory-files + #:while-collecting + #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* + #:*wild-path* #:wilden + #:directorize-pathname-host-device|# + ))) + #+genera (import 'scl:boolean :asdf) + (setf *asdf-version* asdf-version + *upgraded-p* (if existing-version + (cons existing-version *upgraded-p*) + *upgraded-p*)))))) + +;;;; ------------------------------------------------------------------------- +;;;; User-visible parameters +;;;; +(defvar *resolve-symlinks* t + "Determine whether or not ASDF resolves symlinks when defining systems. + +Defaults to T.") + +(defvar *compile-file-warnings-behaviour* + (or #+clisp :ignore :warn) + "How should ASDF react if it encounters a warning when compiling a file? +Valid values are :error, :warn, and :ignore.") + +(defvar *compile-file-failure-behaviour* + (or #+sbcl :error #+clisp :ignore :warn) + "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) +when compiling a file? Valid values are :error, :warn, and :ignore. +Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") + +(defvar *verbose-out* nil) + +(defparameter +asdf-methods+ + '(perform-with-restarts perform explain output-files operation-done-p)) + +(defvar *load-system-operation* 'load-op + "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP. +You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle, +or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") + +(defvar *compile-op-compile-file-function* 'compile-file* + "Function used to compile lisp files.") + + + +#+allegro +(eval-when (:compile-toplevel :execute) + (defparameter *acl-warn-save* + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + excl:*warn-on-nested-reader-conditionals*)) + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + (setf excl:*warn-on-nested-reader-conditionals* nil))) + +;;;; ------------------------------------------------------------------------- +;;;; Resolve forward references + +(declaim (ftype (function (t) t) + format-arguments format-control + error-name error-pathname error-condition + duplicate-names-name + error-component error-operation + module-components module-components-by-name + circular-dependency-components + condition-arguments condition-form + condition-format condition-location + coerce-name) + (ftype (function (&optional t) (values)) initialize-source-registry) + #-(or cormanlisp gcl-pre2.7) + (ftype (function (t t) t) (setf module-components-by-name))) + +;;;; ------------------------------------------------------------------------- +;;;; Compatibility various implementations +#+cormanlisp +(progn + (deftype logical-pathname () nil) + (defun make-broadcast-stream () *error-output*) + (defun translate-logical-pathname (x) x) + (defun file-namestring (p) + (setf p (pathname p)) + (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) + +#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl + (read-from-string + "(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) + (ccl:define-entry-point (_system \"system\") ((name :string)) :int) + ;; Note: ASDF may expect user-homedir-pathname to provide + ;; the pathname of the current user's home directory, whereas + ;; MCL by default provides the directory from which MCL was started. + ;; See http://code.google.com/p/mcl/wiki/Portability + (defun current-user-homedir-pathname () + (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) + (defun probe-posix (posix-namestring) + \"If a file exists for the posix namestring, return the pathname\" + (ccl::with-cstrs ((cpath posix-namestring)) + (ccl::rlet ((is-dir :boolean) + (fsref :fsref)) + (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) + (ccl::%path-from-fsref fsref is-dir))))))")) + +;;;; ------------------------------------------------------------------------- +;;;; General Purpose Utilities + +(macrolet + ((defdef (def* def) + `(defmacro ,def* (name formals &rest rest) + `(progn + #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name) + #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( + ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl + `(declaim (notinline ,name))) + (,',def ,name ,formals ,@rest))))) + (defdef defgeneric* defgeneric) + (defdef defun* defun)) + +(defmacro while-collecting ((&rest collectors) &body body) + "COLLECTORS should be a list of names for collections. A collector +defines a function that, when applied to an argument inside BODY, will +add its argument to the corresponding collection. Returns multiple values, +a list for each collection, in order. + E.g., +\(while-collecting \(foo bar\) + \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) + \(foo \(first x\)\) + \(bar \(second x\)\)\)\) +Returns two values: \(A B C\) and \(1 2 3\)." + (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) + (initial-values (mapcar (constantly nil) collectors))) + `(let ,(mapcar #'list vars initial-values) + (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) + ,@body + (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) + +(defmacro aif (test then &optional else) + "Anaphoric version of IF, On Lisp style" + `(let ((it ,test)) (if it ,then ,else))) + +(defun* pathname-directory-pathname (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME, TYPE and VERSION components" + (when pathname + (make-pathname :name nil :type nil :version nil :defaults pathname))) + +(defun* normalize-pathname-directory-component (directory) + "Given a pathname directory component, return an equivalent form that is a list" + (cond + #-(or cmu sbcl scl) ;; these implementations already normalize directory components. + ((stringp directory) `(:absolute ,directory) directory) + #+gcl + ((and (consp directory) (stringp (first directory))) + `(:absolute ,@directory)) + ((or (null directory) + (and (consp directory) (member (first directory) '(:absolute :relative)))) + directory) + (t + (error (compatfmt "~@") directory)))) + +(defun* merge-pathname-directory-components (specified defaults) + ;; Helper for merge-pathnames* that handles directory components. + (let ((directory (normalize-pathname-directory-component specified))) + (ecase (first directory) + ((nil) defaults) + (:absolute specified) + (:relative + (let ((defdir (normalize-pathname-directory-component defaults)) + (reldir (cdr directory))) + (cond + ((null defdir) + directory) + ((not (eq :back (first reldir))) + (append defdir reldir)) + (t + (loop :with defabs = (first defdir) + :with defrev = (reverse (rest defdir)) + :while (and (eq :back (car reldir)) + (or (and (eq :absolute defabs) (null defrev)) + (stringp (car defrev)))) + :do (pop reldir) (pop defrev) + :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) + +(defun* make-pathname-component-logical (x) + "Make a pathname component suitable for use in a logical-pathname" + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + +(defun* make-pathname-logical (pathname host) + "Take a PATHNAME's directory, name, type and version components, +and make a new pathname with corresponding components and specified logical HOST" + (make-pathname + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname)))) + +(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) + "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that +if the SPECIFIED pathname does not have an absolute directory, +then the HOST and DEVICE both come from the DEFAULTS, whereas +if the SPECIFIED pathname does have an absolute directory, +then the HOST and DEVICE both come from the SPECIFIED. +Also, if either argument is NIL, then the other argument is returned unmodified." + (when (null specified) (return-from merge-pathnames* defaults)) + (when (null defaults) (return-from merge-pathnames* specified)) + #+scl + (ext:resolve-pathname specified defaults) + #-scl + (let* ((specified (pathname specified)) + (defaults (pathname defaults)) + (directory (normalize-pathname-directory-component (pathname-directory specified))) + (name (or (pathname-name specified) (pathname-name defaults))) + (type (or (pathname-type specified) (pathname-type defaults))) + (version (or (pathname-version specified) (pathname-version defaults)))) + (labels ((unspecific-handler (p) + (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) + (multiple-value-bind (host device directory unspecific-handler) + (ecase (first directory) + ((:absolute) + (values (pathname-host specified) + (pathname-device specified) + directory + (unspecific-handler specified))) + ((nil :relative) + (values (pathname-host defaults) + (pathname-device defaults) + (merge-pathname-directory-components directory (pathname-directory defaults)) + (unspecific-handler defaults)))) + (make-pathname :host host :device device :directory directory + :name (funcall unspecific-handler name) + :type (funcall unspecific-handler type) + :version (funcall unspecific-handler version)))))) + +(defun* pathname-parent-directory-pathname (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME, TYPE and VERSION components" + (when pathname + (make-pathname :name nil :type nil :version nil + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) + +(define-modify-macro appendf (&rest args) + append "Append onto list") ;; only to be used on short lists. + +(define-modify-macro orf (&rest args) + or "or a flag") + +(defun* first-char (s) + (and (stringp s) (plusp (length s)) (char s 0))) + +(defun* last-char (s) + (and (stringp s) (plusp (length s)) (char s (1- (length s))))) + + +(defun* asdf-message (format-string &rest format-args) + (declare (dynamic-extent format-args)) + (apply 'format *verbose-out* format-string format-args)) + +(defun* split-string (string &key max (separator '(#\Space #\Tab))) + "Split STRING into a list of components separated by +any of the characters in the sequence SEPARATOR. +If MAX is specified, then no more than max(1,MAX) components will be returned, +starting the separation from the end, e.g. when called with arguments + \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." + (catch nil + (let ((list nil) (words 0) (end (length string))) + (flet ((separatorp (char) (find char separator)) + (done () (throw nil (cons (subseq string 0 end) list)))) + (loop + :for start = (if (and max (>= words (1- max))) + (done) + (position-if #'separatorp string :end end :from-end t)) :do + (when (null start) + (done)) + (push (subseq string (1+ start) end) list) + (incf words) + (setf end start)))))) + +(defun* split-name-type (filename) + (let ((unspecific + ;; Giving :unspecific as argument to make-pathname is not portable. + ;; See CLHS make-pathname and 19.2.2.2.3. + ;; We only use it on implementations that support it, + #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific + #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)) + (destructuring-bind (name &optional (type unspecific)) + (split-string filename :max 2 :separator ".") + (if (equal name "") + (values filename unspecific) + (values name type))))) + +(defun* component-name-to-pathname-components (s &key force-directory force-relative) + "Splits the path string S, returning three values: +A flag that is either :absolute or :relative, indicating + how the rest of the values are to be interpreted. +A directory path --- a list of strings, suitable for + use with MAKE-PATHNAME when prepended with the flag + value. +A filename with type extension, possibly NIL in the + case of a directory pathname. +FORCE-DIRECTORY forces S to be interpreted as a directory +pathname \(third return value will be NIL, final component +of S will be treated as part of the directory path. + +The intention of this function is to support structured component names, +e.g., \(:file \"foo/bar\"\), which will be unpacked to relative +pathnames." + (check-type s string) + (when (find #\: s) + (error (compatfmt "~@") s)) + (let* ((components (split-string s :separator "/")) + (last-comp (car (last components)))) + (multiple-value-bind (relative components) + (if (equal (first components) "") + (if (equal (first-char s) #\/) + (progn + (when force-relative + (error (compatfmt "~@") s)) + (values :absolute (cdr components))) + (values :relative nil)) + (values :relative components)) + (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components)) + (setf components (substitute :back ".." components :test #'equal)) + (cond + ((equal last-comp "") + (values relative components nil)) ; "" already removed + (force-directory + (values relative components nil)) + (t + (values relative (butlast components) last-comp)))))) + +(defun* remove-keys (key-names args) + (loop :for (name val) :on args :by #'cddr + :unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + :append (list name val))) + +(defun* remove-keyword (key args) + (loop :for (k v) :on args :by #'cddr + :unless (eq k key) + :append (list k v))) + +(defun* getenv (x) + (declare (ignorable x)) + #+(or abcl clisp ecl xcl) (ext:getenv x) + #+allegro (sys:getenv x) + #+clozure (ccl:getenv x) + #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) + #+cormanlisp + (let* ((buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string x)) + (needed-size (win:getenvironmentvariable cname buffer 0)) + (buffer1 (ct:malloc (1+ needed-size)))) + (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer) + (ct:free buffer1))) + #+gcl (system:getenv x) + #+genera nil + #+lispworks (lispworks:environment-variable x) + #+mcl (ccl:with-cstrs ((name x)) + (let ((value (_getenv name))) + (unless (ccl:%null-ptr-p value) + (ccl:%get-cstring value)))) + #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x) + #+sbcl (sb-ext:posix-getenv x) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + (error "~S is not supported on your implementation" 'getenv)) + +(defun* directory-pathname-p (pathname) + "Does PATHNAME represent a directory? + +A directory-pathname is a pathname _without_ a filename. The three +ways that the filename components can be missing are for it to be NIL, +:UNSPECIFIC or the empty string. + +Note that this does _not_ check to see that PATHNAME points to an +actually-existing directory." + (when pathname + (let ((pathname (pathname pathname))) + (flet ((check-one (x) + (member x '(nil :unspecific "") :test 'equal))) + (and (not (wild-pathname-p pathname)) + (check-one (pathname-name pathname)) + (check-one (pathname-type pathname)) + t))))) + +(defun* ensure-directory-pathname (pathspec) + "Converts the non-wild pathname designator PATHSPEC to directory form." + (cond + ((stringp pathspec) + (ensure-directory-pathname (pathname pathspec))) + ((not (pathnamep pathspec)) + (error (compatfmt "~@") pathspec)) + ((wild-pathname-p pathspec) + (error (compatfmt "~@") pathspec)) + ((directory-pathname-p pathspec) + pathspec) + (t + (make-pathname :directory (append (or (pathname-directory pathspec) + (list :relative)) + (list (file-namestring pathspec))) + :name nil :type nil :version nil + :defaults pathspec)))) + +#+genera +(unless (fboundp 'ensure-directories-exist) + (defun* ensure-directories-exist (path) + (fs:create-directories-recursively (pathname path)))) + +(defun* absolute-pathname-p (pathspec) + (and (typep pathspec '(or pathname string)) + (eq :absolute (car (pathname-directory (pathname pathspec)))))) + +(defun* coerce-pathname (name &key type defaults) + "coerce NAME into a PATHNAME. +When given a string, portably decompose it into a relative pathname: +#\\/ separates subdirectories. The last #\\/-separated string is as follows: +if TYPE is NIL, its last #\\. if any separates name and type from from type; +if TYPE is a string, it is the type, and the whole string is the name; +if TYPE is :DIRECTORY, the string is a directory component; +if the string is empty, it's a directory. +Any directory named .. is read as :BACK. +Host, device and version components are taken from DEFAULTS." + ;; The defaults are required notably because they provide the default host + ;; to the below make-pathname, which may crucially matter to people using + ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. + ;; NOTE that the host and device slots will be taken from the defaults, + ;; but that should only matter if you later merge relative pathnames with + ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* + (etypecase name + ((or null pathname) + name) + (symbol + (coerce-pathname (string-downcase name) :type type :defaults defaults)) + (string + (multiple-value-bind (relative path filename) + (component-name-to-pathname-components name :force-directory (eq type :directory) + :force-relative t) + (multiple-value-bind (name type) + (cond + ((or (eq type :directory) (null filename)) + (values nil nil)) + (type + (values filename type)) + (t + (split-name-type filename))) + (apply 'make-pathname :directory (cons relative path) :name name :type type + (when defaults `(:defaults ,defaults)))))))) + +(defun* merge-component-name-type (name &key type defaults) + ;; For backwards compatibility only, for people using internals. + ;; Will be removed in a future release, e.g. 2.016. + (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") + (coerce-pathname name :type type :defaults defaults)) + +(defun* subpathname (pathname subpath &key type) + (and pathname (merge-pathnames* (coerce-pathname subpath :type type) + (pathname-directory-pathname pathname)))) + +(defun subpathname* (pathname subpath &key type) + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) + +(defun* length=n-p (x n) ;is it that (= (length x) n) ? + (check-type n (integer 0 *)) + (loop + :for l = x :then (cdr l) + :for i :downfrom n :do + (cond + ((zerop i) (return (null l))) + ((not (consp l)) (return nil))))) + +(defun* string-suffix-p (s suffix) + (check-type s string) + (check-type suffix string) + (let ((start (- (length s) (length suffix)))) + (and (<= 0 start) + (string-equal s suffix :start1 start)))) + +(defun* read-file-forms (file) + (with-open-file (in file) + (loop :with eof = (list nil) + :for form = (read in nil eof) + :until (eq form eof) + :collect form))) + +(defun* pathname-root (pathname) + (make-pathname :directory '(:absolute) + :name nil :type nil :version nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + +(defun* probe-file* (p) + "when given a pathname P, probes the filesystem for a file or directory +with given pathname and if it exists return its truename." + (etypecase p + (null nil) + (string (probe-file* (parse-namestring p))) + (pathname (unless (wild-pathname-p p) + #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) + '(probe-file p) + #+clisp (aif (find-symbol* '#:probe-pathname :ext) + `(ignore-errors (,it p))) + '(ignore-errors (truename p))))))) + +(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) + "Resolve as much of a pathname as possible" + (block nil + (when (typep pathname '(or null logical-pathname)) (return pathname)) + (let ((p (merge-pathnames* pathname defaults))) + (when (typep p 'logical-pathname) (return p)) + (let ((found (probe-file* p))) + (when found (return found))) + (unless (absolute-pathname-p p) + (let ((true-defaults (ignore-errors (truename defaults)))) + (when true-defaults + (setf p (merge-pathnames pathname true-defaults))))) + (unless (absolute-pathname-p p) (return p)) + (let ((sofar (probe-file* (pathname-root p)))) + (unless sofar (return p)) + (flet ((solution (directories) + (merge-pathnames* + (make-pathname :host nil :device nil + :directory `(:relative ,@directories) + :name (pathname-name p) + :type (pathname-type p) + :version (pathname-version p)) + sofar))) + (loop :with directory = (normalize-pathname-directory-component + (pathname-directory p)) + :for component :in (cdr directory) + :for rest :on (cdr directory) + :for more = (probe-file* + (merge-pathnames* + (make-pathname :directory `(:relative ,component)) + sofar)) :do + (if more + (setf sofar more) + (return (solution rest))) + :finally + (return (solution nil)))))))) + +(defun* resolve-symlinks (path) + #-allegro (truenamize path) + #+allegro (if (typep path 'logical-pathname) + path + (excl:pathname-resolve-symbolic-links path))) + +(defun* resolve-symlinks* (path) + (if *resolve-symlinks* + (and path (resolve-symlinks path)) + path)) + +(defun* ensure-pathname-absolute (path) + (cond + ((absolute-pathname-p path) path) + ((stringp path) (ensure-pathname-absolute (pathname path))) + ((not (pathnamep path)) (error "not a valid pathname designator ~S" path)) + (t (let ((resolved (resolve-symlinks path))) + (assert (absolute-pathname-p resolved)) + resolved)))) + +(defun* default-directory () + (truenamize (pathname-directory-pathname *default-pathname-defaults*))) + +(defun* lispize-pathname (input-file) + (make-pathname :type "lisp" :defaults input-file)) + +(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*") +(defparameter *wild-file* + (make-pathname :name *wild* :type *wild* + :version (or #-(or abcl xcl) *wild*) :directory nil)) +(defparameter *wild-directory* + (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil)) +(defparameter *wild-inferiors* + (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil)) +(defparameter *wild-path* + (merge-pathnames *wild-file* *wild-inferiors*)) + +(defun* wilden (path) + (merge-pathnames* *wild-path* path)) + +#-scl +(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) + (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) + (last-char (namestring foo)))) + +#-scl +(defun* directorize-pathname-host-device (pathname) + (let* ((root (pathname-root pathname)) + (wild-root (wilden root)) + (absolute-pathname (merge-pathnames* pathname root)) + (separator (directory-separator-for-host root)) + (root-namestring (namestring root)) + (root-string + (substitute-if #\/ + #'(lambda (x) (or (eql x #\:) + (eql x separator))) + root-namestring))) + (multiple-value-bind (relative path filename) + (component-name-to-pathname-components root-string :force-directory t) + (declare (ignore relative filename)) + (let ((new-base + (make-pathname :defaults root + :directory `(:absolute ,@path)))) + (translate-pathname absolute-pathname wild-root (wilden new-base)))))) + +#+scl +(defun* directorize-pathname-host-device (pathname) + (let ((scheme (ext:pathname-scheme pathname)) + (host (pathname-host pathname)) + (port (ext:pathname-port pathname)) + (directory (pathname-directory pathname))) + (flet ((specificp (x) (and x (not (eq x :unspecific))))) + (if (or (specificp port) + (and (specificp host) (plusp (length host))) + (specificp scheme)) + (let ((prefix "")) + (when (specificp port) + (setf prefix (format nil ":~D" port))) + (when (and (specificp host) (plusp (length host))) + (setf prefix (strcat host prefix))) + (setf prefix (strcat ":" prefix)) + (when (specificp scheme) + (setf prefix (strcat scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + pathname))) + +;;;; ------------------------------------------------------------------------- +;;;; ASDF Interface, in terms of generic functions. +(defgeneric* find-system (system &optional error-p)) +(defgeneric* perform-with-restarts (operation component)) +(defgeneric* perform (operation component)) +(defgeneric* operation-done-p (operation component)) +(defgeneric* mark-operation-done (operation component)) +(defgeneric* explain (operation component)) +(defgeneric* output-files (operation component)) +(defgeneric* input-files (operation component)) +(defgeneric* component-operation-time (operation component)) +(defgeneric* operation-description (operation component) + (:documentation "returns a phrase that describes performing this operation +on this component, e.g. \"loading /a/b/c\". +You can put together sentences using this phrase.")) + +(defgeneric* system-source-file (system) + (:documentation "Return the source file in which system is defined.")) + +(defgeneric* component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) + +(defgeneric* component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) + +(defgeneric* component-relative-pathname (component) + (:documentation "Returns a pathname for the component argument intended to be +interpreted relative to the pathname of that component's parent. +Despite the function's name, the return value may be an absolute +pathname, because an absolute pathname may be interpreted relative to +another pathname in a degenerate way.")) + +(defgeneric* component-property (component property)) + +(defgeneric* (setf component-property) (new-value component property)) + +(defgeneric* component-external-format (component)) + +(defgeneric* component-encoding (component)) + +(eval-when (#-gcl :compile-toplevel :load-toplevel :execute) + (defgeneric* (setf module-components-by-name) (new-value module))) + +(defgeneric* version-satisfies (component version)) + +(defgeneric* find-component (base path) + (:documentation "Finds the component with PATH starting from BASE module; +if BASE is nil, then the component is assumed to be a system.")) + +(defgeneric* source-file-type (component system)) + +(defgeneric* operation-ancestor (operation) + (:documentation + "Recursively chase the operation's parent pointer until we get to +the head of the tree")) + +(defgeneric* component-visited-p (operation component) + (:documentation "Returns the value stored by a call to +VISIT-COMPONENT, if that has been called, otherwise NIL. +This value stored will be a cons cell, the first element +of which is a computed key, so not interesting. The +CDR wil be the DATA value stored by VISIT-COMPONENT; recover +it as (cdr (component-visited-p op c)). + In the current form of ASDF, the DATA value retrieved is +effectively a boolean, indicating whether some operations are +to be performed in order to do OPERATION X COMPONENT. If the +data value is NIL, the combination had been explored, but no +operations needed to be performed.")) + +(defgeneric* visit-component (operation component data) + (:documentation "Record DATA as being associated with OPERATION +and COMPONENT. This is a side-effecting function: the association +will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the +OPERATION\). + No evidence that DATA is ever interesting, beyond just being +non-NIL. Using the data field is probably very risky; if there is +already a record for OPERATION X COMPONENT, DATA will be quietly +discarded instead of recorded. + Starting with 2.006, TRAVERSE will store an integer in data, +so that nodes can be sorted in decreasing order of traversal.")) + + +(defgeneric* (setf visiting-component) (new-value operation component)) + +(defgeneric* component-visiting-p (operation component)) + +(defgeneric* component-depends-on (operation component) + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + + ( *), where is a class + designator and each is a component + designator, which means that the component depends on + having been performed on each ; or + + (FEATURE ), which means that the component depends + on 's presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) + +(defgeneric* component-self-dependencies (operation component)) + +(defgeneric* traverse (operation component) + (:documentation +"Generate and return a plan for performing OPERATION on COMPONENT. + +The plan returned is a list of dotted-pairs. Each pair is the CONS +of ASDF operation object and a COMPONENT object. The pairs will be +processed in order by OPERATE.")) + + +;;;; ------------------------------------------------------------------------- +;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 +(when *upgraded-p* + (when (find-class 'module nil) + (eval + '(defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when *asdf-verbose* + (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") + m (asdf-version))) + (when (member 'components-by-name added) + (compute-module-components-by-name m)) + (when (typep m 'system) + (when (member 'source-file added) + (%set-system-source-file + (probe-asd (component-name m) (component-pathname m)) m) + (when (equal (component-name m) "asdf") + (setf (component-version m) *asdf-version*)))))))) + +;;;; ------------------------------------------------------------------------- +;;;; Classes, Conditions + +(define-condition system-definition-error (error) () + ;; [this use of :report should be redundant, but unfortunately it's not. + ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function + ;; over print-object; this is always conditions::%print-condition for + ;; condition objects, which in turn does inheritance of :report options at + ;; run-time. fortunately, inheritance means we only need this kludge here in + ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] + #+cmu (:report print-object)) + +(define-condition formatted-system-definition-error (system-definition-error) + ((format-control :initarg :format-control :reader format-control) + (format-arguments :initarg :format-arguments :reader format-arguments)) + (:report (lambda (c s) + (apply 'format s (format-control c) (format-arguments c))))) + +(define-condition load-system-definition-error (system-definition-error) + ((name :initarg :name :reader error-name) + (pathname :initarg :pathname :reader error-pathname) + (condition :initarg :condition :reader error-condition)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (error-name c) (error-pathname c) (error-condition c))))) + +(define-condition circular-dependency (system-definition-error) + ((components :initarg :components :reader circular-dependency-components)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (circular-dependency-components c))))) + +(define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (duplicate-names-name c))))) + +(define-condition missing-component (system-definition-error) + ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) + (parent :initform nil :reader missing-parent :initarg :parent))) + +(define-condition missing-component-of-version (missing-component) + ((version :initform nil :reader missing-version :initarg :version))) + +(define-condition missing-dependency (missing-component) + ((required-by :initarg :required-by :reader missing-required-by))) + +(define-condition missing-dependency-of-version (missing-dependency + missing-component-of-version) + ()) + +(define-condition operation-error (error) + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (error-operation c) (error-component c))))) +(define-condition compile-error (operation-error) ()) +(define-condition compile-failed (compile-error) ()) +(define-condition compile-warned (compile-error) ()) + +(define-condition invalid-configuration () + ((form :reader condition-form :initarg :form) + (location :reader condition-location :initarg :location) + (format :reader condition-format :initarg :format) + (arguments :reader condition-arguments :initarg :arguments :initform nil)) + (:report (lambda (c s) + (format s (compatfmt "~@<~? (will be skipped)~@:>") + (condition-format c) + (list* (condition-form c) (condition-location c) + (condition-arguments c)))))) +(define-condition invalid-source-registry (invalid-configuration warning) + ((format :initform (compatfmt "~@")))) +(define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform (compatfmt "~@")))) + +(defclass component () + ((name :accessor component-name :initarg :name :type string :documentation + "Component name: designator for a string composed of portable pathname characters") + ;; We might want to constrain version with + ;; :type (and string (satisfies parse-version)) + ;; but we cannot until we fix all systems that don't use it correctly! + (version :accessor component-version :initarg :version) + (description :accessor component-description :initarg :description) + (long-description :accessor component-long-description :initarg :long-description) + ;; This one below is used by POIU - http://www.cliki.net/poiu + ;; a parallelizing extension of ASDF that compiles in multiple parallel + ;; slave processes (forked on demand) and loads in the master process. + ;; Maybe in the future ASDF may use it internally instead of in-order-to. + (load-dependencies :accessor component-load-dependencies :initform nil) + ;; In the ASDF object model, dependencies exist between *actions* + ;; (an action is a pair of operation and component). They are represented + ;; alists of operations to dependencies (other actions) in each component. + ;; There are two kinds of dependencies, each stored in its own slot: + ;; in-order-to and do-first dependencies. These two kinds are related to + ;; the fact that some actions modify the filesystem, + ;; whereas other actions modify the current image, and + ;; this implies a difference in how to interpret timestamps. + ;; in-order-to dependencies will trigger re-performing the action + ;; when the timestamp of some dependency + ;; makes the timestamp of current action out-of-date; + ;; do-first dependencies do not trigger such re-performing. + ;; Therefore, a FASL must be recompiled if it is obsoleted + ;; by any of its FASL dependencies (in-order-to); but + ;; it needn't be recompiled just because one of these dependencies + ;; hasn't yet been loaded in the current image (do-first). + ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! + ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. + ;; Maybe rename the slots in ASDF? But that's not very backwards compatible. + ;; See our ASDF 2 paper for more complete explanations. + (in-order-to :initform nil :initarg :in-order-to + :accessor component-in-order-to) + (do-first :initform nil :initarg :do-first + :accessor component-do-first) + ;; methods defined using the "inline" style inside a defsystem form: + ;; need to store them somewhere so we can delete them when the system + ;; is re-evaluated + (inline-methods :accessor component-inline-methods :initform nil) + (parent :initarg :parent :initform nil :reader component-parent) + ;; no direct accessor for pathname, we do this as a method to allow + ;; it to default in funky ways if not supplied + (relative-pathname :initarg :pathname) + ;; the absolute-pathname is computed based on relative-pathname... + (absolute-pathname) + (operation-times :initform (make-hash-table) + :accessor component-operation-times) + (around-compile :initarg :around-compile) + (%encoding :accessor %component-encoding :initform nil :initarg :encoding) + ;; XXX we should provide some atomic interface for updating the + ;; component properties + (properties :accessor component-properties :initarg :properties + :initform nil))) + +(defun* component-find-path (component) + (reverse + (loop :for c = component :then (component-parent c) + :while c :collect (component-name c)))) + +(defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity nil) + (format stream "~{~S~^ ~}" (component-find-path c)))) + + +;;;; methods: conditions + +(defmethod print-object ((c missing-dependency) s) + (format s (compatfmt "~@<~A, required by ~A~@:>") + (call-next-method c nil) (missing-required-by c))) + +(defun* sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control + format :format-arguments arguments)) + +;;;; methods: components + +(defmethod print-object ((c missing-component) s) + (format s (compatfmt "~@") + (missing-requires c) + (when (missing-parent c) + (coerce-name (missing-parent c))))) + +(defmethod print-object ((c missing-component-of-version) s) + (format s (compatfmt "~@") + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (coerce-name (missing-parent c))))) + +(defmethod component-system ((component component)) + (aif (component-parent component) + (component-system it) + component)) + +(defvar *default-component-class* 'cl-source-file) + +(defun* compute-module-components-by-name (module) + (let ((hash (make-hash-table :test 'equal))) + (setf (module-components-by-name module) hash) + (loop :for c :in (module-components module) + :for name = (component-name c) + :for previous = (gethash name (module-components-by-name module)) + :do + (when previous + (error 'duplicate-names :name name)) + :do (setf (gethash name (module-components-by-name module)) c)) + hash)) + +(defclass module (component) + ((components + :initform nil + :initarg :components + :accessor module-components) + (components-by-name + :accessor module-components-by-name) + ;; What to do if we can't satisfy a dependency of one of this module's + ;; components. This allows a limited form of conditional processing. + (if-component-dep-fails + :initform :fail + :initarg :if-component-dep-fails + :accessor module-if-component-dep-fails) + (default-component-class + :initform nil + :initarg :default-component-class + :accessor module-default-component-class))) + +(defun* component-parent-pathname (component) + ;; No default anymore (in particular, no *default-pathname-defaults*). + ;; If you force component to have a NULL pathname, you better arrange + ;; for any of its children to explicitly provide a proper absolute pathname + ;; wherever a pathname is actually wanted. + (let ((parent (component-parent component))) + (when parent + (component-pathname parent)))) + +(defmethod component-pathname ((component component)) + (if (slot-boundp component 'absolute-pathname) + (slot-value component 'absolute-pathname) + (let ((pathname + (merge-pathnames* + (component-relative-pathname component) + (pathname-directory-pathname (component-parent-pathname component))))) + (unless (or (null pathname) (absolute-pathname-p pathname)) + (error (compatfmt "~@") + pathname (component-find-path component))) + (setf (slot-value component 'absolute-pathname) pathname) + pathname))) + +(defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) + +(defmethod (setf component-property) (new-value (c component) property) + (let ((a (assoc property (slot-value c 'properties) :test #'equal))) + (if a + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties))))) + new-value) + +(defvar *default-encoding* :default + "Default encoding for source files. +The default value :default preserves the legacy behavior. +A future default might be :utf-8 or :autodetect +reading emacs-style -*- coding: utf-8 -*- specifications, +and falling back to utf-8 or latin1 if nothing is specified.") + +(defparameter *utf-8-external-format* + #+(and asdf-unicode (not clisp)) :utf-8 + #+(and asdf-unicode clisp) charset:utf-8 + #-asdf-unicode :default + "Default :external-format argument to pass to CL:OPEN and also +CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. +On modern implementations, this will decode UTF-8 code points as CL characters. +On legacy implementations, it may fall back on some 8-bit encoding, +with non-ASCII code points being read as several CL characters; +hopefully, if done consistently, that won't affect program behavior too much.") + +(defun* always-default-encoding (pathname) + (declare (ignore pathname)) + *default-encoding*) + +(defvar *encoding-detection-hook* #'always-default-encoding + "Hook for an extension to define a function to automatically detect a file's encoding") + +(defun* detect-encoding (pathname) + (funcall *encoding-detection-hook* pathname)) + +(defmethod component-encoding ((c component)) + (or (loop :for x = c :then (component-parent x) + :while x :thereis (%component-encoding x)) + (detect-encoding (component-pathname c)))) + +(defun* default-encoding-external-format (encoding) + (case encoding + (:default :default) ;; for backwards compatibility only. Explicit usage discouraged. + (:utf-8 *utf-8-external-format*) + (otherwise + (cerror "Continue using :external-format :default" (compatfmt "~@") encoding) + :default))) + +(defvar *encoding-external-format-hook* + #'default-encoding-external-format + "Hook for an extension to define a mapping between non-default encodings +and implementation-defined external-format's") + +(defun encoding-external-format (encoding) + (funcall *encoding-external-format-hook* encoding)) + +(defmethod component-external-format ((c component)) + (encoding-external-format (component-encoding c))) + +(defclass proto-system () ; slots to keep when resetting a system + ;; To preserve identity for all objects, we'd need keep the components slots + ;; but also to modify parse-component-form to reset the recycled objects. + ((name) #|(components) (components-by-names)|#)) + +(defclass system (module proto-system) + (;; description and long-description are now available for all component's, + ;; but now also inherited from component, but we add the legacy accessor + (description :accessor system-description :initarg :description) + (long-description :accessor system-long-description :initarg :long-description) + (author :accessor system-author :initarg :author) + (maintainer :accessor system-maintainer :initarg :maintainer) + (licence :accessor system-licence :initarg :licence + :accessor system-license :initarg :license) + (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade + :writer %set-system-source-file) + (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) + +;;;; ------------------------------------------------------------------------- +;;;; version-satisfies + +(defmethod version-satisfies ((c component) version) + (unless (and version (slot-boundp c 'version)) + (when version + (warn "Requested version ~S but component ~S has no version" version c)) + (return-from version-satisfies t)) + (version-satisfies (component-version c) version)) + +(defun* asdf-version () + "Exported interface to the version of ASDF currently installed. A string. +You can compare this string with e.g.: +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." + *asdf-version*) + +(defun* parse-version (string &optional on-error) + "Parse a version string as a series of natural integers separated by dots. +Return a (non-null) list of integers if the string is valid, NIL otherwise. +If on-error is error, warn, or designates a function of compatible signature, +the function is called with an explanation of what is wrong with the argument. +NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" + (and + (or (stringp string) + (when on-error + (funcall on-error "~S: ~S is not a string" + 'parse-version string)) nil) + (or (loop :for prev = nil :then c :for c :across string + :always (or (digit-char-p c) + (and (eql c #\.) prev (not (eql prev #\.)))) + :finally (return (and c (digit-char-p c)))) + (when on-error + (funcall on-error "~S: ~S doesn't follow asdf version numbering convention" + 'parse-version string)) nil) + (mapcar #'parse-integer (split-string string :separator ".")))) + +(defmethod version-satisfies ((cver string) version) + (let ((x (parse-version cver 'warn)) + (y (parse-version version 'warn))) + (labels ((bigger (x y) + (cond ((not y) t) + ((not x) nil) + ((> (car x) (car y)) t) + ((= (car x) (car y)) + (bigger (cdr x) (cdr y)))))) + (and x y (= (car x) (car y)) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) + +;;;; ----------------------------------------------------------------- +;;;; Windows shortcut support. Based on: +;;;; +;;;; Jesse Hager: The Windows Shortcut File Format. +;;;; http://www.wotsit.org/list.asp?fc=13 + +#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. +(progn +(defparameter *link-initial-dword* 76) +(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) + +(defun* read-null-terminated-string (s) + (with-output-to-string (out) + (loop :for code = (read-byte s) + :until (zerop code) + :do (write-char (code-char code) out)))) + +(defun* read-little-endian (s &optional (bytes 4)) + (loop :for i :from 0 :below bytes + :sum (ash (read-byte s) (* 8 i)))) + +(defun* parse-file-location-info (s) + (let ((start (file-position s)) + (total-length (read-little-endian s)) + (end-of-header (read-little-endian s)) + (fli-flags (read-little-endian s)) + (local-volume-offset (read-little-endian s)) + (local-offset (read-little-endian s)) + (network-volume-offset (read-little-endian s)) + (remaining-offset (read-little-endian s))) + (declare (ignore total-length end-of-header local-volume-offset)) + (unless (zerop fli-flags) + (cond + ((logbitp 0 fli-flags) + (file-position s (+ start local-offset))) + ((logbitp 1 fli-flags) + (file-position s (+ start + network-volume-offset + #x14)))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) + +(defun* parse-windows-shortcut (pathname) + (with-open-file (s pathname :element-type '(unsigned-byte 8)) + (handler-case + (when (and (= (read-little-endian s) *link-initial-dword*) + (let ((header (make-array (length *link-guid*)))) + (read-sequence header s) + (equalp header *link-guid*))) + (let ((flags (read-little-endian s))) + (file-position s 76) ;skip rest of header + (when (logbitp 0 flags) + ;; skip shell item id list + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (cond + ((logbitp 1 flags) + (parse-file-location-info s)) + (t + (when (logbitp 2 flags) + ;; skip description string + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (when (logbitp 3 flags) + ;; finally, our pathname + (let* ((length (read-little-endian s 2)) + (buffer (make-array length))) + (read-sequence buffer s) + (map 'string #'code-char buffer))))))) + (end-of-file () + nil))))) + +;;;; ------------------------------------------------------------------------- +;;;; Finding systems + +(defun* make-defined-systems-table () + (make-hash-table :test 'equal)) + +(defvar *defined-systems* (make-defined-systems-table) + "This is a hash table whose keys are strings, being the +names of the systems, and whose values are pairs, the first +element of which is a universal-time indicating when the +system definition was last updated, and the second element +of which is a system object.") + +(defun* coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error (compatfmt "~@") name)))) + +(defun* system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + +(defun* registered-systems () + (loop :for (() . system) :being :the :hash-values :of *defined-systems* + :collect (coerce-name system))) + +(defun* register-system (system) + (check-type system system) + (let ((name (component-name system))) + (check-type name string) + (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) + (unless (eq system (cdr (gethash name *defined-systems*))) + (setf (gethash name *defined-systems*) + (cons (get-universal-time) system))))) + +(defun* clear-system (name) + "Clear the entry for a system in the database of systems previously loaded. +Note that this does NOT in any way cause the code of the system to be unloaded." + ;; There is no "unload" operation in Common Lisp, and + ;; a general such operation cannot be portably written, + ;; considering how much CL relies on side-effects to global data structures. + (remhash (coerce-name name) *defined-systems*)) + +(defun* map-systems (fn) + "Apply FN to each defined system. + +FN should be a function of one argument. It will be +called with an object of type asdf:system." + (maphash #'(lambda (_ datum) + (declare (ignore _)) + (destructuring-bind (_ . def) datum + (declare (ignore _)) + (funcall fn def))) + *defined-systems*)) + +;;; for the sake of keeping things reasonably neat, we adopt a +;;; convention that functions in this list are prefixed SYSDEF- + +(defvar *system-definition-search-functions* '()) + +(setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. + (remove 'contrib-sysdef-search *system-definition-search-functions*) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; but then it will be the responsibility of whoever does that + ;; to upgrade asdf before he does such a thing rather than after. + (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-asdf)))) + +(defun* search-for-system-definition (system) + (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) + (cons 'find-system-if-being-defined + *system-definition-search-functions*))) + +(defvar *central-registry* nil +"A list of 'system directory designators' ASDF uses to find systems. + +A 'system directory designator' is a pathname or an expression +which evaluates to a pathname. For example: + + (setf asdf:*central-registry* + (list '*default-pathname-defaults* + #p\"/home/me/cl/systems/\" + #p\"/usr/share/common-lisp/systems/\")) + +This is for backward compatibilily. +Going forward, we recommend new users should be using the source-registry. +") + +(defun* featurep (x &optional (features *features*)) + (cond + ((atom x) + (and (member x features) t)) + ((eq :not (car x)) + (assert (null (cddr x))) + (not (featurep (cadr x) features))) + ((eq :or (car x)) + (some #'(lambda (x) (featurep x features)) (cdr x))) + ((eq :and (car x)) + (every #'(lambda (x) (featurep x features)) (cdr x))) + (t + (error "Malformed feature specification ~S" x)))) + +(defun* os-unix-p () + (featurep '(:or :unix :cygwin :darwin))) + +(defun* os-windows-p () + (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) + +(defun* probe-asd (name defaults) + (block nil + (when (directory-pathname-p defaults) + (let* ((file (probe-file* (subpathname defaults (strcat name ".asd"))))) + (when file + (return file))) + #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) + (when (os-windows-p) + (let ((shortcut + (make-pathname + :defaults defaults :version :newest :case :local + :name (strcat name ".asd") + :type "lnk"))) + (when (probe-file* shortcut) + (let ((target (parse-windows-shortcut shortcut))) + (when target + (return (pathname target)))))))))) + +(defun* sysdef-central-registry-search (system) + (let ((name (coerce-name system)) + (to-remove nil) + (to-replace nil)) + (block nil + (unwind-protect + (dolist (dir *central-registry*) + (let ((defaults (eval dir))) + (when defaults + (cond ((directory-pathname-p defaults) + (let ((file (probe-asd name defaults))) + (when file + (return file)))) + (t + (restart-case + (let* ((*print-circle* nil) + (message + (format nil + (compatfmt "~@") + system dir defaults))) + (error message)) + (remove-entry-from-registry () + :report "Remove entry from *central-registry* and continue" + (push dir to-remove)) + (coerce-entry-to-directory () + :report (lambda (s) + (format s (compatfmt "~@") + (ensure-directory-pathname defaults) dir)) + (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) + ;; cleanup + (dolist (dir to-remove) + (setf *central-registry* (remove dir *central-registry*))) + (dolist (pair to-replace) + (let* ((current (car pair)) + (new (cdr pair)) + (position (position current *central-registry*))) + (setf *central-registry* + (append (subseq *central-registry* 0 position) + (list new) + (subseq *central-registry* (1+ position)))))))))) + +(defun* make-temporary-package () + (flet ((try (counter) + (ignore-errors + (make-package (format nil "~A~D" :asdf counter) + :use '(:cl :asdf))))) + (do* ((counter 0 (+ counter 1)) + (package (try counter) (try counter))) + (package package)))) + +(defun* safe-file-write-date (pathname) + ;; If FILE-WRITE-DATE returns NIL, it's possible that + ;; the user or some other agent has deleted an input file. + ;; Also, generated files will not exist at the time planning is done + ;; and calls operation-done-p which calls safe-file-write-date. + ;; So it is very possible that we can't get a valid file-write-date, + ;; and we can survive and we will continue the planning + ;; as if the file were very old. + ;; (or should we treat the case in a different, special way?) + (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname))) + (progn + (when (and pathname *asdf-verbose*) + (warn (compatfmt "~@") + pathname)) + 0))) + +(defmethod find-system ((name null) &optional (error-p t)) + (declare (ignorable name)) + (when error-p + (sysdef-error (compatfmt "~@")))) + +(defmethod find-system (name &optional (error-p t)) + (find-system (coerce-name name) error-p)) + +(defvar *systems-being-defined* nil + "A hash-table of systems currently being defined keyed by name, or NIL") + +(defun* find-system-if-being-defined (name) + (when *systems-being-defined* + (gethash (coerce-name name) *systems-being-defined*))) + +(defun* call-with-system-definitions (thunk) + (if *systems-being-defined* + (funcall thunk) + (let ((*systems-being-defined* (make-hash-table :test 'equal))) + (funcall thunk)))) + +(defmacro with-system-definitions ((&optional) &body body) + `(call-with-system-definitions #'(lambda () ,@body))) + +(defun* load-sysdef (name pathname) + ;; Tries to load system definition with canonical NAME from PATHNAME. + (with-system-definitions () + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname + :condition condition)))) + (let ((*package* package) + (*default-pathname-defaults* + ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. + (pathname-directory-pathname (translate-logical-pathname pathname))) + (external-format (encoding-external-format (detect-encoding pathname)))) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") + pathname package) + (load pathname :external-format external-format))) + (delete-package package))))) + +(defun* locate-system (name) + "Given a system NAME designator, try to locate where to load the system from. +Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME +FOUNDP is true when a system was found, +either a new unregistered one or a previously registered one. +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is +PATHNAME when not null is a path from where to load the system, +either associated with FOUND-SYSTEM, or with the PREVIOUS system. +PREVIOUS when not null is a previously loaded SYSTEM object of same name. +PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous)))) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (when foundp + (setf pathname (resolve-symlinks* pathname)) + (when (and pathname (not (absolute-pathname-p pathname))) + (setf pathname (ensure-pathname-absolute pathname)) + (when found-system + (%set-system-source-file pathname found-system))) + (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp + (system-source-file previous) pathname))) + (%set-system-source-file pathname previous) + (setf previous-time nil)) + (values foundp found-system pathname previous previous-time)))) + +(defmethod find-system ((name string) &optional (error-p t)) + (with-system-definitions () + (loop + (restart-case + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (declare (ignore foundp)) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and pathname + (or (not previous-time) + ;; don't reload if it's already been loaded, + ;; or its filestamp is in the future which means some clock is skewed + ;; and trying to load might cause an infinite loop. + (< previous-time (safe-file-write-date pathname) (get-universal-time)))) + (load-sysdef name pathname)) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (return + (cond + (in-memory + (when pathname + (setf (car in-memory) (safe-file-write-date pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)))))) + (reinitialize-source-registry-and-retry () + :report (lambda (s) + (format s (compatfmt "~@") name)) + (initialize-source-registry)))))) + +(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) + (setf fallback (coerce-name fallback) + requested (coerce-name requested)) + (when (equal requested fallback) + (let ((registered (cdr (gethash fallback *defined-systems*)))) + (or registered + (apply 'make-instance 'system + :name fallback :source-file source-file keys))))) + +(defun* sysdef-find-asdf (name) + ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. + (find-system-fallback name "asdf" :version *asdf-version*)) + + +;;;; ------------------------------------------------------------------------- +;;;; Finding components + +(defmethod find-component ((base string) path) + (let ((s (find-system base nil))) + (and s (find-component s path)))) + +(defmethod find-component ((base symbol) path) + (cond + (base (find-component (coerce-name base) path)) + (path (find-component path nil)) + (t nil))) + +(defmethod find-component ((base cons) path) + (find-component (car base) (cons (cdr base) path))) + +(defmethod find-component ((module module) (name string)) + (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!! + (compute-module-components-by-name module)) + (values (gethash name (module-components-by-name module)))) + +(defmethod find-component ((component component) (name symbol)) + (if name + (find-component component (coerce-name name)) + component)) + +(defmethod find-component ((module module) (name cons)) + (find-component (find-component module (car name)) (cdr name))) + + +;;; component subclasses + +(defclass source-file (component) + ((type :accessor source-file-explicit-type :initarg :type :initform nil))) + +(defclass cl-source-file (source-file) + ((type :initform "lisp"))) +(defclass cl-source-file.cl (cl-source-file) + ((type :initform "cl"))) +(defclass cl-source-file.lsp (cl-source-file) + ((type :initform "lsp"))) +(defclass c-source-file (source-file) + ((type :initform "c"))) +(defclass java-source-file (source-file) + ((type :initform "java"))) +(defclass static-file (source-file) ()) +(defclass doc-file (static-file) ()) +(defclass html-file (doc-file) + ((type :initform "html"))) + +(defmethod source-file-type ((component module) (s module)) + (declare (ignorable component s)) + :directory) +(defmethod source-file-type ((component source-file) (s module)) + (declare (ignorable s)) + (source-file-explicit-type component)) + +(defmethod component-relative-pathname ((component component)) + (coerce-pathname + (or (slot-value component 'relative-pathname) + (component-name component)) + :type (source-file-type component (component-system component)) + :defaults (component-parent-pathname component))) + +;;;; ------------------------------------------------------------------------- +;;;; Operations + +;;; one of these is instantiated whenever #'operate is called + +(defclass operation () + (;; as of danb's 2003-03-16 commit e0d02781, :force can be: + ;; T to force the inside of the specified system, + ;; but not recurse to other systems we depend on. + ;; :ALL (or any other atom) to force all systems + ;; including other systems we depend on. + ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) + ;; to force systems named in a given list + ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 + (forced :initform nil :initarg :force :accessor operation-forced) + (forced-not :initform nil :initarg :force-not :accessor operation-forced-not) + (original-initargs :initform nil :initarg :original-initargs + :accessor operation-original-initargs) + (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) + (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) + (parent :initform nil :initarg :parent :accessor operation-parent))) + +(defmethod print-object ((o operation) stream) + (print-unreadable-object (o stream :type t :identity t) + (ignore-errors + (prin1 (operation-original-initargs o) stream)))) + +(defmethod shared-initialize :after ((operation operation) slot-names + &key force force-not + &allow-other-keys) + ;; the &allow-other-keys disables initarg validity checking + (declare (ignorable operation slot-names force force-not)) + (macrolet ((frob (x) ;; normalize forced and forced-not slots + `(when (consp (,x operation)) + (setf (,x operation) + (mapcar #'coerce-name (,x operation)))))) + (frob operation-forced) (frob operation-forced-not)) + (values)) + +(defun* node-for (o c) + (cons (class-name (class-of o)) c)) + +(defmethod operation-ancestor ((operation operation)) + (aif (operation-parent operation) + (operation-ancestor it) + operation)) + + +(defun* make-sub-operation (c o dep-c dep-o) + "C is a component, O is an operation, DEP-C is another +component, and DEP-O, confusingly enough, is an operation +class specifier, not an operation." + (let* ((args (copy-list (operation-original-initargs o))) + (force-p (getf args :force))) + ;; note explicit comparison with T: any other non-NIL force value + ;; (e.g. :recursive) will pass through + (cond ((and (null (component-parent c)) + (null (component-parent dep-c)) + (not (eql c dep-c))) + (when (eql force-p t) + (setf (getf args :force) nil)) + (apply 'make-instance dep-o + :parent o + :original-initargs args args)) + ((subtypep (type-of o) dep-o) + o) + (t + (apply 'make-instance dep-o + :parent o :original-initargs args args))))) + + +(defmethod visit-component ((o operation) (c component) data) + (unless (component-visited-p o c) + (setf (gethash (node-for o c) + (operation-visited-nodes (operation-ancestor o))) + (cons t data)))) + +(defmethod component-visited-p ((o operation) (c component)) + (gethash (node-for o c) + (operation-visited-nodes (operation-ancestor o)))) + +(defmethod (setf visiting-component) (new-value operation component) + ;; MCL complains about unused lexical variables + (declare (ignorable operation component)) + new-value) + +(defmethod (setf visiting-component) (new-value (o operation) (c component)) + (let ((node (node-for o c)) + (a (operation-ancestor o))) + (if new-value + (setf (gethash node (operation-visiting-nodes a)) t) + (remhash node (operation-visiting-nodes a))) + new-value)) + +(defmethod component-visiting-p ((o operation) (c component)) + (let ((node (node-for o c))) + (gethash node (operation-visiting-nodes (operation-ancestor o))))) + +(defmethod component-depends-on ((op-spec symbol) (c component)) + ;; Note: we go from op-spec to operation via make-instance + ;; to allow for specialization through defmethod's, even though + ;; it's a detour in the default case below. + (component-depends-on (make-instance op-spec) c)) + +(defmethod component-depends-on ((o operation) (c component)) + (cdr (assoc (type-of o) (component-in-order-to c)))) + +(defmethod component-self-dependencies ((o operation) (c component)) + (remove-if-not + #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) + (component-depends-on o c))) + +(defmethod input-files ((operation operation) (c component)) + (let ((parent (component-parent c)) + (self-deps (component-self-dependencies operation c))) + (if self-deps + (mapcan #'(lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) + self-deps) + ;; no previous operations needed? I guess we work with the + ;; original source file, then + (list (component-pathname c))))) + +(defmethod input-files ((operation operation) (c module)) + (declare (ignorable operation c)) + nil) + +(defmethod component-operation-time (o c) + (gethash (type-of o) (component-operation-times c))) + +(defmethod operation-done-p ((o operation) (c component)) + (let ((out-files (output-files o c)) + (in-files (input-files o c)) + (op-time (component-operation-time o c))) + (flet ((earliest-out () + (reduce #'min (mapcar #'safe-file-write-date out-files))) + (latest-in () + (reduce #'max (mapcar #'safe-file-write-date in-files)))) + (cond + ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much. + ;; e.g. operations on systems, modules that have no immediate action, + ;; but are only meaningful through traversed dependencies + t) + ((not out-files) + ;; an operation without output-files is probably meant + ;; for its side-effects in the current image, + ;; assumed to be idem-potent, + ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE. + (and op-time (>= op-time (latest-in)))) + ((not in-files) + ;; an operation with output-files and no input-files + ;; is probably meant for its side-effects on the file-system, + ;; assumed to have to be done everytime. + ;; (I don't think there is any such case in ASDF unless extended) + nil) + (t + ;; an operation with both input and output files is assumed + ;; as computing the latter from the former, + ;; assumed to have been done if the latter are all older + ;; than the former. + ;; e.g. COMPILE-OP of some CL-SOURCE-FILE. + ;; We use >= instead of > to play nice with generated files. + ;; This opens a race condition if an input file is changed + ;; after the output is created but within the same second + ;; of filesystem time; but the same race condition exists + ;; whenever the computation from input to output takes more + ;; than one second of filesystem time (or just crosses the + ;; second). So that's cool. + (and + (every #'probe-file* in-files) + (every #'probe-file* out-files) + (>= (earliest-out) (latest-in)))))))) + + + +;;; For 1.700 I've done my best to refactor TRAVERSE +;;; by splitting it up in a bunch of functions, +;;; so as to improve the collection and use-detection algorithm. --fare +;;; The protocol is as follows: we pass around operation, dependency, +;;; bunch of other stuff, and a force argument. Return a force flag. +;;; The returned flag is T if anything has changed that requires a rebuild. +;;; The force argument is a list of components that will require a rebuild +;;; if the flag is T, at which point whoever returns the flag has to +;;; mark them all as forced, and whoever recurses again can use a NIL list +;;; as a further argument. + +(defvar *forcing* nil + "This dynamically-bound variable is used to force operations in +recursive calls to traverse.") + +(defgeneric* do-traverse (operation component collect)) + +(defun* resolve-dependency-name (component name &optional version) + (loop + (restart-case + (return + (let ((comp (find-component (component-parent component) name))) + (unless comp + (error 'missing-dependency + :required-by component + :requires name)) + (when version + (unless (version-satisfies comp version) + (error 'missing-dependency-of-version + :required-by component + :version version + :requires name))) + comp)) + (retry () + :report (lambda (s) + (format s (compatfmt "~@") name)) + :test + (lambda (c) + (or (null c) + (and (typep c 'missing-dependency) + (eq (missing-required-by c) component) + (equal (missing-requires c) name)))))))) + +(defun* resolve-dependency-spec (component dep-spec) + (cond + ((atom dep-spec) + (resolve-dependency-name component dep-spec)) + ;; Structured dependencies --- this parses keywords. + ;; The keywords could conceivably be broken out and cleanly (extensibly) + ;; processed by EQL methods. But for now, here's what we've got. + ((eq :version (first dep-spec)) + ;; https://bugs.launchpad.net/asdf/+bug/527788 + (resolve-dependency-name component (second dep-spec) (third dep-spec))) + ((eq :feature (first dep-spec)) + ;; This particular subform is not documented and + ;; has always been broken in the past. + ;; Therefore no one uses it, and I'm cerroring it out, + ;; after fixing it + ;; See https://bugs.launchpad.net/asdf/+bug/518467 + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") + (when (find (second dep-spec) *features* :test 'string-equal) + (resolve-dependency-name component (third dep-spec)))) + (t + (error (compatfmt "~@ ), (:feature ), or .~@:>") dep-spec)))) + +(defun* do-one-dep (op c collect dep-op dep-c) + ;; Collects a partial plan for performing dep-op on dep-c + ;; as dependencies of a larger plan involving op and c. + ;; Returns t if this should force recompilation of those who depend on us. + ;; dep-op is an operation class name (not an operation object), + ;; whereas dep-c is a component object.n + (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect)) + +(defun* do-dep (op c collect dep-op-spec dep-c-specs) + ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs + ;; as dependencies of a larger plan involving op and c. + ;; Returns t if this should force recompilation of those who depend on us. + ;; dep-op-spec is either an operation class name (not an operation object), + ;; or the magic symbol asdf:feature. + ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword, + ;; and the plan will succeed if that keyword is present in *feature*, + ;; or fail if it isn't + ;; (at which point c's :if-component-dep-fails will kick in). + ;; If dep-op-spec is an operation class name, + ;; then dep-c-specs specifies a list of sibling component of c, + ;; as per resolve-dependency-spec, such that operating op on c + ;; depends on operating dep-op-spec on each of them. + (cond ((eq dep-op-spec 'feature) + (if (member (car dep-c-specs) *features*) + nil + (error 'missing-dependency + :required-by c + :requires (list :feature (car dep-c-specs))))) + (t + (let ((flag nil)) + (dolist (d dep-c-specs) + (when (do-one-dep op c collect dep-op-spec + (resolve-dependency-spec c d)) + (setf flag t))) + flag)))) + +(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes + +(defun* do-collect (collect x) + (funcall collect x)) + +(defmethod do-traverse ((operation operation) (c component) collect) + (let ((*forcing* *forcing*) + (flag nil)) ;; return value: must we rebuild this and its dependencies? + (labels + ((update-flag (x) + (orf flag x)) + (dep (op comp) + (update-flag (do-dep operation c collect op comp)))) + ;; Have we been visited yet? If so, just process the result. + (aif (component-visited-p operation c) + (progn + (update-flag (cdr it)) + (return-from do-traverse flag))) + ;; dependencies + (when (component-visiting-p operation c) + (error 'circular-dependency :components (list c))) + (setf (visiting-component operation c) t) + (unwind-protect + (block nil + (when (typep c 'system) ;; systems can be forced or forced-not + (let ((ancestor (operation-ancestor operation))) + (flet ((match? (f) + (and f (or (not (consp f)) ;; T or :ALL + (member (component-name c) f :test #'equal))))) + (cond + ((match? (operation-forced ancestor)) + (setf *forcing* t)) + ((match? (operation-forced-not ancestor)) + (return)))))) + ;; first we check and do all the dependencies for the module. + ;; Operations planned in this loop will show up + ;; in the results, and are consumed below. + (let ((*forcing* nil)) + ;; upstream dependencies are never forced to happen just because + ;; the things that depend on them are.... + (loop + :for (required-op . deps) :in (component-depends-on operation c) + :do (dep required-op deps))) + ;; constituent bits + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + ;; This is set based on the results of the + ;; dependencies and whether we are in the + ;; context of a *forcing* call... + ;; inter-system dependencies do NOT trigger + ;; building components + (*forcing* + (or *forcing* + (and flag (not (typep c 'system))))) + (error nil)) + (while-collecting (internal-collect) + (dolist (kid (module-components c)) + (handler-case + (update-flag + (do-traverse operation kid #'internal-collect)) + #-genera + (missing-dependency (condition) + (when (eq (module-if-component-dep-fails c) + :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) + :try-next) + (not at-least-one)) + (error error))))))) + (update-flag (or *forcing* (not (operation-done-p operation c)))) + ;; For sub-operations, check whether + ;; the original ancestor operation was forced, + ;; or names us amongst an explicit list of things to force... + ;; except that this check doesn't distinguish + ;; between all the things with a given name. Sigh. + ;; BROKEN! + (when flag + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (component-do-first c))))) + (loop :for (required-op . deps) :in do-first + :do (do-dep operation c collect required-op deps))) + (do-collect collect (vector module-ops)) + (do-collect collect (cons operation c))))) + (setf (visiting-component operation c) nil))) + (visit-component operation c (when flag (incf *visit-count*))) + flag)) + +(defun* flatten-tree (l) + ;; You collected things into a list. + ;; Most elements are just things to collect again. + ;; A (simple-vector 1) indicate that you should recurse into its contents. + ;; This way, in two passes (rather than N being the depth of the tree), + ;; you can collect things with marginally constant-time append, + ;; achieving linear time collection instead of quadratic time. + (while-collecting (c) + (labels ((r (x) + (if (typep x '(simple-vector 1)) + (r* (svref x 0)) + (c x))) + (r* (l) + (dolist (x l) (r x)))) + (r* l)))) + +(defmethod traverse ((operation operation) (c component)) + (flatten-tree + (while-collecting (collect) + (let ((*visit-count* 0)) + (do-traverse operation c #'collect))))) + +(defmethod perform ((operation operation) (c source-file)) + (sysdef-error + (compatfmt "~@") + (class-of operation) (class-of c))) + +(defmethod perform ((operation operation) (c module)) + (declare (ignorable operation c)) + nil) + +(defmethod mark-operation-done ((operation operation) (c component)) + (setf (gethash (type-of operation) (component-operation-times c)) + (reduce #'max + (cons (get-universal-time) + (mapcar #'safe-file-write-date (input-files operation c)))))) + +(defmethod perform-with-restarts (operation component) + ;; TOO verbose, especially as the default. Add your own :before method + ;; to perform-with-restart or perform if you want that: + #|(when *asdf-verbose* (explain operation component))|# + (perform operation component)) + +(defmethod perform-with-restarts :around (operation component) + (loop + (restart-case + (return (call-next-method)) + (retry () + :report + (lambda (s) + (format s (compatfmt "~@") + (operation-description operation component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@") + (operation-description operation component))) + (mark-operation-done operation component) + (return))))) + +(defmethod explain ((operation operation) (component component)) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") + (operation-description operation component))) + +(defmethod operation-description (operation component) + (format nil (compatfmt "~@<~A on ~A~@:>") + (class-of operation) component)) + +;;;; ------------------------------------------------------------------------- +;;;; compile-op + +(defclass compile-op (operation) + ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) + (on-warnings :initarg :on-warnings :accessor operation-on-warnings + :initform *compile-file-warnings-behaviour*) + (on-failure :initarg :on-failure :accessor operation-on-failure + :initform *compile-file-failure-behaviour*) + (flags :initarg :flags :accessor compile-op-flags + :initform nil))) + +(defun* output-file (operation component) + "The unique output file of performing OPERATION on COMPONENT" + (let ((files (output-files operation component))) + (assert (length=n-p files 1)) + (first files))) + +(defun* ensure-all-directories-exist (pathnames) + (dolist (pathname pathnames) + (ensure-directories-exist (translate-logical-pathname pathname)))) + +(defmethod perform :before ((operation compile-op) (c source-file)) + (ensure-all-directories-exist (output-files operation c))) + +(defmethod perform :after ((operation operation) (c component)) + (mark-operation-done operation c)) + +(defgeneric* around-compile-hook (component)) +(defgeneric* call-with-around-compile-hook (component thunk)) + +(defmethod around-compile-hook ((c component)) + (cond + ((slot-boundp c 'around-compile) + (slot-value c 'around-compile)) + ((component-parent c) + (around-compile-hook (component-parent c))))) + +(defun ensure-function (fun &key (package :asdf)) + (etypecase fun + ((or symbol function) fun) + (cons (eval `(function ,fun))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + +(defmethod call-with-around-compile-hook ((c component) thunk) + (let ((hook (around-compile-hook c))) + (if hook + (funcall (ensure-function hook) thunk) + (funcall thunk)))) + +;;; perform is required to check output-files to find out where to put +;;; its answers, in case it has been overridden for site policy +(defmethod perform ((operation compile-op) (c cl-source-file)) + (let ((source-file (component-pathname c)) + ;; on some implementations, there are more than one output-file, + ;; but the first one should always be the primary fasl that gets loaded. + (output-file (first (output-files operation c))) + (*compile-file-warnings-behaviour* (operation-on-warnings operation)) + (*compile-file-failure-behaviour* (operation-on-failure operation))) + (multiple-value-bind (output warnings-p failure-p) + (call-with-around-compile-hook + c #'(lambda (&rest flags) + (apply *compile-op-compile-file-function* source-file + :output-file output-file + :external-format (component-external-format c) + (append flags (compile-op-flags operation))))) + (unless output + (error 'compile-error :component c :operation operation)) + (when failure-p + (case (operation-on-failure operation) + (:warn (warn + (compatfmt "~@") + operation c)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn + (compatfmt "~@") + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil)))))) + +(defmethod output-files ((operation compile-op) (c cl-source-file)) + (declare (ignorable operation)) + (let* ((p (lispize-pathname (component-pathname c))) + (f (compile-file-pathname ;; fasl + p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)) + #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file + #+ecl (if (use-ecl-byte-compiler-p) + (list f) + (list (compile-file-pathname p :type :object) f)) + #+mkcl (list o f) + #-(or ecl mkcl) (list f))) + +(defmethod perform ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) + nil) + +(defmethod output-files ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) + nil) + +(defmethod input-files ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) + nil) + +(defmethod operation-description ((operation compile-op) component) + (declare (ignorable operation)) + (format nil (compatfmt "~@") component)) + +(defmethod operation-description ((operation compile-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") component)) + + +;;;; ------------------------------------------------------------------------- +;;;; load-op + +(defclass basic-load-op (operation) ()) + +(defclass load-op (basic-load-op) ()) + +(defmethod perform-with-restarts ((o load-op) (c cl-source-file)) + (loop + (restart-case + (return (call-next-method)) + (try-recompiling () + :report (lambda (s) + (format s "Recompile ~a and try loading it again" + (component-name c))) + (perform (make-sub-operation c o c 'compile-op) c))))) + +(defmethod perform ((o load-op) (c cl-source-file)) + (map () #'load + #-(or ecl mkcl) + (input-files o c) + #+(or ecl mkcl) + (loop :for i :in (input-files o c) + :unless (string= (pathname-type i) "fas") + :collect (compile-file-pathname (lispize-pathname i))))) + +(defmethod perform ((operation load-op) (c static-file)) + (declare (ignorable operation c)) + nil) + +(defmethod operation-done-p ((operation load-op) (c static-file)) + (declare (ignorable operation c)) + t) + +(defmethod output-files ((operation operation) (c component)) + (declare (ignorable operation c)) + nil) + +(defmethod component-depends-on ((operation load-op) (c component)) + (declare (ignorable operation)) + (cons (list 'compile-op (component-name c)) + (call-next-method))) + +(defmethod operation-description ((operation load-op) component) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-op) (component cl-source-file)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) + +;;;; ------------------------------------------------------------------------- +;;;; load-source-op + +(defclass load-source-op (basic-load-op) ()) + +(defmethod perform ((o load-source-op) (c cl-source-file)) + (declare (ignorable o)) + (let ((source (component-pathname c))) + (setf (component-property c 'last-loaded-as-source) + (and (call-with-around-compile-hook + c #'(lambda () (load source :external-format (component-external-format c)))) + (get-universal-time))))) + +(defmethod perform ((operation load-source-op) (c static-file)) + (declare (ignorable operation c)) + nil) + +(defmethod output-files ((operation load-source-op) (c component)) + (declare (ignorable operation c)) + nil) + +;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right. +(defmethod component-depends-on ((o load-source-op) (c component)) + (declare (ignorable o)) + (loop :with what-would-load-op-do = (component-depends-on 'load-op c) + :for (op . co) :in what-would-load-op-do + :when (eq op 'load-op) :collect (cons 'load-source-op co))) + +(defmethod operation-done-p ((o load-source-op) (c source-file)) + (declare (ignorable o)) + (if (or (not (component-property c 'last-loaded-as-source)) + (> (safe-file-write-date (component-pathname c)) + (component-property c 'last-loaded-as-source))) + nil t)) + +(defmethod operation-description ((operation load-source-op) component) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-source-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") component)) + + +;;;; ------------------------------------------------------------------------- +;;;; test-op + +(defclass test-op (operation) ()) + +(defmethod perform ((operation test-op) (c component)) + (declare (ignorable operation c)) + nil) + +(defmethod operation-done-p ((operation test-op) (c system)) + "Testing a system is _never_ done." + (declare (ignorable operation c)) + nil) + +(defmethod component-depends-on :around ((o test-op) (c system)) + (declare (ignorable o)) + (cons `(load-op ,(component-name c)) (call-next-method))) + + +;;;; ------------------------------------------------------------------------- +;;;; Invoking Operations + +(defgeneric* operate (operation-class system &key &allow-other-keys)) +(defgeneric* perform-plan (plan &key)) + +;;;; Separating this into a different function makes it more forward-compatible +(defun* cleanup-upgraded-asdf (old-version) + (let ((new-version (asdf-version))) + (unless (equal old-version new-version) + (cond + ((version-satisfies new-version old-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + ((version-satisfies old-version new-version) + (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + (t + (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") + old-version new-version))) + (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) + ;; Invalidate all systems but ASDF itself. + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + ;; If we're in the middle of something, restart it. + (when *systems-being-defined* + (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) + (clrhash *systems-being-defined*) + (dolist (s l) (find-system s nil)))) + t)))) + +;;;; Try to upgrade of ASDF. If a different version was used, return T. +;;;; We need do that before we operate on anything that depends on ASDF. +(defun* upgrade-asdf () + (let ((version (asdf-version))) + (handler-bind (((or style-warning warning) #'muffle-warning)) + (operate 'load-op :asdf :verbose nil)) + (cleanup-upgraded-asdf version))) + +(defmethod perform-plan ((steps list) &key) + (let ((*package* *package*) + (*readtable* *readtable*)) + (with-compilation-unit () + (loop :for (op . component) :in steps :do + (perform-with-restarts op component))))) + +(defmethod operate (operation-class system &rest args + &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force + &allow-other-keys) + (declare (ignore force)) + (with-system-definitions () + (let* ((op (apply 'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) + (system (etypecase system + (system system) + ((or string symbol) (find-system system))))) + (unless (version-satisfies system version) + (error 'missing-component-of-version :requires system :version version)) + (let ((steps (traverse op system))) + (when (and (not (equal '("asdf") (component-find-path system))) + (find '("asdf") (mapcar 'cdr steps) + :test 'equal :key 'component-find-path) + (upgrade-asdf)) + ;; If we needed to upgrade ASDF to achieve our goal, + ;; then do it specially as the first thing, then + ;; invalidate all existing system + ;; retry the whole thing with the new OPERATE function, + ;; which on some implementations + ;; has a new symbol shadowing the current one. + (return-from operate + (apply (find-symbol* 'operate :asdf) operation-class system args))) + (perform-plan steps) + (values op steps))))) + +(defun* oos (operation-class system &rest args &key force verbose version + &allow-other-keys) + (declare (ignore force verbose version)) + (apply 'operate operation-class system args)) + +(let ((operate-docstring + "Operate does three things: + +1. It creates an instance of OPERATION-CLASS using any keyword parameters +as initargs. +2. It finds the asdf-system specified by SYSTEM (possibly loading +it from disk). +3. It then calls TRAVERSE with the operation and system as arguments + +The traverse operation is wrapped in WITH-COMPILATION-UNIT and error +handling code. If a VERSION argument is supplied, then operate also +ensures that the system found satisfies it using the VERSION-SATISFIES +method. + +Note that dependencies may cause the operation to invoke other +operations on the system or its components: the new operations will be +created with the same initargs as the original one. +")) + (setf (documentation 'oos 'function) + (format nil + "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" + operate-docstring)) + (setf (documentation 'operate 'function) + operate-docstring)) + +(defun* load-system (system &rest keys &key force verbose version &allow-other-keys) + "Shorthand for `(operate 'asdf:load-op system)`. +See OPERATE for details." + (declare (ignore force verbose version)) + (apply 'operate *load-system-operation* system keys) + t) + +(defun* load-systems (&rest systems) + (map () 'load-system systems)) + +(defun component-loaded-p (c) + (and (gethash 'load-op (component-operation-times (find-component c nil))) t)) + +(defun loaded-systems () + (remove-if-not 'component-loaded-p (registered-systems))) + +(defun require-system (s &rest keys &key &allow-other-keys) + (apply 'load-system s :force-not (loaded-systems) keys)) + +(defun* compile-system (system &rest args &key force verbose version + &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE +for details." + (declare (ignore force verbose version)) + (apply 'operate 'compile-op system args) + t) + +(defun* test-system (system &rest args &key force verbose version + &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for +details." + (declare (ignore force verbose version)) + (apply 'operate 'test-op system args) + t) + +;;;; ------------------------------------------------------------------------- +;;;; Defsystem + +(defun* load-pathname () + (resolve-symlinks* (or *load-pathname* *compile-file-pathname*))) + +(defun* determine-system-pathname (pathname) + ;; The defsystem macro calls us to determine + ;; the pathname of a system as follows: + ;; 1. the one supplied, + ;; 2. derived from *load-pathname* via load-pathname + ;; 3. taken from the *default-pathname-defaults* via default-directory + (let* ((file-pathname (load-pathname)) + (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) + (or (and pathname (subpathname directory-pathname pathname :type :directory)) + directory-pathname + (default-directory)))) + +(defun* find-class* (x &optional (errorp t) environment) + (etypecase x + ((or standard-class built-in-class) x) + (symbol (find-class x errorp environment)))) + +(defun* class-for-type (parent type) + (or (loop :for symbol :in (list + type + (find-symbol* type *package*) + (find-symbol* type :asdf)) + :for class = (and symbol (find-class symbol nil)) + :when (and class + (#-cormanlisp subtypep #+cormanlisp cl::subclassp + class (find-class 'component))) + :return class) + (and (eq type :file) + (find-class* + (or (loop :for module = parent :then (component-parent module) :while module + :thereis (module-default-component-class module)) + *default-component-class*) nil)) + (sysdef-error "don't recognize component type ~A" type))) + +(defun* maybe-add-tree (tree op1 op2 c) + "Add the node C at /OP1/OP2 in TREE, unless it's there already. +Returns the new tree (which probably shares structure with the old one)" + (let ((first-op-tree (assoc op1 tree))) + (if first-op-tree + (progn + (aif (assoc op2 (cdr first-op-tree)) + (if (find c (cdr it) :test #'equal) + nil + (setf (cdr it) (cons c (cdr it)))) + (setf (cdr first-op-tree) + (acons op2 (list c) (cdr first-op-tree)))) + tree) + (acons op1 (list (list op2 c)) tree)))) + +(defun* union-of-dependencies (&rest deps) + (let ((new-tree nil)) + (dolist (dep deps) + (dolist (op-tree dep) + (dolist (op (cdr op-tree)) + (dolist (c (cdr op)) + (setf new-tree + (maybe-add-tree new-tree (car op-tree) (car op) c)))))) + new-tree)) + + +(defvar *serial-depends-on* nil) + +(defun* sysdef-error-component (msg type name value) + (sysdef-error (strcat msg (compatfmt "~&~@")) + type name value)) + +(defun* check-component-input (type name weakly-depends-on + depends-on components in-order-to) + "A partial test of the values of a component." + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components)) + (unless (and (listp in-order-to) (listp (car in-order-to))) + (sysdef-error-component ":in-order-to must be NIL or a list of components." + type name in-order-to))) + +(defun* %remove-component-inline-methods (component) + (dolist (name +asdf-methods+) + (map () + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf + ;; But this is hardly performance-critical + #'(lambda (m) + (remove-method (symbol-function name) m)) + (component-inline-methods component))) + ;; clear methods, then add the new ones + (setf (component-inline-methods component) nil)) + +(defun* %define-component-inline-methods (ret rest) + (dolist (name +asdf-methods+) + (let ((keyword (intern (symbol-name name) :keyword))) + (loop :for data = rest :then (cddr data) + :for key = (first data) + :for value = (second data) + :while data + :when (eq key keyword) :do + (destructuring-bind (op qual (o c) &body body) value + (pushnew + (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret))))))) + +(defun* %refresh-component-inline-methods (component rest) + (%remove-component-inline-methods component) + (%define-component-inline-methods component rest)) + +(defun* parse-component-form (parent options) + (destructuring-bind + (type name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-keys form. important to keep them in sync + components pathname + perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to + do-first + (version nil versionp) + ;; list ends + &allow-other-keys) options + (declare (ignorable perform explain output-files operation-done-p)) + (check-component-input type name weakly-depends-on depends-on components in-order-to) + + (when (and parent + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + + (when versionp + (unless (parse-version version nil) + (warn (compatfmt "~@") + version name parent))) + + (let* ((args (list* :name (coerce-name name) + :pathname pathname + :parent parent + (remove-keys + '(components pathname + perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to) + rest))) + (ret (find-component parent name))) + (when weakly-depends-on + (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) + (when *serial-depends-on* + (push *serial-depends-on* depends-on)) + (if ret ; preserve identity + (apply 'reinitialize-instance ret args) + (setf ret (apply 'make-instance (class-for-type parent type) args))) + (component-pathname ret) ; eagerly compute the absolute pathname + (when (typep ret 'module) + (let ((*serial-depends-on* nil)) + (setf (module-components ret) + (loop + :for c-form :in components + :for c = (parse-component-form ret c-form) + :for name = (component-name c) + :collect c + :when serial :do (setf *serial-depends-on* name)))) + (compute-module-components-by-name ret)) + + (setf (component-load-dependencies ret) depends-on) ;; Used by POIU + + (setf (component-in-order-to ret) + (union-of-dependencies + in-order-to + `((compile-op (compile-op ,@depends-on)) + (load-op (load-op ,@depends-on))))) + (setf (component-do-first ret) + (union-of-dependencies + do-first + `((compile-op (load-op ,@depends-on))))) + + (%refresh-component-inline-methods ret rest) + ret))) + +(defun* reset-system (system &rest keys &key &allow-other-keys) + (change-class (change-class system 'proto-system) 'system) + (apply 'reinitialize-instance system keys)) + +(defun* do-defsystem (name &rest options + &key pathname (class 'system) + defsystem-depends-on &allow-other-keys) + ;; The system must be registered before we parse the body, + ;; otherwise we recur when trying to find an existing system + ;; of the same name to reuse options (e.g. pathname) from. + ;; To avoid infinite recursion in cases where you defsystem a system + ;; that is registered to a different location to find-system, + ;; we also need to remember it in a special variable *systems-being-defined*. + (with-system-definitions () + (let* ((name (coerce-name name)) + (registered (system-registered-p name)) + (registered! (if registered + (rplaca registered (get-universal-time)) + (register-system (make-instance 'system :name name)))) + (system (reset-system (cdr registered!) + :name name :source-file (load-pathname))) + (component-options (remove-keys '(:class) options))) + (setf (gethash name *systems-being-defined*) system) + (apply 'load-systems defsystem-depends-on) + ;; We change-class (when necessary) AFTER we load the defsystem-dep's + ;; since the class might not be defined as part of those. + (let ((class (class-for-type nil class))) + (unless (eq (type-of system) class) + (change-class system class))) + (parse-component-form + nil (list* + :module name + :pathname (determine-system-pathname pathname) + component-options))))) + +(defmacro defsystem (name &body options) + `(apply 'do-defsystem ',name ',options)) + +;;;; --------------------------------------------------------------------------- +;;;; run-shell-command +;;;; +;;;; run-shell-command functions for other lisp implementations will be +;;;; gratefully accepted, if they do the same thing. +;;;; If the docstring is ambiguous, send a bug report. +;;;; +;;;; WARNING! The function below is mostly dysfunctional. +;;;; For instance, it will probably run fine on most implementations on Unix, +;;;; which will hopefully use the shell /bin/sh (which we force in some cases) +;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell. +;;;; But behavior on Windows may vary wildly between implementations, +;;;; either relying on your having installed a POSIX sh, or going through +;;;; the CMD.EXE interpreter, for a totally different meaning, depending on +;;;; what is easily expressible in said implementation. +;;;; +;;;; We probably should move this functionality to its own system and deprecate +;;;; use of it from the asdf package. However, this would break unspecified +;;;; existing software, so until a clear alternative exists, we can't deprecate +;;;; it, and even after it's been deprecated, we will support it for a few +;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 +;;;; +;;;; As a suggested replacement which is portable to all ASDF-supported +;;;; implementations and operating systems except Genera, I recommend +;;;; xcvb-driver's xcvb-driver:run-program/ and its derivatives. + +(defun* run-shell-command (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, with +output to *VERBOSE-OUT*. Returns the shell's exit code." + (let ((command (apply 'format nil control-string args))) + (asdf-message "; $ ~A~%" command) + + #+abcl + (ext:run-shell-command command :output *verbose-out*) + + #+allegro + ;; will this fail if command has embedded quotes - it seems to work + (multiple-value-bind (stdout stderr exit-code) + (excl.osi:command-output + #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command) + #+mswindows command ; BEWARE! + :input nil :whole nil + #+mswindows :show-window #+mswindows :hide) + (asdf-message "~{~&~a~%~}~%" stderr) + (asdf-message "~{~&~a~%~}~%" stdout) + exit-code) + + #+clisp + ;; CLISP returns NIL for exit status zero. + (if *verbose-out* + (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r" + command)) + (outstream (ext:run-shell-command new-command :output :stream :wait t))) + (multiple-value-bind (retval out-lines) + (unwind-protect + (parse-clisp-shell-output outstream) + (ignore-errors (close outstream))) + (asdf-message "~{~&~a~%~}~%" out-lines) + retval)) + ;; there will be no output, just grab up the exit status + (or (ext:run-shell-command command :output nil :wait t) 0)) + + #+clozure + (nth-value 1 + (ccl:external-process-status + (ccl:run-program + (cond + ((os-unix-p) "/bin/sh") + ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE! + (t (error "Unsupported OS"))) + (if (os-unix-p) (list "-c" command) '()) + :input nil :output *verbose-out* :wait t))) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + + #+cormanlisp + (win32:system command) + + #+ecl ;; courtesy of Juan Jose Garcia Ripoll + (ext:system command) + + #+gcl + (lisp:system command) + + #+lispworks + (apply 'system:call-system-showing-output command + :show-cmd nil :prefix "" :output-stream *verbose-out* + (when (os-unix-p) '(:shell-type "/bin/sh"))) + + #+mcl + (ccl::with-cstrs ((%command command)) (_system %command)) + + #+mkcl + ;; This has next to no chance of working on basic Windows! + ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH. + (multiple-value-bind (io process exit-code) + (apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh" + (list "-c" command) + :input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it + #-windows '(:search nil)) + (declare (ignore io process)) + exit-code) + + #+sbcl + (sb-ext:process-exit-code + (apply 'sb-ext:run-program + #+win32 "sh" #-win32 "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out* + #+win32 '(:search t) #-win32 nil)) + + #+xcl + (ext:run-shell-command command) + + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl) + (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) + +#+clisp +(defun* parse-clisp-shell-output (stream) + "Helper function for running shell commands under clisp. Parses a specially- +crafted output string to recover the exit status of the shell command and a +list of lines of output." + (loop :with status-prefix = "ASDF-EXIT-STATUS " + :with prefix-length = (length status-prefix) + :with exit-status = -1 :with lines = () + :for line = (read-line stream nil nil) + :while line :do (push line lines) :finally + (let* ((last (car lines)) + (status (and last (>= (length last) prefix-length) + (string-equal last status-prefix :end1 prefix-length) + (parse-integer last :start prefix-length :junk-allowed t)))) + (when status + (setf exit-status status) + (pop lines) (when (equal "" (car lines)) (pop lines))) + (return (values exit-status (reverse lines)))))) + +;;;; --------------------------------------------------------------------------- +;;;; system-relative-pathname + +(defun* system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" + "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. +It used to expose ASDF internals with subtle differences with respect to +user expectations, that have been refactored away since. +We recommend you use ASDF:SYSTEM-SOURCE-FILE instead +for a mostly compatible replacement that we're supporting, +or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x)) + +(defmethod system-source-file ((system system)) + ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed + (unless (slot-boundp system 'source-file) + (%set-system-source-file + (probe-asd (component-name system) (component-pathname system)) system)) + (%system-source-file system)) +(defmethod system-source-file ((system-name string)) + (%system-source-file (find-system system-name))) +(defmethod system-source-file ((system-name symbol)) + (%system-source-file (find-system system-name))) + +(defun* system-source-directory (system-designator) + "Return a pathname object corresponding to the +directory in which the system specification (.asd file) is +located." + (pathname-directory-pathname (system-source-file system-designator))) + +(defun* relativize-directory (directory) + (cond + ((stringp directory) + (list :relative directory)) + ((eq (car directory) :absolute) + (cons :relative (cdr directory))) + (t + directory))) + +(defun* relativize-pathname-directory (pathspec) + (let ((p (pathname pathspec))) + (make-pathname + :directory (relativize-directory (pathname-directory p)) + :defaults p))) + +(defun* system-relative-pathname (system name &key type) + (subpathname (system-source-directory system) name :type type)) + + +;;; --------------------------------------------------------------------------- +;;; implementation-identifier +;;; +;;; produce a string to identify current implementation. +;;; Initially stolen from SLIME's SWANK, rewritten since. +;;; We're back to runtime checking, for the sake of e.g. ABCL. + +(defun* first-feature (features) + (dolist (x features) + (multiple-value-bind (val feature) + (if (consp x) (values (first x) (cons :or (rest x))) (values x x)) + (when (featurep feature) (return val))))) + +(defun implementation-type () + (first-feature + '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu + :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl))) + +(defun operating-system () + (first-feature + '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! + (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd + (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd + (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix + :genera))) + +(defun architecture () + (first-feature + '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386)) + (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) + (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) + :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) + :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach + ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, + ;; we may have to segregate the code still by architecture. + (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) + +#+clozure +(defun* ccl-fasl-version () + ;; the fasl version is target-dependent from CCL 1.8 on. + (or (let ((s 'ccl::target-fasl-version)) + (and (fboundp s) (funcall s))) + (and (boundp 'ccl::fasl-version) + (symbol-value 'ccl::fasl-version)) + (error "Can't determine fasl version."))) + +(defun lisp-version-string () + (let ((s (lisp-implementation-version))) + (car ; as opposed to OR, this idiom prevents some unreachable code warning + (list + #+allegro + (format nil "~A~@[~A~]~@[~A~]~@[~A~]" + excl::*common-lisp-version-number* + ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default) + (and (eq excl:*current-case-mode* :case-sensitive-lower) "M") + ;; Note if not using International ACL + ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm + (excl:ics-target-case (:-ics "8")) + (and (member :smp *features*) "S")) + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + #+clisp + (subseq s 0 (position #\space s)) ; strip build information (date, etc.) + #+clozure + (format nil "~d.~d-f~d" ; shorten for windows + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand (ccl-fasl-version) #xFF)) + #+cmu (substitute #\- #\/ s) + #+scl (format nil "~A~A" s + ;; ANSI upper case vs lower case. + (ecase ext:*case-mode* (:upper "") (:lower "l"))) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (subseq vcs-id 0 (min (length vcs-id) 8)))) + #+gcl (subseq s (1+ (position #\space s))) + #+genera + (multiple-value-bind (major minor) (sct:get-system-version "System") + (format nil "~D.~D" major minor)) + #+mcl (subseq s 8) ; strip the leading "Version " + s)))) + +(defun* implementation-identifier () + (substitute-if + #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) + (format nil "~(~a~@{~@[-~a~]~}~)" + (or (implementation-type) (lisp-implementation-type)) + (or (lisp-version-string) (lisp-implementation-version)) + (or (operating-system) (software-type)) + (or (architecture) (machine-type))))) + +(defun* hostname () + ;; Note: untested on RMCL + #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) + #+cormanlisp "localhost" ;; is there a better way? Does it matter? + #+allegro (excl.osi:gethostname) + #+clisp (first (split-string (machine-instance) :separator " ")) + #+gcl (system:gethostname)) + + +;;; --------------------------------------------------------------------------- +;;; Generic support for configuration files + +(defun inter-directory-separator () + (if (os-unix-p) #\: #\;)) + +(defun* user-homedir () + (truenamize + (pathname-directory-pathname + #+cormanlisp (ensure-directory-pathname (user-homedir-pathname)) + #+mcl (current-user-homedir-pathname) + #-(or cormanlisp mcl) (user-homedir-pathname)))) + +(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args) + (when (plusp (length x)) + (let ((p (if want-directory (ensure-directory-pathname x) (pathname x)))) + (when want-absolute + (unless (absolute-pathname-p p) + (cerror "ignore relative pathname" + "Invalid relative pathname ~A~@[ ~?~]" x fmt args) + (return-from ensure-pathname* nil))) + p))) +(defun* split-pathnames* (x want-absolute want-directory fmt &rest args) + (loop :for dir :in (split-string + x :separator (string (inter-directory-separator))) + :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args))) +(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x))) + (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x)) +(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x))) + (and (plusp (length s)) + (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s))) +(defun* getenv-absolute-directory (x) + (getenv-pathname x :want-absolute t :want-directory t)) +(defun* getenv-absolute-directories (x) + (getenv-pathnames x :want-absolute t :want-directory t)) + +(defun* get-folder-path (folder) + (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path + #+(and lispworks mswindows) (sys:get-folder-path folder) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + (ecase folder + (:local-appdata (getenv-absolute-directory "LOCALAPPDATA")) + (:appdata (getenv-absolute-directory "APPDATA")) + (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) + +(defun* user-configuration-directories () + (let ((dirs + `(,@(when (os-unix-p) + (cons + (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/") + (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS") + :collect (subpathname* dir "common-lisp/")))) + ,@(when (os-windows-p) + `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/") + ,(subpathname* (get-folder-path :appdata) "common-lisp/config/"))) + ,(subpathname (user-homedir) ".config/common-lisp/")))) + (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) + :from-end t :test 'equal))) + +(defun* system-configuration-directories () + (cond + ((os-unix-p) '(#p"/etc/common-lisp/")) + ((os-windows-p) + (aif + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData + (subpathname* (get-folder-path :common-appdata) "common-lisp/config/") + (list it))))) + +(defun* in-first-directory (dirs x &key (direction :input)) + (loop :with fun = (ecase direction + ((nil :input :probe) 'probe-file*) + ((:output :io) 'identity)) + :for dir :in dirs + :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir)))))) + +(defun* in-user-configuration-directory (x &key (direction :input)) + (in-first-directory (user-configuration-directories) x :direction direction)) +(defun* in-system-configuration-directory (x &key (direction :input)) + (in-first-directory (system-configuration-directories) x :direction direction)) + +(defun* configuration-inheritance-directive-p (x) + (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) + (or (member x kw) + (and (length=n-p x 1) (member (car x) kw))))) + +(defun* report-invalid-form (reporter &rest args) + (etypecase reporter + (null + (apply 'error 'invalid-configuration args)) + (function + (apply reporter args)) + ((or symbol string) + (apply 'error reporter args)) + (cons + (apply 'apply (append reporter args))))) + +(defvar *ignored-configuration-form* nil) + +(defun* validate-configuration-form (form tag directive-validator + &key location invalid-form-reporter) + (unless (and (consp form) (eq (car form) tag)) + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form form :location location) + (return-from validate-configuration-form nil)) + (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) + :for directive :in (cdr form) + :when (cond + ((configuration-inheritance-directive-p directive) + (incf inherit) t) + ((eq directive :ignore-invalid-entries) + (setf ignore-invalid-p t) t) + ((funcall directive-validator directive) + t) + (ignore-invalid-p + nil) + (t + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form directive :location location) + nil)) + :do (push directive x) + :finally + (unless (= inherit 1) + (report-invalid-form invalid-form-reporter + :arguments (list (compatfmt "~@") + :inherit-configuration :ignore-inherited-configuration))) + (return (nreverse x)))) + +(defun* validate-configuration-file (file validator &key description) + (let ((forms (read-file-forms file))) + (unless (length=n-p forms 1) + (error (compatfmt "~@~%") + description forms)) + (funcall validator (car forms) :location file))) + +(defun* hidden-file-p (pathname) + (equal (first-char (pathname-name pathname)) #\.)) + +(defun* directory* (pathname-spec &rest keys &key &allow-other-keys) + (apply 'directory pathname-spec + (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) + #+clozure '(:follow-links nil) + #+clisp '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl) + '(:resolve-symlinks nil)))))) + +(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter) + "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will +be applied to the results to yield a configuration form. Current +values of TAG include :source-registry and :output-translations." + (let ((files (sort (ignore-errors + (remove-if + 'hidden-file-p + (directory* (make-pathname :name :wild :type "conf" :defaults directory)))) + #'string< :key #'namestring))) + `(,tag + ,@(loop :for file :in files :append + (loop :with ignore-invalid-p = nil + :for form :in (read-file-forms file) + :when (eq form :ignore-invalid-entries) + :do (setf ignore-invalid-p t) + :else + :when (funcall validator form) + :collect form + :else + :when ignore-invalid-p + :do (setf *ignored-configuration-form* t) + :else + :do (report-invalid-form invalid-form-reporter :form form :location file))) + :inherit-configuration))) + + +;;; --------------------------------------------------------------------------- +;;; asdf-output-translations +;;; +;;; this code is heavily inspired from +;;; asdf-binary-translations, common-lisp-controller and cl-launch. +;;; --------------------------------------------------------------------------- + +(defvar *output-translations* () + "Either NIL (for uninitialized), or a list of one element, +said element itself being a sorted list of mappings. +Each mapping is a pair of a source pathname and destination pathname, +and the order is by decreasing length of namestring of the source pathname.") + +(defvar *user-cache* + (flet ((try (x &rest sub) (and x `(,x ,@sub)))) + (or + (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation) + (when (os-windows-p) + (try (or (get-folder-path :local-appdata) + (get-folder-path :appdata)) + "common-lisp" "cache" :implementation)) + '(:home ".cache" "common-lisp" :implementation)))) + +(defun* output-translations () + (car *output-translations*)) + +(defun* (setf output-translations) (new-value) + (setf *output-translations* + (list + (stable-sort (copy-list new-value) #'> + :key #'(lambda (x) + (etypecase (car x) + ((eql t) -1) + (pathname + (let ((directory (pathname-directory (car x)))) + (if (listp directory) (length directory) 0)))))))) + new-value) + +(defun* output-translations-initialized-p () + (and *output-translations* t)) + +(defun* clear-output-translations () + "Undoes any initialization of the output translations. +You might want to call that before you dump an image that would be resumed +with a different configuration, so the configuration would be re-read then." + (setf *output-translations* '()) + (values)) + +(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) + (values (or null pathname) &optional)) + resolve-location)) + +(defun* resolve-relative-location-component (x &key directory wilden) + (let ((r (etypecase x + (pathname x) + (string (coerce-pathname x :type (when directory :directory))) + (cons + (if (null (cdr x)) + (resolve-relative-location-component + (car x) :directory directory :wilden wilden) + (let* ((car (resolve-relative-location-component + (car x) :directory t :wilden nil))) + (merge-pathnames* + (resolve-relative-location-component + (cdr x) :directory directory :wilden wilden) + car)))) + ((eql :default-directory) + (relativize-pathname-directory (default-directory))) + ((eql :*/) *wild-directory*) + ((eql :**/) *wild-inferiors*) + ((eql :*.*.*) *wild-file*) + ((eql :implementation) + (coerce-pathname (implementation-identifier) :type :directory)) + ((eql :implementation-type) + (coerce-pathname (string-downcase (implementation-type)) :type :directory)) + ((eql :hostname) + (coerce-pathname (hostname) :type :directory))))) + (when (absolute-pathname-p r) + (error (compatfmt "~@") x)) + (if (or (pathnamep x) (not wilden)) r (wilden r)))) + +(defvar *here-directory* nil + "This special variable is bound to the currect directory during calls to +PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here +directive.") + +(defun* resolve-absolute-location-component (x &key directory wilden) + (let* ((r + (etypecase x + (pathname x) + (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x))) + #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) + (if directory (ensure-directory-pathname p) p))) + (cons + (return-from resolve-absolute-location-component + (if (null (cdr x)) + (resolve-absolute-location-component + (car x) :directory directory :wilden wilden) + (merge-pathnames* + (resolve-relative-location-component + (cdr x) :directory directory :wilden wilden) + (resolve-absolute-location-component + (car x) :directory t :wilden nil))))) + ((eql :root) + ;; special magic! we encode such paths as relative pathnames, + ;; but it means "relative to the root of the source pathname's host and device". + (return-from resolve-absolute-location-component + (let ((p (make-pathname :directory '(:relative)))) + (if wilden (wilden p) p)))) + ((eql :home) (user-homedir)) + ((eql :here) + (resolve-location (or *here-directory* + ;; give semantics in the case of use interactively + :default-directory) + :directory t :wilden nil)) + ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) + ((eql :system-cache) + (error "Using the :system-cache is deprecated. ~%~ +Please remove it from your ASDF configuration")) + ((eql :default-directory) (default-directory)))) + (s (if (and wilden (not (pathnamep x))) + (wilden r) + r))) + (unless (absolute-pathname-p s) + (error (compatfmt "~@") x)) + s)) + +(defun* resolve-location (x &key directory wilden) + (if (atom x) + (resolve-absolute-location-component x :directory directory :wilden wilden) + (loop :with path = (resolve-absolute-location-component + (car x) :directory (and (or directory (cdr x)) t) + :wilden (and wilden (null (cdr x)))) + :for (component . morep) :on (cdr x) + :for dir = (and (or morep directory) t) + :for wild = (and wilden (not morep)) + :do (setf path (merge-pathnames* + (resolve-relative-location-component + component :directory dir :wilden wild) + path)) + :finally (return path)))) + +(defun* location-designator-p (x) + (flet ((absolute-component-p (c) + (typep c '(or string pathname + (member :root :home :here :user-cache :system-cache :default-directory)))) + (relative-component-p (c) + (typep c '(or string pathname + (member :default-directory :*/ :**/ :*.*.* + :implementation :implementation-type))))) + (or (typep x 'boolean) + (absolute-component-p x) + (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) + +(defun* location-function-p (x) + (and + (length=n-p x 2) + (eq (car x) :function) + (or (symbolp (cadr x)) + (and (consp (cadr x)) + (eq (caadr x) 'lambda) + (length=n-p (cadadr x) 2))))) + +(defun* validate-output-translations-directive (directive) + (or (member directive '(:enable-user-cache :disable-cache nil)) + (and (consp directive) + (or (and (length=n-p directive 2) + (or (and (eq (first directive) :include) + (typep (second directive) '(or string pathname null))) + (and (location-designator-p (first directive)) + (or (location-designator-p (second directive)) + (location-function-p (second directive)))))) + (and (length=n-p directive 1) + (location-designator-p (first directive))))))) + +(defun* validate-output-translations-form (form &key location) + (validate-configuration-form + form + :output-translations + 'validate-output-translations-directive + :location location :invalid-form-reporter 'invalid-output-translation)) + +(defun* validate-output-translations-file (file) + (validate-configuration-file + file 'validate-output-translations-form :description "output translations")) + +(defun* validate-output-translations-directory (directory) + (validate-configuration-directory + directory :output-translations 'validate-output-translations-directive + :invalid-form-reporter 'invalid-output-translation)) + +(defun* parse-output-translations-string (string &key location) + (cond + ((or (null string) (equal string "")) + '(:output-translations :inherit-configuration)) + ((not (stringp string)) + (error (compatfmt "~@") string)) + ((eql (char string 0) #\") + (parse-output-translations-string (read-from-string string) :location location)) + ((eql (char string 0) #\() + (validate-output-translations-form (read-from-string string) :location location)) + (t + (loop + :with inherit = nil + :with directives = () + :with start = 0 + :with end = (length string) + :with source = nil + :with separator = (inter-directory-separator) + :for i = (or (position separator string :start start) end) :do + (let ((s (subseq string start i))) + (cond + (source + (push (list source (if (equal "" s) nil s)) directives) + (setf source nil)) + ((equal "" s) + (when inherit + (error (compatfmt "~@") + string)) + (setf inherit t) + (push :inherit-configuration directives)) + (t + (setf source s))) + (setf start (1+ i)) + (when (> start end) + (when source + (error (compatfmt "~@") + string)) + (unless inherit + (push :ignore-inherited-configuration directives)) + (return `(:output-translations ,@(nreverse directives))))))))) + +(defparameter *default-output-translations* + '(environment-output-translations + user-output-translations-pathname + user-output-translations-directory-pathname + system-output-translations-pathname + system-output-translations-directory-pathname)) + +(defun* wrapping-output-translations () + `(:output-translations + ;; Some implementations have precompiled ASDF systems, + ;; so we must disable translations for implementation paths. + #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t))) + (when h `((,(truenamize h) ,*wild-inferiors*) ()))) + ;; The below two are not needed: no precompiled ASDF system there + #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ()) + #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) + ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) + ;; All-import, here is where we want user stuff to be: + :inherit-configuration + ;; These are for convenience, and can be overridden by the user: + #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + ;; We enable the user cache by default, and here is the place we do: + :enable-user-cache)) + +(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) +(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) + +(defun* user-output-translations-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-file* :direction direction)) +(defun* system-output-translations-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-file* :direction direction)) +(defun* user-output-translations-directory-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-directory* :direction direction)) +(defun* system-output-translations-directory-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-directory* :direction direction)) +(defun* environment-output-translations () + (getenv "ASDF_OUTPUT_TRANSLATIONS")) + +(defgeneric* process-output-translations (spec &key inherit collect)) +(declaim (ftype (function (t &key (:collect (or symbol function))) t) + inherit-output-translations)) +(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t) + process-output-translations-directive)) + +(defmethod process-output-translations ((x symbol) &key + (inherit *default-output-translations*) + collect) + (process-output-translations (funcall x) :inherit inherit :collect collect)) +(defmethod process-output-translations ((pathname pathname) &key inherit collect) + (cond + ((directory-pathname-p pathname) + (process-output-translations (validate-output-translations-directory pathname) + :inherit inherit :collect collect)) + ((probe-file* pathname) + (process-output-translations (validate-output-translations-file pathname) + :inherit inherit :collect collect)) + (t + (inherit-output-translations inherit :collect collect)))) +(defmethod process-output-translations ((string string) &key inherit collect) + (process-output-translations (parse-output-translations-string string) + :inherit inherit :collect collect)) +(defmethod process-output-translations ((x null) &key inherit collect) + (declare (ignorable x)) + (inherit-output-translations inherit :collect collect)) +(defmethod process-output-translations ((form cons) &key inherit collect) + (dolist (directive (cdr (validate-output-translations-form form))) + (process-output-translations-directive directive :inherit inherit :collect collect))) + +(defun* inherit-output-translations (inherit &key collect) + (when inherit + (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) + +(defun* process-output-translations-directive (directive &key inherit collect) + (if (atom directive) + (ecase directive + ((:enable-user-cache) + (process-output-translations-directive '(t :user-cache) :collect collect)) + ((:disable-cache) + (process-output-translations-directive '(t t) :collect collect)) + ((:inherit-configuration) + (inherit-output-translations inherit :collect collect)) + ((:ignore-inherited-configuration :ignore-invalid-entries nil) + nil)) + (let ((src (first directive)) + (dst (second directive))) + (if (eq src :include) + (when dst + (process-output-translations (pathname dst) :inherit nil :collect collect)) + (when src + (let ((trusrc (or (eql src t) + (let ((loc (resolve-location src :directory t :wilden t))) + (if (absolute-pathname-p loc) (truenamize loc) loc))))) + (cond + ((location-function-p dst) + (funcall collect + (list trusrc + (if (symbolp (second dst)) + (fdefinition (second dst)) + (eval (second dst)))))) + ((eq dst t) + (funcall collect (list trusrc t))) + (t + (let* ((trudst (if dst + (resolve-location dst :directory t :wilden t) + trusrc)) + (wilddst (merge-pathnames* *wild-file* trudst))) + (funcall collect (list wilddst t)) + (funcall collect (list trusrc trudst))))))))))) + +(defun* compute-output-translations (&optional parameter) + "read the configuration, return it" + (remove-duplicates + (while-collecting (c) + (inherit-output-translations + `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) + :test 'equal :from-end t)) + +(defvar *output-translations-parameter* nil) + +(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*)) + "read the configuration, initialize the internal configuration variable, +return the configuration" + (setf *output-translations-parameter* parameter + (output-translations) (compute-output-translations parameter))) + +(defun* disable-output-translations () + "Initialize output translations in a way that maps every file to itself, +effectively disabling the output translation facility." + (initialize-output-translations + '(:output-translations :disable-cache :ignore-inherited-configuration))) + +;; checks an initial variable to see whether the state is initialized +;; or cleared. In the former case, return current configuration; in +;; the latter, initialize. ASDF will call this function at the start +;; of (asdf:find-system). +(defun* ensure-output-translations () + (if (output-translations-initialized-p) + (output-translations) + (initialize-output-translations))) + +(defun* translate-pathname* (path absolute-source destination &optional root source) + (declare (ignore source)) + (cond + ((functionp destination) + (funcall destination path absolute-source)) + ((eq destination t) + path) + ((not (pathnamep destination)) + (error "Invalid destination")) + ((not (absolute-pathname-p destination)) + (translate-pathname path absolute-source (merge-pathnames* destination root))) + (root + (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) + (t + (translate-pathname path absolute-source destination)))) + +(defun* apply-output-translations (path) + #+cormanlisp (truenamize path) #-cormanlisp + (etypecase path + (logical-pathname + path) + ((or pathname string) + (ensure-output-translations) + (loop :with p = (truenamize path) + :for (source destination) :in (car *output-translations*) + :for root = (when (or (eq source t) + (and (pathnamep source) + (not (absolute-pathname-p source)))) + (pathname-root p)) + :for absolute-source = (cond + ((eq source t) (wilden root)) + (root (merge-pathnames* source root)) + (t source)) + :when (or (eq source t) (pathname-match-p p absolute-source)) + :return (translate-pathname* p absolute-source destination root source) + :finally (return p))))) + +(defmethod output-files :around (operation component) + "Translate output files, unless asked not to" + operation component ;; hush genera, not convinced by declare ignorable(!) + (values + (multiple-value-bind (files fixedp) (call-next-method) + (if fixedp + files + (mapcar #'apply-output-translations files))) + t)) + +(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) + (if (absolute-pathname-p output-file) + ;; what cfp should be doing, w/ mp* instead of mp + (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys))) + (defaults (make-pathname + :type type :defaults (merge-pathnames* input-file)))) + (merge-pathnames* output-file defaults)) + (apply-output-translations + (apply 'compile-file-pathname input-file + (if output-file keys (remove-keyword :output-file keys)))))) + +(defun* tmpize-pathname (x) + (make-pathname + :name (strcat "ASDF-TMP-" (pathname-name x)) + :defaults x)) + +(defun* delete-file-if-exists (x) + (when (and x (probe-file* x)) + (delete-file x))) + +(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys) + (let* ((keywords (remove-keyword :compile-check keys)) + (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords)) + (tmp-file (tmpize-pathname output-file)) + (status :error)) + (multiple-value-bind (output-truename warnings-p failure-p) + (apply 'compile-file input-file :output-file tmp-file keywords) + (cond + (failure-p + (setf status *compile-file-failure-behaviour*)) + (warnings-p + (setf status *compile-file-warnings-behaviour*)) + (t + (setf status :success))) + (cond + ((and (ecase status + ((:success :warn :ignore) t) + ((:error nil))) + (or (not compile-check) + (apply compile-check input-file :output-file tmp-file keywords))) + (delete-file-if-exists output-file) + (when output-truename + (rename-file output-truename output-file) + (setf output-truename output-file))) + (t ;; error or failed check + (delete-file-if-exists output-truename) + (setf output-truename nil failure-p t))) + (values output-truename warnings-p failure-p)))) + +#+abcl +(defun* translate-jar-pathname (source wildcard) + (declare (ignore wildcard)) + (let* ((p (pathname (first (pathname-device source)))) + (root (format nil "/___jar___file___root___/~@[~A/~]" + (and (find :windows *features*) + (pathname-device p))))) + (apply-output-translations + (merge-pathnames* + (relativize-pathname-directory source) + (merge-pathnames* + (relativize-pathname-directory (ensure-directory-pathname p)) + root))))) + +;;;; ----------------------------------------------------------------- +;;;; Compatibility mode for ASDF-Binary-Locations + +(defmethod operate :before (operation-class system &rest args &key &allow-other-keys) + (declare (ignorable operation-class system args)) + (when (find-symbol* '#:output-files-for-system-and-operation :asdf) + (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. +ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, +which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, +and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. +In case you insist on preserving your previous A-B-L configuration, but +do not know how to achieve the same effect with A-O-T, you may use function +ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; +call that function where you would otherwise have loaded and configured A-B-L."))) + +(defun* enable-asdf-binary-locations-compatibility + (&key + (centralize-lisp-binaries nil) + (default-toplevel-directory + (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? + (include-per-user-information nil) + (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) + (source-to-target-mappings nil)) + #+(or clisp ecl mkcl) + (when (null map-all-source-files) + (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) + (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) + (mapped-files (if map-all-source-files *wild-file* + (make-pathname :type fasl-type :defaults *wild-file*))) + (destination-directory + (if centralize-lisp-binaries + `(,default-toplevel-directory + ,@(when include-per-user-information + (cdr (pathname-directory (user-homedir)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) + (initialize-output-translations + `(:output-translations + ,@source-to-target-mappings + ((:root ,*wild-inferiors* ,mapped-files) + (,@destination-directory ,mapped-files)) + (t t) + :ignore-inherited-configuration)))) + +;;;; ----------------------------------------------------------------- +;;;; Source Registry Configuration, by Francois-Rene Rideau +;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 + +;; Using ack 1.2 exclusions +(defvar *default-source-registry-exclusions* + '(".bzr" ".cdv" + ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards + ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" + "_sgbak" "autom4te.cache" "cover_db" "_build" + "debian")) ;; debian often builds stuff under the debian directory... BAD. + +(defvar *source-registry-exclusions* *default-source-registry-exclusions*) + +(defvar *source-registry* nil + "Either NIL (for uninitialized), or an equal hash-table, mapping +system names to pathnames of .asd files") + +(defun* source-registry-initialized-p () + (typep *source-registry* 'hash-table)) + +(defun* clear-source-registry () + "Undoes any initialization of the source registry. +You might want to call that before you dump an image that would be resumed +with a different configuration, so the configuration would be re-read then." + (setf *source-registry* nil) + (values)) + +(defparameter *wild-asd* + (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) + +(defun* filter-logical-directory-results (directory entries merger) + (if (typep directory 'logical-pathname) + ;; Try hard to not resolve logical-pathname into physical pathnames; + ;; otherwise logical-pathname users/lovers will be disappointed. + ;; If directory* could use some implementation-dependent magic, + ;; we will have logical pathnames already; otherwise, + ;; we only keep pathnames for which specifying the name and + ;; translating the LPN commute. + (loop :for f :in entries + :for p = (or (and (typep f 'logical-pathname) f) + (let* ((u (ignore-errors (funcall merger f)))) + ;; The first u avoids a cumbersome (truename u) error. + ;; At this point f should already be a truename, + ;; but isn't quite in CLISP, for doesn't have :version :newest + (and u (equal (ignore-errors (truename u)) (truename f)) u))) + :when p :collect p) + entries)) + +(defun* directory-files (directory &optional (pattern *wild-file*)) + (let ((dir (pathname directory))) + (when (typep dir 'logical-pathname) + ;; Because of the filtering we do below, + ;; logical pathnames have restrictions on wild patterns. + ;; Not that the results are very portable when you use these patterns on physical pathnames. + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) + (filter-logical-directory-results + directory entries + #'(lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical (pathname-name f)) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f)))))))) + +(defun* directory-asd-files (directory) + (directory-files directory *wild-asd*)) + +(defun* subdirectories (directory) + (let* ((directory (ensure-directory-pathname directory)) + #-(or abcl cormanlisp genera xcl) + (wild (merge-pathnames* + #-(or abcl allegro cmu lispworks sbcl scl xcl) + *wild-directory* + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #-(or abcl cormanlisp genera xcl) + (ignore-errors + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (fs:directory-list directory)) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) + (dirs (loop :for x :in dirs + :for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu sbcl scl) (directory-pathname-p x) + #+genera (getf (cdr x) :directory) + #+lispworks (lw:file-directory-p x) + :when d :collect #+(or abcl allegro xcl) d + #+genera (ensure-directory-pathname (first x)) + #+(or cmu lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) + '(:absolute)))) ; because allegro returns NIL for #p"FOO:" + #'(lambda (d) + (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory (append prefix (make-pathname-component-logical (last dir))))))))))) + +(defun* collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) + +(defun* collect-sub*directories (directory collectp recursep collector) + (when (funcall collectp directory) + (funcall collector directory)) + (dolist (subdir (subdirectories directory)) + (when (funcall recursep subdir) + (collect-sub*directories subdir collectp recursep collector)))) + +(defun* collect-sub*directories-asd-files + (directory &key + (exclude *default-source-registry-exclusions*) + collect) + (collect-sub*directories + directory + (constantly t) + #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal))) + #'(lambda (dir) (collect-asds-in-directory dir collect)))) + +(defun* validate-source-registry-directive (directive) + (or (member directive '(:default-registry)) + (and (consp directive) + (let ((rest (rest directive))) + (case (first directive) + ((:include :directory :tree) + (and (length=n-p rest 1) + (location-designator-p (first rest)))) + ((:exclude :also-exclude) + (every #'stringp rest)) + ((:default-registry) + (null rest))))))) + +(defun* validate-source-registry-form (form &key location) + (validate-configuration-form + form :source-registry 'validate-source-registry-directive + :location location :invalid-form-reporter 'invalid-source-registry)) + +(defun* validate-source-registry-file (file) + (validate-configuration-file + file 'validate-source-registry-form :description "a source registry")) + +(defun* validate-source-registry-directory (directory) + (validate-configuration-directory + directory :source-registry 'validate-source-registry-directive + :invalid-form-reporter 'invalid-source-registry)) + +(defun* parse-source-registry-string (string &key location) + (cond + ((or (null string) (equal string "")) + '(:source-registry :inherit-configuration)) + ((not (stringp string)) + (error (compatfmt "~@") string)) + ((find (char string 0) "\"(") + (validate-source-registry-form (read-from-string string) :location location)) + (t + (loop + :with inherit = nil + :with directives = () + :with start = 0 + :with end = (length string) + :with separator = (inter-directory-separator) + :for pos = (position separator string :start start) :do + (let ((s (subseq string start (or pos end)))) + (flet ((check (dir) + (unless (absolute-pathname-p dir) + (error (compatfmt "~@") string)) + dir)) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error (compatfmt "~@") + string)) + (setf inherit t) + (push ':inherit-configuration directives)) + ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? + (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) + (t + (push `(:directory ,(check s)) directives)))) + (cond + (pos + (setf start (1+ pos))) + (t + (unless inherit + (push '(:ignore-inherited-configuration) directives)) + (return `(:source-registry ,@(nreverse directives)))))))))) + +(defun* register-asd-directory (directory &key recurse exclude collect) + (if (not recurse) + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files + directory :exclude exclude :collect collect))) + +(defparameter *default-source-registries* + '(environment-source-registry + user-source-registry + user-source-registry-directory + system-source-registry + system-source-registry-directory + default-source-registry)) + +(defparameter *source-registry-file* (coerce-pathname "source-registry.conf")) +(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/")) + +(defun* wrapping-source-registry () + `(:source-registry + #+ecl (:tree ,(translate-logical-pathname "SYS:")) + #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) + #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t))) + :inherit-configuration + #+cmu (:tree #p"modules:") + #+scl (:tree #p"file://modules/"))) +(defun* default-source-registry () + `(:source-registry + #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) + (:directory ,(default-directory)) + ,@(loop :for dir :in + `(,@(when (os-unix-p) + `(,(or (getenv-absolute-directory "XDG_DATA_HOME") + (subpathname (user-homedir) ".local/share/")) + ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") + '("/usr/local/share" "/usr/share")))) + ,@(when (os-windows-p) + (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata)))) + :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) + :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) + :inherit-configuration)) +(defun* user-source-registry (&key (direction :input)) + (in-user-configuration-directory *source-registry-file* :direction direction)) +(defun* system-source-registry (&key (direction :input)) + (in-system-configuration-directory *source-registry-file* :direction direction)) +(defun* user-source-registry-directory (&key (direction :input)) + (in-user-configuration-directory *source-registry-directory* :direction direction)) +(defun* system-source-registry-directory (&key (direction :input)) + (in-system-configuration-directory *source-registry-directory* :direction direction)) +(defun* environment-source-registry () + (getenv "CL_SOURCE_REGISTRY")) + +(defgeneric* process-source-registry (spec &key inherit register)) +(declaim (ftype (function (t &key (:register (or symbol function))) t) + inherit-source-registry)) +(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t) + process-source-registry-directive)) + +(defmethod process-source-registry ((x symbol) &key inherit register) + (process-source-registry (funcall x) :inherit inherit :register register)) +(defmethod process-source-registry ((pathname pathname) &key inherit register) + (cond + ((directory-pathname-p pathname) + (let ((*here-directory* (truenamize pathname))) + (process-source-registry (validate-source-registry-directory pathname) + :inherit inherit :register register))) + ((probe-file* pathname) + (let ((*here-directory* (pathname-directory-pathname pathname))) + (process-source-registry (validate-source-registry-file pathname) + :inherit inherit :register register))) + (t + (inherit-source-registry inherit :register register)))) +(defmethod process-source-registry ((string string) &key inherit register) + (process-source-registry (parse-source-registry-string string) + :inherit inherit :register register)) +(defmethod process-source-registry ((x null) &key inherit register) + (declare (ignorable x)) + (inherit-source-registry inherit :register register)) +(defmethod process-source-registry ((form cons) &key inherit register) + (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) + (dolist (directive (cdr (validate-source-registry-form form))) + (process-source-registry-directive directive :inherit inherit :register register)))) + +(defun* inherit-source-registry (inherit &key register) + (when inherit + (process-source-registry (first inherit) :register register :inherit (rest inherit)))) + +(defun* process-source-registry-directive (directive &key inherit register) + (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) + (ecase kw + ((:include) + (destructuring-bind (pathname) rest + (process-source-registry (resolve-location pathname) :inherit nil :register register))) + ((:directory) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (resolve-location pathname :directory t))))) + ((:tree) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (resolve-location pathname :directory t) + :recurse t :exclude *source-registry-exclusions*)))) + ((:exclude) + (setf *source-registry-exclusions* rest)) + ((:also-exclude) + (appendf *source-registry-exclusions* rest)) + ((:default-registry) + (inherit-source-registry '(default-source-registry) :register register)) + ((:inherit-configuration) + (inherit-source-registry inherit :register register)) + ((:ignore-inherited-configuration) + nil))) + nil) + +(defun* flatten-source-registry (&optional parameter) + (remove-duplicates + (while-collecting (collect) + (let ((*default-pathname-defaults* (default-directory))) + (inherit-source-registry + `(wrapping-source-registry + ,parameter + ,@*default-source-registries*) + :register #'(lambda (directory &key recurse exclude) + (collect (list directory :recurse recurse :exclude exclude)))))) + :test 'equal :from-end t)) + +;; Will read the configuration and initialize all internal variables. +(defun* compute-source-registry (&optional parameter (registry *source-registry*)) + (dolist (entry (flatten-source-registry parameter)) + (destructuring-bind (directory &key recurse exclude) entry + (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates + (register-asd-directory + directory :recurse recurse :exclude exclude :collect + #'(lambda (asd) + (let* ((name (pathname-name asd)) + (name (if (typep asd 'logical-pathname) + ;; logical pathnames are upper-case, + ;; at least in the CLHS and on SBCL, + ;; yet (coerce-name :foo) is lower-case. + ;; won't work well with (load-system "Foo") + ;; instead of (load-system 'foo) + (string-downcase name) + name))) + (cond + ((gethash name registry) ; already shadowed by something else + nil) + ((gethash name h) ; conflict at current level + (when *asdf-verbose* + (warn (compatfmt "~@") + directory recurse name (gethash name h) asd))) + (t + (setf (gethash name registry) asd) + (setf (gethash name h) asd)))))) + h))) + (values)) + +(defvar *source-registry-parameter* nil) + +(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) + (setf *source-registry-parameter* parameter) + (setf *source-registry* (make-hash-table :test 'equal)) + (compute-source-registry parameter)) + +;; Checks an initial variable to see whether the state is initialized +;; or cleared. In the former case, return current configuration; in +;; the latter, initialize. ASDF will call this function at the start +;; of (asdf:find-system) to make sure the source registry is initialized. +;; However, it will do so *without* a parameter, at which point it +;; will be too late to provide a parameter to this function, though +;; you may override the configuration explicitly by calling +;; initialize-source-registry directly with your parameter. +(defun* ensure-source-registry (&optional parameter) + (unless (source-registry-initialized-p) + (initialize-source-registry parameter)) + (values)) + +(defun* sysdef-source-registry-search (system) + (ensure-source-registry) + (values (gethash (coerce-name system) *source-registry*))) + +(defun* clear-configuration () + (clear-source-registry) + (clear-output-translations)) + + +;;; ECL and MKCL support for COMPILE-OP / LOAD-OP +;;; +;;; In ECL and MKCL, these operations produce both +;;; FASL files and the object files that they are built from. +;;; Having both of them allows us to later on reuse the object files +;;; for bundles, libraries, standalone executables, etc. +;;; +;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes +;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp. +;;; +;;; Also, register-pre-built-system. + +#+(or ecl mkcl) +(progn + (defun register-pre-built-system (name) + (register-system (make-instance 'system :name (coerce-name name) :source-file nil))) + + #+(or (and ecl win32) (and mkcl windows)) + (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal) + (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source)))) + + (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* + (loop :for f :in #+ecl ext:*module-provider-functions* + #+mkcl mk-ext::*module-provider-functions* + :unless (eq f 'module-provide-asdf) + :collect #'(lambda (name) + (let ((l (multiple-value-list (funcall f name)))) + (and (first l) (register-pre-built-system (coerce-name name))) + (values-list l))))) + + (setf *compile-op-compile-file-function* 'compile-file-keeping-object) + + (defun compile-file-keeping-object (input-file &rest keys &key &allow-other-keys) + (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys) + #+mkcl progn + (multiple-value-bind (object-file flags1 flags2) + (apply 'compile-file* input-file + #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil keys) + (values (and object-file + (compiler::build-fasl + (compile-file-pathname object-file + #+ecl :type #+ecl :fasl #+mkcl :fasl-p #+mkcl t) + #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file)) + object-file) + flags1 + flags2))))) + +;;;; ----------------------------------------------------------------------- +;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL +;;;; +(defun* module-provide-asdf (name) + (handler-bind + ((style-warning #'muffle-warning) + #-genera + (missing-component (constantly nil)) + (error #'(lambda (e) + (format *error-output* (compatfmt "~@~%") + name e)))) + (let ((*verbose-out* (make-broadcast-stream)) + (system (find-system (string-downcase name) nil))) + (when system + (require-system system :verbose nil) + t)))) + +#+(or abcl clisp clozure cmu ecl mkcl sbcl) +(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom)))) + (when x + (eval `(pushnew 'module-provide-asdf + #+abcl sys::*module-provider-functions* + #+clisp ,x + #+clozure ccl:*module-provider-functions* + #+(or cmu ecl) ext:*module-provider-functions* + #+mkcl mk-ext:*module-provider-functions* + #+sbcl sb-ext:*module-provider-functions*)))) + + +;;;; ------------------------------------------------------------------------- +;;;; Cleanups after hot-upgrade. +;;;; Things to do in case we're upgrading from a previous version of ASDF. +;;;; See https://bugs.launchpad.net/asdf/+bug/485687 +;;;; + +;;; If a previous version of ASDF failed to read some configuration, try again. +(when *ignored-configuration-form* + (clear-configuration) + (setf *ignored-configuration-form* nil)) + +;;;; ----------------------------------------------------------------- +;;;; Done! +(when *load-verbose* + (asdf-message ";; ASDF, version ~a~%" (asdf-version))) + +#+mkcl +(progn + (defvar *loading-asdf-bundle* nil) + (unless *loading-asdf-bundle* + (let ((*central-registry* + (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*)) + (*loading-asdf-bundle* t)) + (clear-system :asdf-bundle) ;; we hope to force a reload. + (multiple-value-bind (result bundling-error) + (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle)) + (unless result + (format *error-output* + "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%" + bundling-error)))))) + +#+allegro +(eval-when (:compile-toplevel :execute) + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) + +(pushnew :asdf *features*) +(pushnew :asdf2 *features*) + +(provide :asdf) + +;;; Local Variables: +;;; mode: lisp +;;; End: diff --git a/sbcl/.quicklisp/client-info.sexp b/sbcl/.quicklisp/client-info.sexp new file mode 100644 index 0000000..15ea093 --- /dev/null +++ b/sbcl/.quicklisp/client-info.sexp @@ -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")) diff --git a/sbcl/.quicklisp/dists/quicklisp/archives/alexandria-20191227-git.tgz b/sbcl/.quicklisp/dists/quicklisp/archives/alexandria-20191227-git.tgz new file mode 100644 index 0000000..ae3278c Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/archives/alexandria-20191227-git.tgz differ diff --git a/sbcl/.quicklisp/dists/quicklisp/archives/slime-v2.24.tgz b/sbcl/.quicklisp/dists/quicklisp/archives/slime-v2.24.tgz new file mode 100644 index 0000000..b0a2c9f Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/archives/slime-v2.24.tgz differ diff --git a/sbcl/.quicklisp/dists/quicklisp/archives/split-sequence-v2.0.0.tgz b/sbcl/.quicklisp/dists/quicklisp/archives/split-sequence-v2.0.0.tgz new file mode 100644 index 0000000..fd15c57 Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/archives/split-sequence-v2.0.0.tgz differ diff --git a/sbcl/.quicklisp/dists/quicklisp/archives/trivial-gray-streams-20181018-git.tgz b/sbcl/.quicklisp/dists/quicklisp/archives/trivial-gray-streams-20181018-git.tgz new file mode 100644 index 0000000..9806b7d Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/archives/trivial-gray-streams-20181018-git.tgz differ diff --git a/sbcl/.quicklisp/dists/quicklisp/archives/usocket-0.8.3.tgz b/sbcl/.quicklisp/dists/quicklisp/archives/usocket-0.8.3.tgz new file mode 100644 index 0000000..c76a656 Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/archives/usocket-0.8.3.tgz differ diff --git a/sbcl/.quicklisp/dists/quicklisp/archives/vom-20160825-git.tgz b/sbcl/.quicklisp/dists/quicklisp/archives/vom-20160825-git.tgz new file mode 100644 index 0000000..a159867 Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/archives/vom-20160825-git.tgz differ diff --git a/sbcl/.quicklisp/dists/quicklisp/archives/yason-v0.7.8.tgz b/sbcl/.quicklisp/dists/quicklisp/archives/yason-v0.7.8.tgz new file mode 100644 index 0000000..c34daf3 Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/archives/yason-v0.7.8.tgz differ diff --git a/sbcl/.quicklisp/dists/quicklisp/distinfo.txt b/sbcl/.quicklisp/dists/quicklisp/distinfo.txt new file mode 100644 index 0000000..86798cc --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/distinfo.txt @@ -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 diff --git a/sbcl/.quicklisp/dists/quicklisp/enabled.txt b/sbcl/.quicklisp/dists/quicklisp/enabled.txt new file mode 100644 index 0000000..e69de29 diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/releases/alexandria.txt b/sbcl/.quicklisp/dists/quicklisp/installed/releases/alexandria.txt new file mode 100644 index 0000000..9c5a37d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/releases/alexandria.txt @@ -0,0 +1 @@ +dists/quicklisp/software/alexandria-20191227-git/ diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/releases/slime.txt b/sbcl/.quicklisp/dists/quicklisp/installed/releases/slime.txt new file mode 100644 index 0000000..1a3e79a --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/releases/slime.txt @@ -0,0 +1 @@ +dists/quicklisp/software/slime-v2.24/ diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/releases/split-sequence.txt b/sbcl/.quicklisp/dists/quicklisp/installed/releases/split-sequence.txt new file mode 100644 index 0000000..28a0527 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/releases/split-sequence.txt @@ -0,0 +1 @@ +dists/quicklisp/software/split-sequence-v2.0.0/ diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/releases/trivial-gray-streams.txt b/sbcl/.quicklisp/dists/quicklisp/installed/releases/trivial-gray-streams.txt new file mode 100644 index 0000000..2e59812 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/releases/trivial-gray-streams.txt @@ -0,0 +1 @@ +dists/quicklisp/software/trivial-gray-streams-20181018-git/ diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/releases/usocket.txt b/sbcl/.quicklisp/dists/quicklisp/installed/releases/usocket.txt new file mode 100644 index 0000000..c7f96c6 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/releases/usocket.txt @@ -0,0 +1 @@ +dists/quicklisp/software/usocket-0.8.3/ diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/releases/vom.txt b/sbcl/.quicklisp/dists/quicklisp/installed/releases/vom.txt new file mode 100644 index 0000000..00d6362 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/releases/vom.txt @@ -0,0 +1 @@ +dists/quicklisp/software/vom-20160825-git/ diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/releases/yason.txt b/sbcl/.quicklisp/dists/quicklisp/installed/releases/yason.txt new file mode 100644 index 0000000..0071fa5 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/releases/yason.txt @@ -0,0 +1 @@ +dists/quicklisp/software/yason-v0.7.8/ diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/alexandria-tests.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/alexandria-tests.txt new file mode 100644 index 0000000..04e4471 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/alexandria-tests.txt @@ -0,0 +1 @@ +dists/quicklisp/software/alexandria-20191227-git/alexandria-tests.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/alexandria.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/alexandria.txt new file mode 100644 index 0000000..8f1de51 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/alexandria.txt @@ -0,0 +1 @@ +dists/quicklisp/software/alexandria-20191227-git/alexandria.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/split-sequence.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/split-sequence.txt new file mode 100644 index 0000000..a06b52f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/split-sequence.txt @@ -0,0 +1 @@ +dists/quicklisp/software/split-sequence-v2.0.0/split-sequence.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/swank.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/swank.txt new file mode 100644 index 0000000..330bc34 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/swank.txt @@ -0,0 +1 @@ +dists/quicklisp/software/slime-v2.24/swank.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/trivial-gray-streams-test.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/trivial-gray-streams-test.txt new file mode 100644 index 0000000..60077c8 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/trivial-gray-streams-test.txt @@ -0,0 +1 @@ +dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams-test.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/trivial-gray-streams.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/trivial-gray-streams.txt new file mode 100644 index 0000000..7db7b2f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/trivial-gray-streams.txt @@ -0,0 +1 @@ +dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/usocket-server.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/usocket-server.txt new file mode 100644 index 0000000..0e815d1 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/usocket-server.txt @@ -0,0 +1 @@ +dists/quicklisp/software/usocket-0.8.3/usocket-server.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/usocket-test.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/usocket-test.txt new file mode 100644 index 0000000..2610e37 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/usocket-test.txt @@ -0,0 +1 @@ +dists/quicklisp/software/usocket-0.8.3/usocket-test.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/usocket.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/usocket.txt new file mode 100644 index 0000000..4f2aa80 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/usocket.txt @@ -0,0 +1 @@ +dists/quicklisp/software/usocket-0.8.3/usocket.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/vom.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/vom.txt new file mode 100644 index 0000000..94241fd --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/vom.txt @@ -0,0 +1 @@ +dists/quicklisp/software/vom-20160825-git/vom.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/installed/systems/yason.txt b/sbcl/.quicklisp/dists/quicklisp/installed/systems/yason.txt new file mode 100644 index 0000000..dd3ba86 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/installed/systems/yason.txt @@ -0,0 +1 @@ +dists/quicklisp/software/yason-v0.7.8/yason.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/preference.txt b/sbcl/.quicklisp/dists/quicklisp/preference.txt new file mode 100644 index 0000000..ca57830 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/preference.txt @@ -0,0 +1 @@ +3788524139 \ No newline at end of file diff --git a/sbcl/.quicklisp/dists/quicklisp/releases.cdb b/sbcl/.quicklisp/dists/quicklisp/releases.cdb new file mode 100644 index 0000000..1cafa2a Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/releases.cdb differ diff --git a/sbcl/.quicklisp/dists/quicklisp/releases.txt b/sbcl/.quicklisp/dists/quicklisp/releases.txt new file mode 100644 index 0000000..fa290a3 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/releases.txt @@ -0,0 +1,1831 @@ +# project url size file-md5 content-sha1 prefix [system-file1..system-fileN] +1am http://beta.quicklisp.org/archive/1am/2014-11-06/1am-20141106-git.tgz 3490 c5e83c329157518e3ebfeef63e4ac269 83dfee1159cc630cc2453681a7caaf745f987d41 1am-20141106-git 1am.asd +3b-bmfont http://beta.quicklisp.org/archive/3b-bmfont/2019-12-27/3b-bmfont-20191227-git.tgz 7982 86d51f81bfe1ce12cbbd6387105bc0f6 be1523d1f02ca7fce9fbd4b91c879d8bd3e68d8b 3b-bmfont-20191227-git 3b-bmfont.asd +3b-swf http://beta.quicklisp.org/archive/3b-swf/2012-01-07/3b-swf-20120107-git.tgz 75453 c130b35b44de03caa7cdf043d9d27dee 2dc75635c4d6a641618a63e61a9aa98252bbd2b7 3b-swf-20120107-git 3b-swf-swc.asd 3b-swf.asd +3bgl-shader http://beta.quicklisp.org/archive/3bgl-shader/2018-02-28/3bgl-shader-20180228-git.tgz 96057 fbd3727d73a99fc11116d13330b4e1a9 bbee1ba646c170f11a97829e1d3477990075bc1c 3bgl-shader-20180228-git 3bgl-shader-example.asd 3bgl-shader.asd +3bmd http://beta.quicklisp.org/archive/3bmd/2017-10-19/3bmd-20171019-git.tgz 22819 d691962a511f2edc15f4fc228ecdf546 054c8be1629c24d5658cdb57aa858e08919a955b 3bmd-20171019-git 3bmd-ext-code-blocks.asd 3bmd-ext-definition-lists.asd 3bmd-ext-tables.asd 3bmd-ext-wiki-links.asd 3bmd-youtube-tests.asd 3bmd-youtube.asd 3bmd.asd +3bz http://beta.quicklisp.org/archive/3bz/2019-10-07/3bz-20191007-git.tgz 30098 269233dd30c2203672739352bca94461 738b9a01b481ce80cdd75d5b44e0735e9d6f3517 3bz-20191007-git 3bz.asd +3d-matrices http://beta.quicklisp.org/archive/3d-matrices/2019-10-07/3d-matrices-20191007-git.tgz 41071 f1c646a034348281b8d05aed3c1ee153 ca19e0105d6c8d2614c2d0cbb487492c9aa077f9 3d-matrices-20191007-git 3d-matrices-test.asd 3d-matrices.asd +3d-vectors http://beta.quicklisp.org/archive/3d-vectors/2019-07-10/3d-vectors-20190710-git.tgz 27831 a5cf6cf3b78cba6ec36585bc6acbde61 b4cd1b5bfe087dc6ad95671fc74242905d6b22e5 3d-vectors-20190710-git 3d-vectors-test.asd 3d-vectors.asd +a-cl-logger http://beta.quicklisp.org/archive/a-cl-logger/2018-08-31/a-cl-logger-20180831-git.tgz 18415 27b4f20b1b3d779319df4f2da5e6740e 03171fd4aa730f0d692fa54c922d2ffb16558da3 a-cl-logger-20180831-git a-cl-logger-logstash.asd a-cl-logger.asd +able http://beta.quicklisp.org/archive/able/2017-12-27/able-20171227-git.tgz 30476 bf42d58fb2f32f239e9f98561fb11be1 3d1693e9704ba4fcd19a151baf16e3600447d83b able-20171227-git able.asd +access http://beta.quicklisp.org/archive/access/2015-12-18/access-20151218-git.tgz 14821 a6f1eb4a1823b04c6db4fa2dc16d648f f8cf34ea96902db935db8c183e7c09c2fc2c8c90 access-20151218-git access.asd +acclimation http://beta.quicklisp.org/archive/acclimation/2018-08-31/acclimation-20180831-git.tgz 5069 71fa994f03a01452e0a15d27c61f5d55 3488315089e411ebe6347e4acc6ff062667a91ed acclimation-20180831-git Temperature/acclimation-temperature.asd acclimation.asd +adopt http://beta.quicklisp.org/archive/adopt/2019-12-27/adopt-20191227-hg.tgz 22054 c5ae8be1ffe8c9f37be9e9fb60196859 b54e9303f9b8f6d9bb3a9437aa29a67832bdda73 adopt-20191227-hg adopt.asd +advanced-readtable http://beta.quicklisp.org/archive/advanced-readtable/2013-07-20/advanced-readtable-20130720-git.tgz 10570 bcb3c8a4757047bf7a41117265b74a3f 163baeafd28c4f4cb0c3fb42529df5ee75a711cc advanced-readtable-20130720-git advanced-readtable.asd +adw-charting http://beta.quicklisp.org/archive/adw-charting/2012-09-09/adw-charting-20120909-http.tgz 291857 932a2a8f87a6a26b8aece05240850451 7a7e66124521f356ff6b6b9653f8b190b827b7e1 adw-charting-20120909-http adw-charting-google.asd adw-charting-vecto.asd adw-charting.asd +agnostic-lizard http://beta.quicklisp.org/archive/agnostic-lizard/2019-03-07/agnostic-lizard-20190307-git.tgz 32336 b9fdba47c8bdb8071c824dbc4067f7bb 83be3235a297e14470fe2815edf191c221368990 agnostic-lizard-20190307-git agnostic-lizard-debugger-prototype.asd agnostic-lizard.asd +agutil http://beta.quicklisp.org/archive/agutil/2019-02-02/agutil-20190202-git.tgz 6480 87f78ed77eaddc8877b44af4a6151e2e 36e70c15d9938571501ba9da145a4c2aa95272b5 agutil-20190202-git agutil.asd +ahungry-fleece http://beta.quicklisp.org/archive/ahungry-fleece/2018-08-31/ahungry-fleece-20180831-git.tgz 94922 cf283b8fddaae5430703413bd22a8841 ed6c9c7e8def3ef93b16670c73dadc770beff94f ahungry-fleece-20180831-git ahungry-fleece.asd skel/skeleton.asd +alexa http://beta.quicklisp.org/archive/alexa/2018-08-31/alexa-20180831-git.tgz 11101 322aae1831d32c65e4f7512a749e5794 d27375e85ec943d49b3fcb77b3ab606b2dd63e92 alexa-20180831-git alexa-tests.asd alexa.asd +alexandria http://beta.quicklisp.org/archive/alexandria/2019-12-27/alexandria-20191227-git.tgz 53842 634105318a9c82a2a2729d0305c91667 3df48554c447086fe060dbbca21943dcbe7b82db alexandria-20191227-git alexandria-tests.asd alexandria.asd +algebraic-data-library http://beta.quicklisp.org/archive/algebraic-data-library/2018-08-31/algebraic-data-library-20180831-git.tgz 2657 4e0c9d6480ef5824821e38ef88ce7c0f 35e8cb9da56cd9b6f4bc6bbd9b6e7094f28e367a algebraic-data-library-20180831-git algebraic-data-library.asd +also-alsa http://beta.quicklisp.org/archive/also-alsa/2019-08-13/also-alsa-20190813-git.tgz 12973 0c4ae0cbe5abfcdcaf2cd448e9be85db 77fa84942c50e825d52643b03548d5d2c6e8d042 also-alsa-20190813-git also-alsa.asd +amazon-ecs http://beta.quicklisp.org/archive/amazon-ecs/2011-04-18/amazon-ecs-20110418-git.tgz 18915 6fdd5ad095bd4a492e0d5cd07b7fae98 f8aa169d0a8e927a8357b210570f72d0198d630d amazon-ecs-20110418-git amazon-ecs.asd +anaphora http://beta.quicklisp.org/archive/anaphora/2019-10-07/anaphora-20191007-git.tgz 6114 bfaae44cfb6226f35f0afde335e51ca4 88e839f9edff0b74502c7595df3122a434401268 anaphora-20191007-git anaphora.asd +anaphoric-variants http://beta.quicklisp.org/archive/anaphoric-variants/2012-10-13/anaphoric-variants-1.0.1.tgz 3961 1958c6eed506b8dd7f7ebf4fb85142ed affec75bb8b78489722f937336342d2e003695db anaphoric-variants-1.0.1 anaphoric-variants.asd +antik http://beta.quicklisp.org/archive/antik/2019-10-08/antik-master-df14cb8c-git.tgz 1655490 1bfdd37b226dd77d2a83a8262c7f5c75 027e6a3fca896a523a6cd49cb6ae501605c6d953 antik-master-df14cb8c-git antik-base.asd antik.asd foreign-array.asd physical-dimension.asd science-data.asd +apply-argv http://beta.quicklisp.org/archive/apply-argv/2015-06-08/apply-argv-20150608-git.tgz 2451 d6c331fb609e14d8e99c2c5235767ae5 41176149bfe25382fbeee01eef0ca9aaca6aa6ec apply-argv-20150608-git apply-argv.asd +april http://beta.quicklisp.org/archive/april/2019-12-27/april-20191227-git.tgz 81594 6dbbfc4183b598deef9adb7f86b0dde0 21c472f95c9b4690786b296a8e189f08bccd1a40 april-20191227-git aplesque/aplesque.asd april.asd vex/vex.asd +arc-compat http://beta.quicklisp.org/archive/arc-compat/2018-08-31/arc-compat-20180831-git.tgz 69330 724b920b586c131d72e21b9c7438050c 4709ebe97f06bec4e489306df69bc6bf308aca8f arc-compat-20180831-git arc-compat.asd +architecture.builder-protocol http://beta.quicklisp.org/archive/architecture.builder-protocol/2019-05-21/architecture.builder-protocol-20190521-git.tgz 42621 5513a5432729ab4577400825d93d919c 1282644bcd48c2a9d30f53b2c1d0db53ec171d5b architecture.builder-protocol-20190521-git architecture.builder-protocol.asd architecture.builder-protocol.json.asd architecture.builder-protocol.universal-builder.asd architecture.builder-protocol.xpath.asd +architecture.hooks http://beta.quicklisp.org/archive/architecture.hooks/2018-12-10/architecture.hooks-20181210-git.tgz 15541 698bdb1309cae19fb8f0e1e425ba4cd9 c5d4bd17509ba19d55913a247ef56853d51a4169 architecture.hooks-20181210-git cl-hooks.asd +architecture.service-provider http://beta.quicklisp.org/archive/architecture.service-provider/2019-10-07/architecture.service-provider-20191007-git.tgz 22626 7260877f29b3fe3ad6e94126360f0bd3 9ae3133023dfc49a6e891ce2a3d1eefdc25c0513 architecture.service-provider-20191007-git architecture.service-provider-and-hooks.asd architecture.service-provider.asd +archive http://beta.quicklisp.org/archive/archive/2016-03-18/archive-20160318-git.tgz 19507 5332faf00d7b8416c0468770fa9aaf1f 83bcf90b745c5d8967086741072f3b7496733868 archive-20160318-git archive.asd +arnesi http://beta.quicklisp.org/archive/arnesi/2017-04-03/arnesi-20170403-git.tgz 84553 bbb34e1a646b2cc489766690c741d964 c83ef816a3596038ebc507611c2c17bb822a1024 arnesi-20170403-git arnesi.asd +array-operations http://beta.quicklisp.org/archive/array-operations/2019-07-10/array-operations-20190710-git.tgz 26278 42291d895198108ea4a39c195a92b4fb faa7ed1c5d9d9b2f9f1beef7db4deb8060297dda array-operations-20190710-git array-operations.asd +array-utils http://beta.quicklisp.org/archive/array-utils/2019-07-10/array-utils-20190710-git.tgz 5723 58c39c2ba3d2c8cd8a695fb867b72c33 5bc7a920472f8e254062a993d720b3d1ae4642fe array-utils-20190710-git array-utils-test.asd array-utils.asd +arrival http://beta.quicklisp.org/archive/arrival/2019-05-21/arrival-20190521-git.tgz 204257 9bc7b64b7b838feb61a99fd9241d8b7e bafc2300f7fcb8c4d7574da9825658468bee8480 arrival-20190521-git arrival.asd +arrow-macros http://beta.quicklisp.org/archive/arrow-macros/2016-09-29/arrow-macros-20160929-git.tgz 4832 0545674913ad39b66989b2a6318c69df 0618dfc6a77bdb78065a9f52e19e2af7e49df5e0 arrow-macros-20160929-git arrow-macros-test.asd arrow-macros.asd +arrows http://beta.quicklisp.org/archive/arrows/2018-10-18/arrows-20181018-git.tgz 5067 c60b5d79680de19baad018a0fe87bc48 82ebf99cf60c78e451f73e515b418f7c2f40b18b arrows-20181018-git arrows.asd +asd-generator http://beta.quicklisp.org/archive/asd-generator/2019-01-07/asd-generator-20190107-git.tgz 17944 3d89b79133f9d2e7bff3e7735a299f96 b9e465de3e179e7a7c0b73aa62be878777b014ea asd-generator-20190107-git asd-generator.asd test/asd-generator-test.asd +asdf-dependency-grovel http://beta.quicklisp.org/archive/asdf-dependency-grovel/2017-04-03/asdf-dependency-grovel-20170403-git.tgz 41965 e5f32a1e82dd83fa6446c28c2e43a73d ecfb684ceed8f4a95d124aa4f5398ec35a2dc5e2 asdf-dependency-grovel-20170403-git asdf-dependency-grovel.asd tests/test-serial-system.asd +asdf-encodings http://beta.quicklisp.org/archive/asdf-encodings/2019-10-07/asdf-encodings-20191007-git.tgz 9259 76bd0a61aa4df19e683d16592e0e62cd e3a8f15e4b8e4c4b39d4bcbbb67c6e7c308cf3d1 asdf-encodings-20191007-git asdf-encodings.asd +asdf-finalizers http://beta.quicklisp.org/archive/asdf-finalizers/2017-04-03/asdf-finalizers-20170403-git.tgz 6663 a9e3c960e6b6fdbd69640b520ef8044b 3838733d2c72f1dfc49fd2adb186f490d9f4601a asdf-finalizers-20170403-git asdf-finalizers-test.asd asdf-finalizers.asd list-of.asd +asdf-flv http://beta.quicklisp.org/archive/asdf-flv/2016-04-21/asdf-flv-version-2.1.tgz 2116 2b74b721b7e5335d2230d6b95fc6be56 7f61773346be3e61c241d597d02a3ec533d15989 asdf-flv-version-2.1 net.didierverna.asdf-flv.asd +asdf-linguist http://beta.quicklisp.org/archive/asdf-linguist/2015-09-23/asdf-linguist-20150923-git.tgz 4653 110db875b9d5cbdbc41fff8b50cc6688 b5929afb75c89ab6729d90da79686bc0885d7b55 asdf-linguist-20150923-git asdf-linguist.asd +asdf-manager http://beta.quicklisp.org/archive/asdf-manager/2016-02-08/asdf-manager-20160208-git.tgz 3156 67452d33f1e027b145ca8bfd0fa2806c eda6b453d5d3481e2d4e164c3206ae84012e7edd asdf-manager-20160208-git asdf-manager-test.asd asdf-manager.asd +asdf-package-system http://beta.quicklisp.org/archive/asdf-package-system/2015-06-08/asdf-package-system-20150608-git.tgz 1383 9eee9d811aec4894843ac1d8ae6cbccd 910495edcf74671f08ba09181539bf644e0cbb3f asdf-package-system-20150608-git asdf-package-system.asd +asdf-system-connections http://beta.quicklisp.org/archive/asdf-system-connections/2017-01-24/asdf-system-connections-20170124-git.tgz 4933 23bdbb69c433568e3e15ed705b803992 c49a358d1e61207c282e985905eae1810205fc2b asdf-system-connections-20170124-git asdf-system-connections.asd +asdf-viz http://beta.quicklisp.org/archive/asdf-viz/2019-05-21/asdf-viz-20190521-git.tgz 4138601 d979610cccb9ff58b71d99b01aaaca8b 8ce5cfd76d8031d15055a2e8390d0ac97abffa67 asdf-viz-20190521-git asdf-viz.asd +aserve http://beta.quicklisp.org/archive/aserve/2018-12-10/aserve-20181210-git.tgz 524530 4f5ddf1dcb415a1dc18a280bff91334b 8c71220d450d52b271ae7c3875eba2f37dbd80db aserve-20181210-git zaserve.asd +assert-p http://beta.quicklisp.org/archive/assert-p/2019-12-27/assert-p-20191227-git.tgz 17261 4d729e645c2a4a65aaa2eacd7602c044 f9324004ac2a29a9f217563b3fe992eff57be600 assert-p-20191227-git assert-p.asd +assertion-error http://beta.quicklisp.org/archive/assertion-error/2019-12-27/assertion-error-20191227-git.tgz 14185 797ad3c5cad14fb25eec76ccfb79b66a d9aff6bf141a59631d4371eace22a865bd29b0e6 assertion-error-20191227-git assertion-error.asd +assoc-utils http://beta.quicklisp.org/archive/assoc-utils/2018-10-18/assoc-utils-20181018-git.tgz 3516 cb9f306c3d4fac34bcf58fdd1a45eb6f 3210b7eb3a287e0307777340517b73093bca1752 assoc-utils-20181018-git assoc-utils-test.asd assoc-utils.asd +asteroids http://beta.quicklisp.org/archive/asteroids/2019-10-07/asteroids-20191007-git.tgz 3522066 e6956f404d402140e6573e24d849fc7d 89a44fb3225d6525e4bd26d20992a10ae2a0917a asteroids-20191007-git asteroids.asd +async-process http://beta.quicklisp.org/archive/async-process/2019-11-30/async-process-20191130-git.tgz 204948 a5dc34d24a41128f6342446e6348e791 18ec6b174dc9e249c7295a315233192a3cc37eec async-process-20191130-git src/async-process.asd +atdoc http://beta.quicklisp.org/archive/atdoc/2012-03-05/atdoc-20120305-git.tgz 36850 e9c40fd27b136fd9db0d0f13dc7d51a7 e60e3ca611b8eb9ff908091482932c14a119066a atdoc-20120305-git atdoc.asd example/blocks-world.asd +atomics http://beta.quicklisp.org/archive/atomics/2019-10-07/atomics-20191007-git.tgz 7007 722ec3bce23a990b37a5ccfe28da725a dabf84714ae2eed3598d6efe390c124e1b8c9791 atomics-20191007-git atomics-test.asd atomics.asd +authenticated-encryption http://beta.quicklisp.org/archive/authenticated-encryption/2018-10-18/authenticated-encryption-20181018-git.tgz 3639 02feacbc3a7b22144c368c498d5c4376 e966e0e3779ca5769c995cf4dc16e241c708a37f authenticated-encryption-20181018-git authenticated-encryption-test.asd authenticated-encryption.asd +avatar-api http://beta.quicklisp.org/archive/avatar-api/2015-06-08/avatar-api-20150608-git.tgz 2129 52a2e667536e10f80124ae2436f5d9a6 9fda0ec095f9fbdb8073605703d792a0eb3e8398 avatar-api-20150608-git avatar-api-test.asd avatar-api.asd +aws-foundation http://beta.quicklisp.org/archive/aws-foundation/2018-07-11/aws-foundation-20180711-git.tgz 4880 1cc177097ef8968147370f9970f04174 a973090f169db7cbacba714b68499f442b084902 aws-foundation-20180711-git aws-foundation.asd +aws-sign4 http://beta.quicklisp.org/archive/aws-sign4/2019-07-10/aws-sign4-20190710-git.tgz 35619 6d4df76edbdc135eadf22d09450f9c3c 54a0e8742edbbd2be9740fb6b9f620fe12c64d92 aws-sign4-20190710-git aws-sign4.asd +ayah-captcha http://beta.quicklisp.org/archive/ayah-captcha/2018-02-28/ayah-captcha-20180228-git.tgz 4660 396998f1fc484ded0afe3209ff00a380 59257d29def50e9701cdef4d34f13242cc85db4b ayah-captcha-20180228-git ayah-captcha.asd demo/ayah-captcha-demo.asd +babel http://beta.quicklisp.org/archive/babel/2019-11-30/babel-20191130-git.tgz 271183 80087c99fe351d24e56bb279a62effeb 726d583c6b9f5ff7f5c1fccc10ce2105348b0405 babel-20191130-git babel-streams.asd babel-tests.asd babel.asd +base-blobs http://beta.quicklisp.org/archive/base-blobs/2018-07-11/base-blobs-stable-9d781d0e-git.tgz 2442960 8bc33597482b7c41dc961f7ca69e2aec 36ed71aab08457bf4452c4d70de23c4574383668 base-blobs-stable-9d781d0e-git base-blobs.asd +base64 http://beta.quicklisp.org/archive/base64/2018-10-18/base64-20181018-git.tgz 2014 e7d77c873d9111e6e0a6704422805b24 3d8e62f5d3313d09e1a9ecd8d66f25b24eb58e73 base64-20181018-git base64.asd +basic-binary-ipc http://beta.quicklisp.org/archive/basic-binary-ipc/2015-08-04/basic-binary-ipc-20150804-git.tgz 57492 800adaca3395dad2c379fb6d64a51b1c dbc53ed3a51db6ec3605366dfca6616efe79dbb6 basic-binary-ipc-20150804-git basic-binary-ipc-tests.asd basic-binary-ipc.asd +bdef http://beta.quicklisp.org/archive/bdef/2019-12-27/bdef-20191227-git.tgz 13288 d9ff843530ce32a539ba4c7273bed079 308a463a559f142d4afacd85b439633ad81ac76f bdef-20191227-git bdef.asd +beast http://beta.quicklisp.org/archive/beast/2019-12-27/beast-20191227-git.tgz 14403 2c7f63da4924d0436d38082a7b1787cd 50de9053276359660d73b742d39c29f6c9c2455c beast-20191227-git beast-test.asd beast.asd +beirc http://beta.quicklisp.org/archive/beirc/2015-05-05/beirc-20150505-git.tgz 27301 50b1ea2e799d918ee68ff607f2ed7c98 091f2c11d2b297704101697235a411841ceb23ad beirc-20150505-git beirc.asd +big-string http://beta.quicklisp.org/archive/big-string/2019-03-07/big-string-20190307-hg.tgz 3949 bdffed5d0ef77e065911aba09e1bdf8c 5489c493ce7ca3c482880797a0d80c9c84e91384 big-string-20190307-hg big-string.asd +bike http://beta.quicklisp.org/archive/bike/2019-10-07/bike-20191007-git.tgz 70596 4cb973b533ea10cb735a167f77e2ff7f 9b3226071cf82b50a349d501031b1a8908ac0e18 bike-20191007-git bike-examples.asd bike-internals.asd bike-tests.asd bike.asd +binary-io http://beta.quicklisp.org/archive/binary-io/2019-12-27/binary-io-20191227-git.tgz 8936 ba18c49eb1fb8ff286cac00f7d0009f8 4ab347c91ba4fd1a680a8f033b30d1e14fbf4f1e binary-io-20191227-git binary-io.asd +binary-types http://beta.quicklisp.org/archive/binary-types/2013-06-15/binary-types-20130615-git.tgz 21337 e26f69cddf40a07beb89d9066830c44a 2f1a13a9ef75be93d53cf55d7c4c07260a620c3e binary-types-20130615-git binary-types.asd +binascii http://beta.quicklisp.org/archive/binascii/2015-07-09/binascii-20150709-git.tgz 196802 23f4db8372bd521725dd78dd667c2be1 e02502e8146770e87fa5b6e461b7729ee1117ad2 binascii-20150709-git binascii.asd +binfix http://beta.quicklisp.org/archive/binfix/2019-08-13/binfix-20190813-git.tgz 103896 916f3d55cf63c374ff9afacf03f9e9cc b3848eabd74026fd5a24d290bff94cdacd7d6dd3 binfix-20190813-git binfix.asd +binomial-heap http://beta.quicklisp.org/archive/binomial-heap/2013-04-20/binomial-heap-20130420-git.tgz 6211 ca40cb01b88a3fe902cc4cc25fb2d242 81583c3945e9f392cb8943713ed18724f72296f2 binomial-heap-20130420-git binomial-heap.asd +binpack http://beta.quicklisp.org/archive/binpack/2019-07-10/binpack-20190710-git.tgz 4335 88c5ea5d36266243886fd6d92ed03c94 6716a0de1e6296ddafd615d56bf7799d30faa4c7 binpack-20190710-git binpack.asd +birch http://beta.quicklisp.org/archive/birch/2016-03-18/birch-20160318-git.tgz 20320 1ce06aa2cbcef122fcef36186955cbd4 7deb668bd53ed29ac66d33e598efedccfe5ae6e5 birch-20160318-git birch.asd birch.test.asd +bit-ops http://beta.quicklisp.org/archive/bit-ops/2018-02-28/bit-ops-20180228-git.tgz 7131 487abc6e8afc586eb96300931a43d7be 923abf5d89d48ea17333f812c9c4bc1ab3092d90 bit-ops-20180228-git bit-ops.asd bit-ops.test.asd +bit-smasher http://beta.quicklisp.org/archive/bit-smasher/2018-10-18/bit-smasher-20181018-git.tgz 8790 bbb6df9cffc70ad72fe3a5b06664a0bc 6a4942aee4a5d892bd3b89cd5f2684dea079e951 bit-smasher-20181018-git bit-smasher.asd +bitfield-schema http://beta.quicklisp.org/archive/bitfield-schema/2012-01-07/bitfield-schema-20120107-git.tgz 6659 fac865d5c6379fd8e4a8526b99ec0662 5b4bf17a55e13ed80e657a545b9ea1ca5ceb77ec bitfield-schema-20120107-git bitfield-schema.asd +bitio http://beta.quicklisp.org/archive/bitio/2017-10-23/bitio-20171023-git.tgz 19253 4f906c8f8928bd703b72eb2207fbb623 d70390717f22b95bdbab594c14f468d674809844 bitio-20171023-git bitio.asd +bk-tree http://beta.quicklisp.org/archive/bk-tree/2013-04-20/bk-tree-20130420-git.tgz 21425 5ae53564f2a64abdc1424a054f965485 e0690274745029d8135d91abcdb18598e60e2999 bk-tree-20130420-git bk-tree.asd +bknr-datastore http://beta.quicklisp.org/archive/bknr-datastore/2019-12-27/bknr-datastore-20191227-git.tgz 630259 48d376b77c3e4bf912d25e7606f96bc1 b31c08ff484786b46311c972c2cc02ee9cc71ec1 bknr-datastore-20191227-git src/bknr.data.impex.asd src/bknr.datastore.asd src/bknr.impex.asd src/bknr.indices.asd src/bknr.skip-list.asd src/bknr.utils.asd src/bknr.xml.asd +bknr-web http://beta.quicklisp.org/archive/bknr-web/2014-07-13/bknr-web-20140713-git.tgz 172044 e867c9d79b03ea02d3e8af6d5d4a1fd7 80c17f624bf44065d7992880117d8a2373cf6744 bknr-web-20140713-git modules/bknr.modules.asd modules/spider/leech.asd src/bknr.web.asd src/html-match/html-match.asd +black-tie http://beta.quicklisp.org/archive/black-tie/2019-08-13/black-tie-20190813-git.tgz 13657 c6384b61495e45e737b0a4c8befe02c1 ceb8f687a25fe99e90bb8c7619820a7c2a8fb7e1 black-tie-20190813-git black-tie.asd +blackbird http://beta.quicklisp.org/archive/blackbird/2016-05-31/blackbird-20160531-git.tgz 12865 5cb13dc06a0eae8dcba14714d2b5365d 956c28da3fa238c46a3c52bcfc15afa415af452b blackbird-20160531-git blackbird-test.asd blackbird.asd +bobbin http://beta.quicklisp.org/archive/bobbin/2019-12-27/bobbin-20191227-hg.tgz 6090 1375f0163d0143291610a6591c7045dc 78bd651ef3eda07422453447881f91873bae548a bobbin-20191227-hg bobbin.asd +bodge-blobs-support http://beta.quicklisp.org/archive/bodge-blobs-support/2018-07-11/bodge-blobs-support-stable-8c77e4af-git.tgz 2287 9bdcf48ab4ab9f403838cd059b9affaa f44ce99cff4fbfc8362b59098847185bb884cce3 bodge-blobs-support-stable-8c77e4af-git bodge-blobs-support.asd +bodge-chipmunk http://beta.quicklisp.org/archive/bodge-chipmunk/2019-10-08/bodge-chipmunk-stable-6370e76a-git.tgz 1252241 0e111d03004ccb45037cab97c96e9bf0 6d930f384a15c6aa5d8e194135c367f9a779dc9a bodge-chipmunk-stable-6370e76a-git bodge-chipmunk.asd +bodge-glad http://beta.quicklisp.org/archive/bodge-glad/2018-02-28/bodge-glad-stable-d488bef5-git.tgz 54298 e5672047f95295ce6ab1da8f1f98b4d0 1bd91fbe51194ceb31551b724626d37230831cc3 bodge-glad-stable-d488bef5-git bodge-glad.asd +bodge-glfw http://beta.quicklisp.org/archive/bodge-glfw/2019-10-08/bodge-glfw-stable-7519a922-git.tgz 511390 030b8f5e93f15e435c231daa1f59beed eea577b03d23779d483b5e82ca79612e5a2551ec bodge-glfw-stable-7519a922-git bodge-glfw.asd +bodge-nanovg http://beta.quicklisp.org/archive/bodge-nanovg/2019-10-08/bodge-nanovg-stable-90fd9f9d-git.tgz 2103878 197d1b793047b22c7ea6c25e7628e58d 24ea020872dd2507e284e46b0197f102f83b53a4 bodge-nanovg-stable-90fd9f9d-git bodge-nanovg.asd +bodge-nuklear http://beta.quicklisp.org/archive/bodge-nuklear/2019-10-08/bodge-nuklear-stable-16f52766-git.tgz 1867351 5a3230800bb5e1e50b25c981bbbcaa40 ce626e9ea26731e7c3fbfdc08fd6efb73daa6cf6 bodge-nuklear-stable-16f52766-git bodge-nuklear.asd +bodge-ode http://beta.quicklisp.org/archive/bodge-ode/2019-10-08/bodge-ode-stable-3a5fbcea-git.tgz 2343673 24d965361477cf314b4fa50f7d851edd 64b63a2426df1b0fcce1d98958bb78c76b5ccf53 bodge-ode-stable-3a5fbcea-git bodge-ode.asd +bodge-openal http://beta.quicklisp.org/archive/bodge-openal/2019-10-08/bodge-openal-stable-9dc6ea9c-git.tgz 956800 d8eb0bfaf88c75e94014aeb8c8ecee42 6287f84f6e9b32976f4d528a0359534701f0377b bodge-openal-stable-9dc6ea9c-git bodge-openal.asd +bodge-sndfile http://beta.quicklisp.org/archive/bodge-sndfile/2019-10-08/bodge-sndfile-stable-e57475a5-git.tgz 3099841 d2eb07bf885c7f2215cab2056a7bd0cd 7bbd1e3bb5afc3294d76e2b158c8a45214405ee3 bodge-sndfile-stable-e57475a5-git bodge-sndfile.asd +bordeaux-fft http://beta.quicklisp.org/archive/bordeaux-fft/2015-06-08/bordeaux-fft-20150608-http.tgz 13857 99bee7dc569e71f40783551c792295bd a0caf5c27a3c3734178472333279926177ffb23a bordeaux-fft-20150608-http bordeaux-fft.asd +bordeaux-threads http://beta.quicklisp.org/archive/bordeaux-threads/2019-11-30/bordeaux-threads-v0.8.7.tgz 21951 071b427dd047999ffe038a2ef848ac13 b947d6b5d66b895a715f6d60044ff6d3de8afcf3 bordeaux-threads-v0.8.7 bordeaux-threads.asd +bourbaki http://beta.quicklisp.org/archive/bourbaki/2011-01-10/bourbaki-20110110-http.tgz 133787 64d23b156e8cf295c76a144e6522749b c224635f433be2ab0e45fd2e0ec13c6d735751ab bourbaki-20110110-http bourbaki.asd +bp http://beta.quicklisp.org/archive/bp/2019-12-27/bp-20191227-git.tgz 37999 079f202bf3c7eb3f3dcd4f5ed31333bc a157e736ffd5f5b70e19001a89435d5a3c937553 bp-20191227-git bp.asd +bst http://beta.quicklisp.org/archive/bst/2019-07-10/bst-20190710-git.tgz 18426 52ed6faee1e8761e061cba6bbb73936c 7c5cf9987cc1340a4241ef941c5ed473b4e72e3c bst-20190710-git bst.asd +bt-semaphore http://beta.quicklisp.org/archive/bt-semaphore/2018-07-11/bt-semaphore-20180711-git.tgz 4185 f70c869eaf18e277056a16eb3a21fd4a 23d9c3966166a46e5c42bbdacab7a2f684bfcd0c bt-semaphore-20180711-git bt-semaphore-test.asd bt-semaphore.asd +btrie http://beta.quicklisp.org/archive/btrie/2014-07-13/btrie-20140713-git.tgz 6389 1fdf3a46133861b59f7a1063f5fe6696 9d9e506112d4b87225944df068090c68d4b2c563 btrie-20140713-git btrie.asd +bubble-operator-upwards http://beta.quicklisp.org/archive/bubble-operator-upwards/2012-11-25/bubble-operator-upwards-1.0.tgz 2943 390c6f1aad23154fc613a1941ab0ee90 e5c62a9e32928fc4e4d38f9949acd9b30b0a7187 bubble-operator-upwards-1.0 bubble-operator-upwards.asd +buildapp http://beta.quicklisp.org/archive/buildapp/2015-12-18/buildapp-1.5.6.tgz 16389 b6c1450b19370d7e4ac21bf565b62c89 33832bc72acbd9b3c4a097b054bd0de1921b873a buildapp-1.5.6 buildapp.asd +buildnode http://beta.quicklisp.org/archive/buildnode/2017-04-03/buildnode-20170403-git.tgz 66725 b917f0d6c20489febbef0d5b954c350d dfe5d7aec7c73eb6797069f1d5b7fdc2d60fb610 buildnode-20170403-git buildnode-excel.asd buildnode-html5.asd buildnode-kml.asd buildnode-xhtml.asd buildnode-xul.asd buildnode.asd +burgled-batteries http://beta.quicklisp.org/archive/burgled-batteries/2016-08-25/burgled-batteries-20160825-git.tgz 42019 d20613a907e062fd32128fe25aead746 3124f87459f2bf2ad793179593df364aa383c3b1 burgled-batteries-20160825-git burgled-batteries-tests.asd burgled-batteries.asd +burgled-batteries.syntax http://beta.quicklisp.org/archive/burgled-batteries.syntax/2016-03-18/burgled-batteries.syntax-20160318-git.tgz 8126 ffdbbba14dbf3205ba0fe9ac6fae0bb0 b2801c136e8ecf705eb05c3f39e882eb56c706bb burgled-batteries.syntax-20160318-git burgled-batteries.syntax-test.asd burgled-batteries.syntax.asd +bytecurry.asdf-ext http://beta.quicklisp.org/archive/bytecurry.asdf-ext/2015-05-05/bytecurry.asdf-ext-20150505-git.tgz 2750 9fb33756e2edcb3ab0074dd8c32b73e4 32af33d3211f1d3aa8cb3a32d125ee5e49ae4236 bytecurry.asdf-ext-20150505-git bytecurry.asdf-ext.asd +bytecurry.mocks http://beta.quicklisp.org/archive/bytecurry.mocks/2015-05-05/bytecurry.mocks-20150505-git.tgz 4281 fa669aeb93a4beeb2457b3d30718adf2 648c6215a6c87842c35f9d9db578b71a7bcd2536 bytecurry.mocks-20150505-git bytecurry.mocks.asd +cacau http://beta.quicklisp.org/archive/cacau/2019-12-27/cacau-20191227-git.tgz 316777 b02aec6139693a06b09972690c6c20bb 9268f540d65c3439ff4fd186f2d22b539613010c cacau-20191227-git cacau-asdf.asd cacau-test.asd cacau.asd examples/asdf-intregration/cacau-examples-asdf-integration-test.asd examples/asdf-intregration/cacau-examples-asdf-integration.asd +cacle http://beta.quicklisp.org/archive/cacle/2019-05-21/cacle-20190521-git.tgz 16699 8ea845a295a43d0794dc43c22d36ec2c edfe4bf4dc852fac85daf536ae908816aa269d28 cacle-20190521-git cacle.asd +calispel http://beta.quicklisp.org/archive/calispel/2017-08-30/calispel-20170830-git.tgz 28640 1fba6e4b2055f5d1f0a78387e29552b1 1035e7249ad45cc5fb7aa5d6e362b0a80fefb7b8 calispel-20170830-git calispel.asd +cambl http://beta.quicklisp.org/archive/cambl/2018-12-10/cambl-20181210-git.tgz 45991 e5857aaf953cfdb3ebb1c4c49a02e92c 8d9ad22f71869a88fa184ae7e2510e73ff7c669e cambl-20181210-git cambl-test.asd cambl.asd fprog.asd +can http://beta.quicklisp.org/archive/can/2018-03-28/can-20180328-git.tgz 2565 6ef0d28d5aa6bc2936078cc116b70f39 0e6ad110295f63dba70e4f4d5f467734c8b52e20 can-20180328-git can-test.asd can.asd +caramel http://beta.quicklisp.org/archive/caramel/2013-04-20/caramel-20130420-git.tgz 4745 b6e6020c467971a5118dd7dba8276270 5d89e63be813fb25e31975f4d42db250aa2aecb2 caramel-20130420-git caramel.asd +cardiogram http://beta.quicklisp.org/archive/cardiogram/2019-08-13/cardiogram-20190813-git.tgz 9994 ebf310b3df23d141ccfaf09abd264bee 939ff797658ae8ab074cb73d4de03bc75d46b305 cardiogram-20190813-git cardiogram.asd +cari3s http://beta.quicklisp.org/archive/cari3s/2019-07-10/cari3s-20190710-git.tgz 25064 f6b7bad1691bd59f46c9e2128ce18faa 473ce6a22fb69dd67c617d9d3c15eb6c5690d634 cari3s-20190710-git cari3s.asd +carrier http://beta.quicklisp.org/archive/carrier/2018-12-10/carrier-20181210-git.tgz 3881 f831e7a8f590a9c634eaacdc8f145fe5 d2f6c847ae390bf95b2b392f562fbe17e6530563 carrier-20181210-git carrier.asd +cartesian-product-switch http://beta.quicklisp.org/archive/cartesian-product-switch/2012-09-09/cartesian-product-switch-2.0.tgz 4502 0f48da4205f8cd3b201eae1e07131fcd 82200c07f66d5d80ebeb62388108699e03e27f49 cartesian-product-switch-2.0 cartesian-product-switch.asd +caveman http://beta.quicklisp.org/archive/caveman/2019-08-13/caveman-20190813-git.tgz 29873 09d7223fd528757eaf1285dd99105ed6 63f6dd0215e1d5dc7321ee12e2c52edb31fe674c caveman-20190813-git caveman-middleware-dbimanager.asd caveman-test.asd caveman.asd caveman2-db.asd caveman2-test.asd caveman2.asd +caveman2-widgets http://beta.quicklisp.org/archive/caveman2-widgets/2018-02-28/caveman2-widgets-20180228-git.tgz 115350 960ba92d1ac86f49ce553bffd7136b25 446246d6fb1f1a2891175b7e88f45704fa72c728 caveman2-widgets-20180228-git caveman2-widgets-test.asd caveman2-widgets.asd +caveman2-widgets-bootstrap http://beta.quicklisp.org/archive/caveman2-widgets-bootstrap/2018-02-28/caveman2-widgets-bootstrap-20180228-git.tgz 4962 b6fc04d5468c9b3d6a502024eaaa8750 7ce56c2e7c5eb75f32208c90695e44a3006c10be caveman2-widgets-bootstrap-20180228-git caveman2-widgets-bootstrap-test.asd caveman2-widgets-bootstrap.asd +ccl-compat http://beta.quicklisp.org/archive/ccl-compat/2017-11-30/ccl-compat-20171130-git.tgz 7068 3229bd0be4ffa2a90e882433253a0100 fc117e973fdd6c08994c81baf99e5cc025877654 ccl-compat-20171130-git ccl-compat.asd +ccldoc http://beta.quicklisp.org/archive/ccldoc/2018-01-31/ccldoc-20180131-git.tgz 46896 d35e98910bbb163d9e2e27d156b274f8 93b40acb846828ba4f51e19cf47feed6391a511f ccldoc-20180131-git source/ccldoc-libraries.asd source/ccldoc.asd +cells http://beta.quicklisp.org/archive/cells/2018-03-28/cells-20180328-git.tgz 20813259 c28d3bfb8ee51a0d8fae9c2357b6833a 49c5235fd154b630c785941523c910666b970a64 cells-20180328-git cells-test.asd cells.asd +cepl http://beta.quicklisp.org/archive/cepl/2019-10-07/cepl-release-quicklisp-635f3483-git.tgz 434389 900d85f9a403def693c93db2b8f147d0 baea38b63add26c6aee73e0658ebbe2d7453b3d3 cepl-release-quicklisp-635f3483-git cepl.asd cepl.build.asd +cepl.camera http://beta.quicklisp.org/archive/cepl.camera/2018-02-28/cepl.camera-release-quicklisp-1292212a-git.tgz 3590 ea3319909269d1defe329ae8e126a314 6ef8df0aa73f50df2b63f462301c0bf9331d6007 cepl.camera-release-quicklisp-1292212a-git cepl.camera.asd +cepl.devil http://beta.quicklisp.org/archive/cepl.devil/2018-02-28/cepl.devil-release-quicklisp-ea5f8514-git.tgz 1930 3ca7236c320de5b217c7cd924bf8e063 6b6f880612fd28a8573cc6b4795bfa663131cf83 cepl.devil-release-quicklisp-ea5f8514-git cepl.devil.asd +cepl.drm-gbm http://beta.quicklisp.org/archive/cepl.drm-gbm/2019-05-21/cepl.drm-gbm-20190521-git.tgz 4081 1303fc696e495ec12e2ece9ee4dc6344 b74136275913799eaae407b967c32eac5baec46c cepl.drm-gbm-20190521-git cepl.drm-gbm.asd +cepl.glop http://beta.quicklisp.org/archive/cepl.glop/2018-02-28/cepl.glop-release-quicklisp-8ec09801-git.tgz 2915 33579536bbfc7037efe4ee830ecaed5f b72f80288063b5d214cf27257d1bcdf8b703878b cepl.glop-release-quicklisp-8ec09801-git cepl.glop.asd +cepl.sdl2 http://beta.quicklisp.org/archive/cepl.sdl2/2018-02-28/cepl.sdl2-release-quicklisp-6da5a030-git.tgz 4119 8e30fec5d59a4cf8f21525d1cdb9f7d3 61e4d1868d907fc092236d7f6ad8b36b685b181c cepl.sdl2-release-quicklisp-6da5a030-git cepl.sdl2.asd +cepl.sdl2-image http://beta.quicklisp.org/archive/cepl.sdl2-image/2018-02-28/cepl.sdl2-image-release-quicklisp-94a77649-git.tgz 2449 7e83fbc6868c8a13579dd590377c15fa c784ddba948e3260da76df22b18b7cc41fba7fda cepl.sdl2-image-release-quicklisp-94a77649-git cepl.sdl2-image.asd +cepl.sdl2-ttf http://beta.quicklisp.org/archive/cepl.sdl2-ttf/2018-01-31/cepl.sdl2-ttf-release-quicklisp-11b498a3-git.tgz 2404 d5e31a84c08ec2bf453a0a9cf00fa4e9 7c4640f10b7220bee04db63eef4cbf6ecae2f757 cepl.sdl2-ttf-release-quicklisp-11b498a3-git cepl.sdl2-ttf.asd +cepl.skitter http://beta.quicklisp.org/archive/cepl.skitter/2018-02-28/cepl.skitter-release-quicklisp-f52b9240-git.tgz 1755 64a97da55e6074842428311cafc99bed 63f431bc9eaa088c5c77dda2f4d983c9aa17bfdb cepl.skitter-release-quicklisp-f52b9240-git cepl.skitter.glop.asd cepl.skitter.sdl2.asd +cepl.spaces http://beta.quicklisp.org/archive/cepl.spaces/2018-03-28/cepl.spaces-release-quicklisp-c7f83f26-git.tgz 24762 53d77882ea7a52043103f436138b5496 765133bddb709078ff096c43c9ff4d98cf8fabe2 cepl.spaces-release-quicklisp-c7f83f26-git cepl.spaces.asd +ceramic http://beta.quicklisp.org/archive/ceramic/2019-11-30/ceramic-20191130-git.tgz 86783 fe8e29a2f02e11260e50449dc17d9a2d 79c7d3bfc3315beb09afa2f9fcc36f08f54e0af8 ceramic-20191130-git ceramic.asd examples/hello-world/ceramic-hello-world.asd t/app/ceramic-test-app.asd +cerberus http://beta.quicklisp.org/archive/cerberus/2019-02-02/cerberus-20190202-git.tgz 3247973 993b538eb39bdc9fa976eb688f8aaf71 6aabeae31748df0b54550e00993e3b758b344581 cerberus-20190202-git cerberus.asd +cesdi http://beta.quicklisp.org/archive/cesdi/2019-08-13/cesdi_1.0.tgz 6241 3db5a8c77f7b5facf158ef91f2161d28 77436237165035312da19ea32641b3e2dfd57c58 cesdi_1.0 cesdi.asd tests/cesdi_tests.asd +cffi http://beta.quicklisp.org/archive/cffi/2019-07-10/cffi_0.20.1.tgz 260119 b8a8337465a7b4c1be05270b777ce14f 9f0940f1693b5d19ac354a426b218734d45fb6ef cffi_0.20.1 cffi-examples.asd cffi-grovel.asd cffi-libffi.asd cffi-tests.asd cffi-toolchain.asd cffi-uffi-compat.asd cffi.asd +chameleon http://beta.quicklisp.org/archive/chameleon/2019-11-30/chameleon-v1.1.0.tgz 4071 5d1819290c08797f2cd42cdeae0f4795 48012faabe08d783071117c747b80414550e3915 chameleon-v1.1.0 chameleon.asd +chancery http://beta.quicklisp.org/archive/chancery/2019-12-27/chancery-20191227-hg.tgz 15232 ac00423a87aa78b85a877eafa97056a8 c42e7495ac578efec42d4019cf306bd4d8e20e53 chancery-20191227-hg chancery.asd chancery.test.asd +changed-stream http://beta.quicklisp.org/archive/changed-stream/2013-01-28/changed-stream-20130128-git.tgz 233624 08dfb9234851b9bbe3d2b774efc809b6 153aecf366d19d2091f7e4c8a4aa22293cd0a66b changed-stream-20130128-git changed-stream.asd changed-stream.test.asd +chanl http://beta.quicklisp.org/archive/chanl/2019-11-30/chanl-20191130-git.tgz 27265 f3101f6d31943f48b2f963d9f4c54172 457163482b344b4976527d435e097451c65942aa chanl-20191130-git chanl.asd +cheat-js http://beta.quicklisp.org/archive/cheat-js/2012-10-13/cheat-js-20121013-git.tgz 27000 d23fc2a4dfd3a0ce8c7fb42c773feb2d 288b962ed29320e097d0bf871dcd0189aa5de94d cheat-js-20121013-git cheat-js.asd +check-it http://beta.quicklisp.org/archive/check-it/2015-07-09/check-it-20150709-git.tgz 19988 0baae55e5a9c8c884202cbc51e634c42 49933b16fc112096734546df0d91bb76bef3044e check-it-20150709-git check-it.asd +checkl http://beta.quicklisp.org/archive/checkl/2018-03-28/checkl-20180328-git.tgz 8294 a5050385e2ef2977ba2112ea88128535 aca1cf3498cb81a443772c0bc306b11e037d5dd6 checkl-20180328-git checkl-docs.asd checkl-test.asd checkl.asd +chemical-compounds http://beta.quicklisp.org/archive/chemical-compounds/2011-10-01/chemical-compounds-1.0.2.tgz 5119 05d45cf42a61e9dabab409d345b778c1 1fc077075d4b580f4b363a131f670bab602e8886 chemical-compounds-1.0.2 chemical-compounds.asd +chillax http://beta.quicklisp.org/archive/chillax/2015-03-02/chillax-20150302-git.tgz 207342 f173c34bb131fe6192f5c6c87bf1be7e 860cd942dd71757d22f1b81d24919e36cca850c5 chillax-20150302-git chillax.asd chillax.core.asd chillax.jsown.asd chillax.view-server.asd chillax.yason.asd +chipmunk-blob http://beta.quicklisp.org/archive/chipmunk-blob/2018-01-31/chipmunk-blob-stable-55c6bf5b-git.tgz 758650 179214dca154f48185307aa331e7318f 54b0bf182e9eaf483d9287cd8499f33d9ea49090 chipmunk-blob-stable-55c6bf5b-git chipmunk-blob.asd +chipz http://beta.quicklisp.org/archive/chipz/2019-02-02/chipz-20190202-git.tgz 37110 e3533408ca6899fe996eede390e820c7 b2a2321ae7eab3609bf20ffa01f7bddc307bf087 chipz-20190202-git chipz.asd +chirp http://beta.quicklisp.org/archive/chirp/2019-07-10/chirp-20190710-git.tgz 86852 f55281d67bea97ea0348500ae6713d70 a05e8372d96a09bf5a8676e286b35ea476ba200a chirp-20190710-git chirp-core.asd chirp-dexador.asd chirp-drakma.asd chirp.asd +chrome-native-messaging http://beta.quicklisp.org/archive/chrome-native-messaging/2015-03-02/chrome-native-messaging-20150302-git.tgz 1973 3fae36a2473eb7095d50f8472d31bd6c beeb53f51396f5fd05217c00b07306835a566943 chrome-native-messaging-20150302-git chrome-native-messaging.asd +chronicity http://beta.quicklisp.org/archive/chronicity/2019-02-02/chronicity-20190202-git.tgz 30517 43ca1a6e3f5f16f3c3fa8708aa6f8abb 8d561cd975aec6eceaabd245b8fc4e26f9450081 chronicity-20190202-git chronicity-test.asd chronicity.asd +chtml-matcher http://beta.quicklisp.org/archive/chtml-matcher/2011-10-01/chtml-matcher-20111001-git.tgz 9772 b78c982a080fa6264d0524f5aabb6440 c328ea450fd88170ce98235761bcd3973ce2fc1e chtml-matcher-20111001-git chtml-matcher.asd +chunga http://beta.quicklisp.org/archive/chunga/2018-01-31/chunga-20180131-git.tgz 20552 044b684535b11b1eee1cf939bec6e14a 674f398ede85b384db80b21d93d5a4fae335a982 chunga-20180131-git chunga.asd +ci-utils http://beta.quicklisp.org/archive/ci-utils/2019-12-27/ci-utils-20191227-git.tgz 16686 d0c3f9cc75bca68b50276a39a8a0a705 ce9949fcdb5a8e75c2c674e527ff649d39af0960 ci-utils-20191227-git ci-utils-features.asd ci-utils.asd +circular-streams http://beta.quicklisp.org/archive/circular-streams/2016-12-04/circular-streams-20161204-git.tgz 3335 2383f3b82fa3335d9106e1354a678db8 aaeec87552396bc112300d66e93905c546e2c0ec circular-streams-20161204-git circular-streams-test.asd circular-streams.asd +city-hash http://beta.quicklisp.org/archive/city-hash/2016-08-25/city-hash-20160825-git.tgz 31639 d6ea890c84c4745bbc435b97eaa0457d 76b2a1f9c2a3e1388b89f682c5d6d493e8f25e2c city-hash-20160825-git city-hash-test.asd city-hash.asd +cl+ssl http://beta.quicklisp.org/archive/cl+ssl/2019-11-30/cl+ssl-20191130-git.tgz 52704 995aaef02ec5112a0de78b2533691629 96dd6269d2044cbe4ee3cf3f3c2abd9b7fa17110 cl+ssl-20191130-git cl+ssl.asd cl+ssl.test.asd +cl-6502 http://beta.quicklisp.org/archive/cl-6502/2015-09-23/cl-6502-20150923-git.tgz 67684 b4396714cfa3693fd1f40d3464622304 f55e04108665aa220401d15ec2b08b8cf6739e35 cl-6502-20150923-git cl-6502.asd +cl-abnf http://beta.quicklisp.org/archive/cl-abnf/2019-05-21/cl-abnf-20190521-git.tgz 7966 59e6c617f7183ae62eb9626ae12d836f 8b6f0a0f9162ba4df5fea4046bc32b4e8108189c cl-abnf-20190521-git abnf.asd +cl-abstract-classes http://beta.quicklisp.org/archive/cl-abstract-classes/2019-03-07/cl-abstract-classes-20190307-hg.tgz 4719 9f70affac8015d8fc4e29f16c642890e 9c691e814b9e541e024751edd4e3e26c87082b0b cl-abstract-classes-20190307-hg abstract-classes.asd singleton-classes.asd +cl-acronyms http://beta.quicklisp.org/archive/cl-acronyms/2015-03-02/cl-acronyms-20150302-git.tgz 927131 99e7304da8f6408227323fdab76e07db 695aaa263b152453e6f8130afb6cfcea1165a463 cl-acronyms-20150302-git cl-acronyms.asd +cl-algebraic-data-type http://beta.quicklisp.org/archive/cl-algebraic-data-type/2019-10-07/cl-algebraic-data-type-20191007-git.tgz 7396 022de40e52b252919ea9c7f77ab90435 eec9f2941bcad980c2f76a5f94df20f1f920c87f cl-algebraic-data-type-20191007-git cl-algebraic-data-type.asd +cl-all http://beta.quicklisp.org/archive/cl-all/2019-07-10/cl-all-20190710-git.tgz 5429 7927a2782ba49b86ed0ce365841bbb70 b5c956f55bea28fa792c632e86bef7a6f65e7fc1 cl-all-20190710-git cl-all.asd +cl-amqp http://beta.quicklisp.org/archive/cl-amqp/2019-10-08/cl-amqp-v0.4.1.tgz 58162 1867a1d1ecdf4606ed8c50d583b1b876 92e5c46f853154df29fb8e8a1a62bbbf23b34332 cl-amqp-v0.4.1 cl-amqp.asd cl-amqp.test.asd +cl-ana http://beta.quicklisp.org/archive/cl-ana/2019-07-10/cl-ana-20190710-git.tgz 526237 a22444bc080a90f4ff3e2b08a1ad0595 036cf75968c23e91fbe6819a2a6ecf6c4a59387b cl-ana-20190710-git binary-tree/cl-ana.binary-tree.asd calculus/cl-ana.calculus.asd cl-ana.asd clos-utils/cl-ana.clos-utils.asd columnar-table/cl-ana.columnar-table.asd csv-table/cl-ana.csv-table.asd error-propogation/cl-ana.error-propogation.asd file-utils/cl-ana.file-utils.asd fitting/cl-ana.fitting.asd functional-utils/cl-ana.functional-utils.asd generic-math/cl-ana.generic-math.asd gnuplot-interface/cl-ana.gnuplot-interface.asd gsl-cffi/cl-ana.gsl-cffi.asd hash-table-utils/cl-ana.hash-table-utils.asd hdf-cffi/cl-ana.hdf-cffi.asd hdf-table/cl-ana.hdf-table.asd hdf-typespec/cl-ana.hdf-typespec.asd hdf-utils/cl-ana.hdf-utils.asd histogram/cl-ana.histogram.asd int-char/cl-ana.int-char.asd linear-algebra/cl-ana.linear-algebra.asd list-utils/cl-ana.list-utils.asd lorentz/cl-ana.lorentz.asd macro-utils/cl-ana.macro-utils.asd makeres-block/cl-ana.makeres-block.asd makeres-branch/cl-ana.makeres-branch.asd makeres-graphviz/cl-ana.makeres-graphviz.asd makeres-macro/cl-ana.makeres-macro.asd makeres-progress/cl-ana.makeres-progress.asd makeres-table/cl-ana.makeres-table.asd makeres-utils/cl-ana.makeres-utils.asd makeres/cl-ana.makeres.asd map/cl-ana.map.asd math-functions/cl-ana.math-functions.asd memoization/cl-ana.memoization.asd ntuple-table/cl-ana.ntuple-table.asd package-utils/cl-ana.package-utils.asd pathname-utils/cl-ana.pathname-utils.asd plotting/cl-ana.plotting.asd quantity/cl-ana.quantity.asd reusable-table/cl-ana.reusable-table.asd serialization/cl-ana.serialization.asd statistical-learning/cl-ana.statistical-learning.asd statistics/cl-ana.statistics.asd string-utils/cl-ana.string-utils.asd symbol-utils/cl-ana.symbol-utils.asd table-utils/cl-ana.table-utils.asd table-viewing/cl-ana.table-viewing.asd table/cl-ana.table.asd tensor/cl-ana.tensor.asd typed-table/cl-ana.typed-table.asd typespec/cl-ana.typespec.asd +cl-annot http://beta.quicklisp.org/archive/cl-annot/2015-06-08/cl-annot-20150608-git.tgz 10039 35d8f79311bda4dd86002d11edcd0a21 31e415954f5e033907cd5d88ee4735e4ed940f12 cl-annot-20150608-git cl-annot.asd +cl-annot-prove http://beta.quicklisp.org/archive/cl-annot-prove/2015-09-23/cl-annot-prove-20150923-git.tgz 9244 d7ee8d5c35f1aaa036b77bbd1092b77c 25a765cde6977c027de5adf3067647623e96ba05 cl-annot-prove-20150923-git cl-annot-prove-test.asd cl-annot-prove.asd +cl-anonfun http://beta.quicklisp.org/archive/cl-anonfun/2011-12-03/cl-anonfun-20111203-git.tgz 2163 915bda1a7653d42090f8d20a1ad85d0b a0a38ada878271e7bc8ebc9cb75a0bd7b5cc7aa5 cl-anonfun-20111203-git cl-anonfun.asd +cl-ansi-term http://beta.quicklisp.org/archive/cl-ansi-term/2018-02-28/cl-ansi-term-20180228-git.tgz 48226 abb6d07e957b16e6899144d27ee6019a 1f58dd2298e65b8e28d1a7acd0b16762e486032b cl-ansi-term-20180228-git cl-ansi-term.asd +cl-ansi-text http://beta.quicklisp.org/archive/cl-ansi-text/2015-08-04/cl-ansi-text-20150804-git.tgz 5876 70aa38b40377a5e89a7f22bb68b3f796 2de105750d54136d99a566bbf98d57c85088fb90 cl-ansi-text-20150804-git cl-ansi-text-test.asd cl-ansi-text.asd +cl-apple-plist http://beta.quicklisp.org/archive/cl-apple-plist/2011-11-05/cl-apple-plist-20111105-git.tgz 2720 95b6163c11c22fbb84c1f43c6703e612 b973e5c37b48d524c34b1ea2e8b89f636d69ad06 cl-apple-plist-20111105-git cl-apple-plist.asd +cl-arff-parser http://beta.quicklisp.org/archive/cl-arff-parser/2013-04-21/cl-arff-parser-20130421-git.tgz 4500 8ae977859eb11df65a1694b52436b0b5 d2342be9fa7b9a7aea26935b6268b7f556f7ff81 cl-arff-parser-20130421-git cl-arff-parser.asd +cl-argparse http://beta.quicklisp.org/archive/cl-argparse/2019-12-27/cl-argparse-20191227-git.tgz 6876 199e936fd0f8990d7fe264ef5d0c9101 becc75542c82a1d028a1d99cc74cec61448f2c78 cl-argparse-20191227-git src/cl-argparse.asd +cl-arrows http://beta.quicklisp.org/archive/cl-arrows/2016-03-18/cl-arrows-20160318-git.tgz 2072 3098c08f52480279d64bd1314e72d50c 91c9b1d1fb60d4e188647797785ace68d9bc4d5e cl-arrows-20160318-git cl-arrows.asd +cl-arxiv-api http://beta.quicklisp.org/archive/cl-arxiv-api/2017-04-03/cl-arxiv-api-20170403-git.tgz 9013 3537c564323f050ba434a8198e525455 7c066716a5453b08d60181849bfb302517009806 cl-arxiv-api-20170403-git cl-arxiv-api.asd +cl-ascii-art http://beta.quicklisp.org/archive/cl-ascii-art/2017-10-19/cl-ascii-art-20171019-git.tgz 2500481 cf7fe4d84658d5d65d899e5b2c2f88fe 1fce75ccdd44c7ff91be24c51e6d570f009ccd94 cl-ascii-art-20171019-git cl-ascii-art.asd +cl-ascii-table http://beta.quicklisp.org/archive/cl-ascii-table/2017-12-27/cl-ascii-table-20171227-git.tgz 3493 4a48649958049fd2a147ec6dcc2f4dea 83858d3fd90d9f3f41e7057bcdeefc583178d42a cl-ascii-table-20171227-git cl-ascii-table.asd +cl-association-rules http://beta.quicklisp.org/archive/cl-association-rules/2017-04-03/cl-association-rules-20170403-git.tgz 4370 641b30a4fcf913cf91acbe6aaf2cae1a cf2b99cd6350ac6eef1a1301b6f80d5d27d5e305 cl-association-rules-20170403-git cl-association-rules.asd +cl-async http://beta.quicklisp.org/archive/cl-async/2019-11-30/cl-async-20191130-git.tgz 56759 3850bc827b4c41b6047b962e3892bcb2 a958e4d8f40c64c4e0c2f0da80624af120bfb7cd cl-async-20191130-git cl-async-repl.asd cl-async-ssl.asd cl-async-test.asd cl-async.asd +cl-async-future http://beta.quicklisp.org/archive/cl-async-future/2015-01-13/cl-async-future-20150113-git.tgz 5719 961dbcb0bad3515ac7170f96dfd626ef 50751c2b573e0323f4c4687427df1d15b901cc38 cl-async-future-20150113-git cl-async-future.asd +cl-autorepo http://beta.quicklisp.org/archive/cl-autorepo/2018-07-11/cl-autorepo-20180711-git.tgz 2223 333fc8779ce41c4e87ed5bdae6a18047 93fa8ee37a34306d513fbdcdfef0b32b6e50723d cl-autorepo-20180711-git cl-autorepo.asd +cl-autowrap http://beta.quicklisp.org/archive/cl-autowrap/2019-05-21/cl-autowrap-20190521-git.tgz 76125 be601951cafd465e1445586a16024e0b b337ff6c7c98ded0be3c1b92853815a5fd38d23c cl-autowrap-20190521-git cl-autowrap-test.asd cl-autowrap.asd cl-plus-c.asd +cl-azure http://beta.quicklisp.org/archive/cl-azure/2016-08-25/cl-azure-20160825-git.tgz 16121 b85ed39bbbe3dc96b008dba7f7832365 e6bc24f54ee60ad9c51143995e36e9344f450b57 cl-azure-20160825-git cl-azure.asd +cl-base32 http://beta.quicklisp.org/archive/cl-base32/2013-04-20/cl-base32-20130420-git.tgz 3417 e5066e4e4947e6f9d4debcbb38c008b9 ae9f24b9a9f4055650d2cc5aafd986cd4251b19b cl-base32-20130420-git cl-base32.asd +cl-base58 http://beta.quicklisp.org/archive/cl-base58/2015-01-13/cl-base58-20150113-git.tgz 2327 18cbd835ced24e94b0eff6380d7ee088 114d203cecd45d09c54756b5042d493c31f37d51 cl-base58-20150113-git cl-base58-test.asd cl-base58.asd +cl-base64 http://beta.quicklisp.org/archive/cl-base64/2015-09-23/cl-base64-20150923-git.tgz 8589 560d0601eaa86901611f1484257b9a57 429e68ef554c75d437f2f109d670c28fd877bf0a cl-base64-20150923-git cl-base64.asd +cl-batis http://beta.quicklisp.org/archive/cl-batis/2019-01-07/cl-batis-20190107-git.tgz 9418 5dece883bcc69d11ed1f7e4a00b35671 a68412091d2bbbe32919dc0238ff3d504d5bacae cl-batis-20190107-git batis-test.asd batis.asd cl-batis.asd +cl-bayesnet http://beta.quicklisp.org/archive/cl-bayesnet/2013-04-20/cl-bayesnet-20130420-git.tgz 1176067 bfbc8a2a51d5b76c4c53993d2280d94f ff6228f63582e6f4a5665fb845bce62df365347a cl-bayesnet-20130420-git cl-bayesnet.asd +cl-beanstalk http://beta.quicklisp.org/archive/cl-beanstalk/2011-06-19/cl-beanstalk-20110619-git.tgz 8888 a0cc4fd21e978722d70185c8cb908053 657eca4550127ddf554db273999f89f5a4e1b7e7 cl-beanstalk-20110619-git cl-beanstalk.asd +cl-bencode http://beta.quicklisp.org/archive/cl-bencode/2018-02-28/cl-bencode-20180228-git.tgz 6343 4eaa85d018a4fbb35378c07c727bf585 0548331a29e838863d1f0573ca8c788647ea8196 cl-bencode-20180228-git bencode.asd +cl-bert http://beta.quicklisp.org/archive/cl-bert/2014-11-06/cl-bert-20141106-git.tgz 3107 146379540abc497d942ef89d33df9672 d7082e37cc22c2d99b2dba50f6cf8ea1060f85a9 cl-bert-20141106-git bert.asd +cl-bibtex http://beta.quicklisp.org/archive/cl-bibtex/2018-12-10/cl-bibtex-20181210-git.tgz 76724 83cf40c69b449a4b543538f67fdf69cd 05c1cf877743b2f32a2d8f87fc871858d9b403a5 cl-bibtex-20181210-git bibtex.asd +cl-bip39 http://beta.quicklisp.org/archive/cl-bip39/2018-07-11/cl-bip39-20180711-git.tgz 10742 a791287d7b55d8a813f3239016b321ea f24dffe751c80eaa3e0042545289be79c7447be2 cl-bip39-20180711-git cl-bip39.asd +cl-bloom http://beta.quicklisp.org/archive/cl-bloom/2018-02-28/cl-bloom-20180228-git.tgz 4302 89f0727b66223ccb6aeb294fc0cc011f ad6f0142aefcc1bfbeeec81e09627a2a74e78047 cl-bloom-20180228-git cl-bloom.asd +cl-bnf http://beta.quicklisp.org/archive/cl-bnf/2019-11-30/cl-bnf-20191130-git.tgz 5694 2a6d8add79f964ed0e4028dda0c3b3c0 8c26582251999166575d7d9d9fb379c8ae73f83b cl-bnf-20191130-git cl-bnf-examples.asd cl-bnf-tests.asd cl-bnf.asd +cl-bootstrap http://beta.quicklisp.org/archive/cl-bootstrap/2018-08-31/cl-bootstrap-20180831-git.tgz 161893 cee57823b000ebedbf0ca2a5bc745e8b 832338aec105f68f8982c4e6ecdc1209361ce3e8 cl-bootstrap-20180831-git cl-bootstrap-demo.asd cl-bootstrap-test.asd cl-bootstrap.asd +cl-bplustree http://beta.quicklisp.org/archive/cl-bplustree/2018-03-28/cl-bplustree-20180328-git.tgz 8921 e5a31bafa8e9e42a5da16d675b852697 84702c33e5625e787ea4df04d7d5c2cf82336bde cl-bplustree-20180328-git cl-bplustree.asd +cl-bson http://beta.quicklisp.org/archive/cl-bson/2017-04-03/cl-bson-20170403-git.tgz 35505 c9359beeeb67fde4566ca3fdcd2e7ba6 74baa529bd8c1038f4dc509baabba84f545f001f cl-bson-20170403-git cl-bson-test.asd cl-bson.asd +cl-buchberger http://beta.quicklisp.org/archive/cl-buchberger/2011-05-22/cl-buchberger-20110522-git.tgz 7989 8a993756267bd3eea16fdaaab023ad59 d0df1a56821d2187a97c578441b95980fbe92ec7 cl-buchberger-20110522-git cl-buchberger.asd +cl-bunny http://beta.quicklisp.org/archive/cl-bunny/2016-03-18/cl-bunny-0.4.5.tgz 44478 240ffda23fedfbb0b2cd1fcd51bb8a5d a02dfc2e897e1f9ffa2b6b3883bae1a3c7cc5f4e cl-bunny-0.4.5 cl-bunny.asd cl-bunny.examples.asd cl-bunny.test.asd +cl-ca http://beta.quicklisp.org/archive/cl-ca/2016-12-04/cl-ca-20161204-git.tgz 4056 e20a120a4bdea1da122f67d1c748c164 250c6a1fd47118fd4634c1ca7b67f6eec8822e29 cl-ca-20161204-git cl-ca.asd +cl-cache-tables http://beta.quicklisp.org/archive/cl-cache-tables/2017-10-19/cl-cache-tables-20171019-git.tgz 5219 24fcc0c7e5c4b56aa4d3c0ccf8013804 8467ba23db68b1b2136216eb37934664bbc56560 cl-cache-tables-20171019-git cl-cache-tables.asd +cl-cairo2 http://beta.quicklisp.org/archive/cl-cairo2/2016-05-31/cl-cairo2-20160531-git.tgz 219593 aa81d669f8c3feb77dd952f0e4d41719 34fc6c321105781ff8edce95e921dddf81f85a40 cl-cairo2-20160531-git a-cl-cairo2-loader.asd cl-cairo2-demos.asd cl-cairo2-gtk2.asd cl-cairo2-xlib.asd cl-cairo2.asd +cl-case-control http://beta.quicklisp.org/archive/cl-case-control/2014-11-06/cl-case-control-20141106-git.tgz 4262 9bd926eaf15cc7053ef7e6676491aa23 a2d273abfa6ff8f0680f0f9d6545064ba133908a cl-case-control-20141106-git cl-case-control.asd +cl-cffi-gtk http://beta.quicklisp.org/archive/cl-cffi-gtk/2019-07-10/cl-cffi-gtk-20190710-git.tgz 6290692 4ab4d1eabe6fd639f40cb1053ef002b9 788f1a286b96e4d0062e12e68d81e58c3dcb0a6c cl-cffi-gtk-20190710-git cairo/cl-cffi-gtk-cairo.asd demo/cairo-demo/cl-cffi-gtk-demo-cairo.asd demo/glib-demo/cl-cffi-gtk-demo-glib.asd demo/gobject-demo/cl-cffi-gtk-demo-gobject.asd demo/gtk-example/cl-cffi-gtk-example-gtk.asd demo/opengl-demo/cl-cffi-gtk-opengl-demo.asd gdk-pixbuf/cl-cffi-gtk-gdk-pixbuf.asd gdk/cl-cffi-gtk-gdk.asd gio/cl-cffi-gtk-gio.asd glib/cl-cffi-gtk-glib.asd gobject/cl-cffi-gtk-gobject.asd gtk/cl-cffi-gtk.asd pango/cl-cffi-gtk-pango.asd +cl-change-case http://beta.quicklisp.org/archive/cl-change-case/2019-10-07/cl-change-case-20191007-git.tgz 6031 385245df04b1f1514b9fd709a08c4082 5a754242c13cfc0b59832b63053c4fc1fdde0b3d cl-change-case-20191007-git cl-change-case-test.asd cl-change-case.asd +cl-charms http://beta.quicklisp.org/archive/cl-charms/2018-12-10/cl-charms-20181210-git.tgz 26980 19641e2e670b34fe8d8be493d48cb2b3 f00cd4c3c8afae0920c4c5e5181673550b6c1d90 cl-charms-20181210-git cl-charms-paint.asd cl-charms-timer.asd cl-charms.asd +cl-cheshire-cat http://beta.quicklisp.org/archive/cl-cheshire-cat/2012-11-25/cl-cheshire-cat-20121125-git.tgz 23482 729d03cde121deedf97f3669c262e82e d2797915bed6422d5516abeb9f3c4a33809c306b cl-cheshire-cat-20121125-git cl-cheshire-cat.asd +cl-clblas http://beta.quicklisp.org/archive/cl-clblas/2018-10-18/cl-clblas-20181018-git.tgz 8535 ae2ac2ceba89561bc472677ab373017f ecca33c74178a2f77c94fdb3f40a9fee5e87c399 cl-clblas-20181018-git cl-clblas-test.asd cl-clblas.asd +cl-cli http://beta.quicklisp.org/archive/cl-cli/2015-12-18/cl-cli-20151218-git.tgz 6467 820e5c7dde6800fcfa44b1fbc7a9d62b 95d3aaf9325b6317343844e8b40efdf7c302a47f cl-cli-20151218-git cl-cli.asd +cl-cli-parser http://beta.quicklisp.org/archive/cl-cli-parser/2015-06-08/cl-cli-parser-20150608-git.tgz 8093 38fc199ad50a98819a3cd0d82665fe68 a7e3a4d60a6069b08ecd5ebf477609c6927710c3 cl-cli-parser-20150608-git cli-parser.asd +cl-clon http://beta.quicklisp.org/archive/cl-clon/2018-02-28/clon-1.0b24.tgz 191003 7d74fc146a2de5be70a9cb2c5a94312e fa0a4d3ed8bf00ddbdb104b6764a272e21fd0e65 clon-1.0b24 core/net.didierverna.clon.core.asd net.didierverna.clon.asd setup/net.didierverna.clon.setup.asd termio/net.didierverna.clon.termio.asd +cl-closure-template http://beta.quicklisp.org/archive/cl-closure-template/2015-08-04/cl-closure-template-20150804-git.tgz 98945 d2b36fa36a3bbb532c7898c2ff6211f7 b58d01914b50c26a7a43ed1e0848562a212017b3 cl-closure-template-20150804-git closure-template.asd +cl-clsparse http://beta.quicklisp.org/archive/cl-clsparse/2019-08-13/cl-clsparse-20190813-git.tgz 5431 f52ee9a080bc55364c817ea7c032588d e9b211b3f6c39cca6e07516292673c76271b2349 cl-clsparse-20190813-git cl-clsparse.asd +cl-cognito http://beta.quicklisp.org/archive/cl-cognito/2018-12-10/cl-cognito-20181210-git.tgz 10532 6372b22b37cd2f092542cf4add7f336b a31ce281d683c6d15bd458f2dc366ea5ba641b86 cl-cognito-20181210-git cl-cognito.asd +cl-collider http://beta.quicklisp.org/archive/cl-collider/2019-12-27/cl-collider-20191227-git.tgz 54466 f20f5b92d3c9ff4ed7d3fdfabeda763a f30661c617108d845cd4d0144db0106a52019347 cl-collider-20191227-git cl-collider.asd osc/sc-osc.asd +cl-colors http://beta.quicklisp.org/archive/cl-colors/2018-03-28/cl-colors-20180328-git.tgz 14566 5e59ea59b32a0254df9610a5662ae2ec 08d7a2af682802fce159e47ff3511112f24e892a cl-colors-20180328-git cl-colors.asd +cl-colors2 http://beta.quicklisp.org/archive/cl-colors2/2018-10-18/cl-colors2-20181018-git.tgz 21403 ccf1cc214fbce1d11caba8124e844df7 d3a297fade1aa485fe17326c4f2e424558d0feba cl-colors2-20181018-git cl-colors2.asd +cl-conllu http://beta.quicklisp.org/archive/cl-conllu/2019-05-21/cl-conllu-20190521-git.tgz 41333 996654fc068fa6c548868e0455587d9f 2a807ef4d732e413d752212f0804b57c82c52e31 cl-conllu-20190521-git cl-conllu.asd +cl-conspack http://beta.quicklisp.org/archive/cl-conspack/2017-04-03/cl-conspack-20170403-git.tgz 46289 43b17d3d9bb969ffd1919f7c05453c14 6f2acf5bb1d4c2d18573fc5f6eec367325131924 cl-conspack-20170403-git cl-conspack-test.asd cl-conspack.asd +cl-cont http://beta.quicklisp.org/archive/cl-cont/2011-02-19/cl-cont-20110219-darcs.tgz 11715 204ad0178da3de604e92fab5ac1c20b6 f24ffb4d90a98f4ab82841279f29ac64615069de cl-cont-20110219-darcs cl-cont-test.asd cl-cont.asd +cl-containers http://beta.quicklisp.org/archive/cl-containers/2017-04-03/cl-containers-20170403-git.tgz 229279 17123cd2b018cd3eb048eceef78be3f8 3b0e0761995c807fa27cdc74ef97fecf1ba48339 cl-containers-20170403-git cl-containers-test.asd cl-containers.asd +cl-cookie http://beta.quicklisp.org/archive/cl-cookie/2019-10-07/cl-cookie-20191007-git.tgz 4880 37595a6705fdd77415b859aea90d30bc c1dad8b9e287398c5f909af268f1b3908dabc760 cl-cookie-20191007-git cl-cookie-test.asd cl-cookie.asd +cl-coroutine http://beta.quicklisp.org/archive/cl-coroutine/2016-09-29/cl-coroutine-20160929-git.tgz 3335 d89c78cb0a94768603c8f581227af23f 934dcbb769a9199affe633368462e104fbf2c03f cl-coroutine-20160929-git cl-coroutine-test.asd cl-coroutine.asd +cl-coveralls http://beta.quicklisp.org/archive/cl-coveralls/2019-10-07/cl-coveralls-20191007-git.tgz 6629 39f50fddc88f80f9129a17027cfeb6d5 3806f18146a0cbf543329d39508ae55e9607e8fc cl-coveralls-20191007-git cl-coveralls-test.asd cl-coveralls.asd +cl-cpus http://beta.quicklisp.org/archive/cl-cpus/2018-04-30/cl-cpus-20180430-git.tgz 2505 8144fd890f060d558d896c2b10538f02 1c38814243fe2a8f437189d7a7496cd51574f1bb cl-cpus-20180430-git cl-cpus.asd +cl-crc64 http://beta.quicklisp.org/archive/cl-crc64/2014-07-13/cl-crc64-20140713-git.tgz 3436 d97cf9231647235a938707e64a1766ad 3140afa99b2ee11f7cda85f9563b975c45cdb9d2 cl-crc64-20140713-git cl-crc64.asd +cl-creditcard http://beta.quicklisp.org/archive/cl-creditcard/2015-01-13/cl-creditcard-20150113-git.tgz 10834 35f506d0dcef15f26a46b6419c0f060b 0b816115dbedc264e2d3724088267220a8e43a5a cl-creditcard-20150113-git cl-authorize-net.asd cl-creditcard.asd +cl-cron http://beta.quicklisp.org/archive/cl-cron/2019-03-07/cl-cron-20190307-hg.tgz 15874 d5d1bace9780975f4f4144e0c0f4b0fc 35ccdd808c6e532928a100f25fc95bb5fcaf5b2a cl-cron-20190307-hg cl-cron.asd +cl-crypt http://beta.quicklisp.org/archive/cl-crypt/2012-05-20/cl-crypt-20120520-git.tgz 7279 0e6b5ba0cd7a565686e847197622698f f66ea06ec261e994f5ba7d71236c93a3a4edd113 cl-crypt-20120520-git crypt.asd +cl-css http://beta.quicklisp.org/archive/cl-css/2014-09-14/cl-css-20140914-git.tgz 4907 a91f5a5d6a751af31d5c4fd8170f6ece 0b25eb863296f4d83523535c606514502ad6aac5 cl-css-20140914-git cl-css.asd +cl-csv http://beta.quicklisp.org/archive/cl-csv/2018-08-31/cl-csv-20180831-git.tgz 25961 4bd0ef366dea9d48c4581ed73a208cf3 8d16eafebdbb7557ca46f0c3a9b7b8c61f06dcae cl-csv-20180831-git cl-csv-clsql.asd cl-csv-data-table.asd cl-csv.asd +cl-cuda http://beta.quicklisp.org/archive/cl-cuda/2019-10-08/cl-cuda-20191008-git.tgz 72953 bb1ed940f70994c6c078d25337ab343e 653bc8f9cdb6d04c1a1d1909ba278d1d327ace86 cl-cuda-20191008-git cl-cuda-examples.asd cl-cuda-interop-examples.asd cl-cuda-interop.asd cl-cuda-misc.asd cl-cuda.asd +cl-custom-hash-table http://beta.quicklisp.org/archive/cl-custom-hash-table/2017-11-30/cl-custom-hash-table-20171130-git.tgz 7684 c7f9c269174fb5b42717c55d3beed364 42bfbb4a958a3b3259e645d7ae2b434ec84d79a7 cl-custom-hash-table-20171130-git cl-custom-hash-table-test.asd cl-custom-hash-table.asd +cl-cut http://beta.quicklisp.org/archive/cl-cut/2018-01-31/cl-cut-20180131-git.tgz 5001 e020c977e8064ff8b5a6e00c43b2612e 6a7a89a4568e71e2d4b41cb711cd54c4a63ef928 cl-cut-20180131-git cl-cut.asd cl-cut.test.asd +cl-cxx http://beta.quicklisp.org/archive/cl-cxx/2019-05-21/cl-cxx-20190521-git.tgz 6123 2faa57c1c9a2b33b6b5a90828ad24b9f c1455566260bad2f68e58dfdca25b4cfbebbf2b4 cl-cxx-20190521-git cxx-test.asd cxx.asd +cl-darksky http://beta.quicklisp.org/archive/cl-darksky/2018-07-11/cl-darksky-20180711-git.tgz 2006 c62b43b0d00975df19b5c5e72433b462 4b55a096708a83a7fa703813c4ddb02178e45ab3 cl-darksky-20180711-git cl-darksky-test.asd cl-darksky.asd +cl-data-format-validation http://beta.quicklisp.org/archive/cl-data-format-validation/2014-07-13/cl-data-format-validation-20140713-git.tgz 37403 2d13446e593b3b0c46fb83ee9fc5da7f 0a085113a3c0e2c28735f4709b31ff46ee54b68b cl-data-format-validation-20140713-git data-format-validation.asd +cl-data-frame http://beta.quicklisp.org/archive/cl-data-frame/2017-11-30/cl-data-frame-20171130-git.tgz 8813 fdd3f478710440340ac70bffa48a1d73 6db4200be1705e935dc9c72a7e619cdaf47d1d8d cl-data-frame-20171130-git cl-data-frame.asd +cl-date-time-parser http://beta.quicklisp.org/archive/cl-date-time-parser/2014-07-13/cl-date-time-parser-20140713-git.tgz 10231 a5c384eafcdcf063499341b40c09129a 7633ae11684c9c8cd219f4cf615869bc2b5d2c42 cl-date-time-parser-20140713-git cl-date-time-parser.asd +cl-db3 http://beta.quicklisp.org/archive/cl-db3/2019-07-10/cl-db3-20190710-git.tgz 6063 efbee2cdb4ff1ce12dfd8d6fdea20f49 fca6a1dca15b58bf98bd856028e7ce029f985120 cl-db3-20190710-git db3.asd +cl-dbi http://beta.quicklisp.org/archive/cl-dbi/2019-10-07/cl-dbi-20191007-git.tgz 14683 bf524c4000468d12627fa419ae412abb 5f1c8914dca8ac2ef97a04c6068d988908422b1a cl-dbi-20191007-git cl-dbi.asd dbd-mysql.asd dbd-postgres.asd dbd-sqlite3.asd dbi-test.asd dbi.asd +cl-dbi-connection-pool http://beta.quicklisp.org/archive/cl-dbi-connection-pool/2019-01-07/cl-dbi-connection-pool-20190107-git.tgz 6113 a5724b7fc356695c5767580a86c6df9d d8cc6ce43e8b3fd42149fdbf4da5bd831944aa5c cl-dbi-connection-pool-20190107-git cl-dbi-connection-pool.asd dbi-cp-test.asd dbi-cp.asd +cl-dct http://beta.quicklisp.org/archive/cl-dct/2019-11-30/cl-dct-20191130-git.tgz 6823 6f4faa9be0f2ce2a6a959ea705fe8617 8eff1202d59f2f0e27b94d4587f9e2b142946272 cl-dct-20191130-git dct-test.asd dct.asd +cl-decimals http://beta.quicklisp.org/archive/cl-decimals/2019-07-10/cl-decimals-20190710-git.tgz 8044 978ca67fae1ab66015c551505734a149 14ba8ef7eae9319a141e0141f4d8d571b38d8dbb cl-decimals-20190710-git decimals.asd +cl-devil http://beta.quicklisp.org/archive/cl-devil/2015-03-02/cl-devil-20150302-git.tgz 7271 2386d79fa23a831b46dd3a851b635165 81f0c286536f30795267f35614562d2459c41cea cl-devil-20150302-git cl-devil.asd cl-ilu.asd cl-ilut.asd +cl-diceware http://beta.quicklisp.org/archive/cl-diceware/2015-09-23/cl-diceware-20150923-git.tgz 46217 1effc5add086f20640ecca3ea9fb6d44 26501cee6304c77b9db6320e1f2b3fbba88ede2b cl-diceware-20150923-git cl-diceware.asd +cl-difflib http://beta.quicklisp.org/archive/cl-difflib/2013-01-28/cl-difflib-20130128-git.tgz 11909 e8a3434843a368373b67d09983d2b809 2acef03b40d410454539b26882762b25f60da136 cl-difflib-20130128-git cl-difflib-tests.asd cl-difflib.asd +cl-digraph http://beta.quicklisp.org/archive/cl-digraph/2019-12-27/cl-digraph-20191227-hg.tgz 16154 1b66f04c2af3a2a7e6629f9d5f97c3f8 578cdb45125c0cfcf11d22ca52bfa736792bb8bc cl-digraph-20191227-hg cl-digraph.asd cl-digraph.dot.asd cl-digraph.test.asd +cl-diskspace http://beta.quicklisp.org/archive/cl-diskspace/2018-01-31/cl-diskspace-20180131-git.tgz 5005 e82009d42eb86994120bccb7ac5e85a7 f648ea789bba382408ad523e1117a48885ccf290 cl-diskspace-20180131-git cl-diskspace.asd +cl-disque http://beta.quicklisp.org/archive/cl-disque/2017-12-27/cl-disque-20171227-git.tgz 12120 422f594efe55882f080273d68d26c561 f0a7b26834d07a6b35c03c16ba8aeeae18df6160 cl-disque-20171227-git cl-disque-test.asd cl-disque.asd +cl-docutils http://beta.quicklisp.org/archive/cl-docutils/2013-01-28/cl-docutils-20130128-git.tgz 115606 e83e70398da47984339dd29632a78072 014884afae1335295230482b54b560ed7bc51db6 cl-docutils-20130128-git docutils.asd +cl-dot http://beta.quicklisp.org/archive/cl-dot/2018-01-31/cl-dot-20180131-git.tgz 186442 1a552bdc7365fd5e7d2f00a7e49c2202 c35f35701d4fbebe0fc06836ac412566494e28e8 cl-dot-20180131-git cl-dot.asd +cl-dotenv http://beta.quicklisp.org/archive/cl-dotenv/2018-10-18/cl-dotenv-20181018-git.tgz 5339 ea905b934f2a2dc8ee3bfc88fc35ac49 3fe52852f1350c31baa11f85094ad6b7c433ea42 cl-dotenv-20181018-git cl-dotenv-test.asd cl-dotenv.asd +cl-drm http://beta.quicklisp.org/archive/cl-drm/2016-12-04/cl-drm-20161204-git.tgz 3310 dc45def8e5c9df2d9622193b400aa968 5f5474b54ced85e2eaba592dac37c07eb12f702c cl-drm-20161204-git cl-drm.asd +cl-dropbox http://beta.quicklisp.org/archive/cl-dropbox/2015-06-08/cl-dropbox-20150608-git.tgz 3127 cb8e142a42e59c3ad3ebc51243f0e9fd 692318495dcbb349116b544b33482119a1620ff7 cl-dropbox-20150608-git cl-dropbox.asd +cl-dsl http://beta.quicklisp.org/archive/cl-dsl/2013-07-20/cl-dsl-20130720-git.tgz 14073 fce58e9d8682e3224120cc794922de84 a93b21d4833d1d92609d2399028cbba3e908cbbf cl-dsl-20130720-git cl-dsl.asd +cl-durian http://beta.quicklisp.org/archive/cl-durian/2015-06-08/cl-durian-20150608-git.tgz 4819 9da8dd551e1ee63907a79bea0b1565d3 a0ca0ed4bf0257b86270d66bda9a963d0d30529b cl-durian-20150608-git cl-durian.asd +cl-ecma-48 http://beta.quicklisp.org/archive/cl-ecma-48/2019-10-08/cl-ecma-48-20191008-http.tgz 22772 96f3b42f0e84f9743c5894e6b61e1e61 1d35c8d4bf7dfebe48f449b3a47116e2b7a1402b cl-ecma-48-20191008-http cl-ecma-48.asd +cl-editdistance http://beta.quicklisp.org/archive/cl-editdistance/2019-11-30/cl-editdistance-20191130-git.tgz 11143 a3daec92c5fb9595cec446bfa494ddfc d2c99d886ba1b4febe00a07cd7fa247ea44014c3 cl-editdistance-20191130-git edit-distance-test.asd edit-distance.asd +cl-egl http://beta.quicklisp.org/archive/cl-egl/2019-05-21/cl-egl-20190521-git.tgz 3064 022f1ac3d01a265e700d0aa99ff47d71 03446e74bcaa71e61d1f0e9352c9df99ad3ad403 cl-egl-20190521-git cl-egl.asd +cl-elastic http://beta.quicklisp.org/archive/cl-elastic/2019-11-30/cl-elastic-20191130-git.tgz 5445 f41cde9363a8de98bc677f978a4a76d8 59dcbf6275515d52e7ba4f48bfbdc80fb87eaece cl-elastic-20191130-git cl-elastic-test.asd cl-elastic.asd +cl-emacs-if http://beta.quicklisp.org/archive/cl-emacs-if/2012-03-05/cl-emacs-if-20120305-git.tgz 5080 79a7e7ed0dce7b6b937481da97bc5490 3328115dfa0afe358d2301ce9d0335fb323b7b3f cl-emacs-if-20120305-git cl-emacs-if.asd +cl-emb http://beta.quicklisp.org/archive/cl-emb/2019-05-21/cl-emb-20190521-git.tgz 14557 b27bbe8de2206ab7c461700b58d4d527 04a32481580be674abe707cdfd25f20ff710ac7a cl-emb-20190521-git cl-emb.asd +cl-emoji http://beta.quicklisp.org/archive/cl-emoji/2018-02-28/cl-emoji-20180228-git.tgz 130741 28944d5548ea7fb8a591c1f732edd538 fcaf8cb10f53a4155d3a96a9a3e41356c7fa33d1 cl-emoji-20180228-git cl-emoji-test.asd cl-emoji.asd +cl-enchant http://beta.quicklisp.org/archive/cl-enchant/2019-05-21/cl-enchant-20190521-git.tgz 8136 2a868c280fd5a74f9c298c384567e31b 724cc1533724de27d433c210bd63db8a65ecbdf4 cl-enchant-20190521-git enchant-autoload.asd enchant.asd +cl-enumeration http://beta.quicklisp.org/archive/cl-enumeration/2019-07-10/cl-enumeration-20190710-git.tgz 116101 d7f838b9f923cb925966a4cbc44453e4 8450c2282e83778407a297fb5510c5c32cd83468 cl-enumeration-20190710-git enumerations.asd +cl-env http://beta.quicklisp.org/archive/cl-env/2018-04-30/cl-env-20180430-git.tgz 2808 881867f2aee6a8f22acb2dc1db3b5a62 d79b84e8739451c189fa50a6df245db1d4dd0953 cl-env-20180430-git cl-env.asd +cl-environments http://beta.quicklisp.org/archive/cl-environments/2019-11-30/cl-environments-20191130-git.tgz 39644 b7b04131bb799a90c087eba6644f2e7c 47cbb62c93757d781167d60ad398a3d03346d789 cl-environments-20191130-git cl-environments.asd +cl-epmd http://beta.quicklisp.org/archive/cl-epmd/2014-02-11/cl-epmd-20140211-git.tgz 8497 535d47c3fdcbf90656549f48da838151 1e5e823a18ae86b707ebfae97acd4af7a31ef36e cl-epmd-20140211-git epmd-test.asd epmd.asd +cl-epoch http://beta.quicklisp.org/archive/cl-epoch/2018-12-10/cl-epoch-20181210-git.tgz 772 677d6391a0c4ae9b20e4115cb0681706 3266833985cfc3447642de88f2b808fd0e25d222 cl-epoch-20181210-git cl-epoch.asd +cl-erlang-term http://beta.quicklisp.org/archive/cl-erlang-term/2016-05-31/cl-erlang-term-20160531-git.tgz 19973 fb58d27f4aba01da6e4677ef8a1e4fff 65583551c5793e1c22f20414a65548043814608d cl-erlang-term-20160531-git erlang-term-optima.asd erlang-term-test.asd erlang-term.asd +cl-ev http://beta.quicklisp.org/archive/cl-ev/2015-09-23/cl-ev-20150923-git.tgz 6322 802c3966a9dbd25d22407825271e70fd d90c2e7c18e3710e25ecd2206430926dc4307891 cl-ev-20150923-git ev.asd +cl-events http://beta.quicklisp.org/archive/cl-events/2016-03-18/cl-events-20160318-git.tgz 7199 064df9efa3a6db5b1540d61a91671ca8 21f4cb9f76b3ffd12d7b6d5d17e0960cd8b57819 cl-events-20160318-git cl-events.asd cl-events.test.asd +cl-ewkb http://beta.quicklisp.org/archive/cl-ewkb/2011-06-19/cl-ewkb-20110619-git.tgz 9929 cbcc96a62750e5aee99f2261d4b2171c 262f1978c053c76a4fa288411f8fbd150d29fcbb cl-ewkb-20110619-git cl-ewkb.asd +cl-factoring http://beta.quicklisp.org/archive/cl-factoring/2018-04-30/cl-factoring-20180430-git.tgz 22615 d394be277a6a2639cf86f4547b31e959 773a33d4c38725d5eb0282dc64e2c880c48c38a5 cl-factoring-20180430-git cl-factoring-test.asd cl-factoring.asd +cl-fad http://beta.quicklisp.org/archive/cl-fad/2019-08-13/cl-fad-20190813-git.tgz 24659 7d0405b44fefccb8a807527249ee2700 06a84a76e539e6168fa868abd403ab036892857d cl-fad-20190813-git cl-fad.asd +cl-fam http://beta.quicklisp.org/archive/cl-fam/2012-11-25/cl-fam-20121125-git.tgz 8597 4844d1092223363858a0963b56b09d10 9def84e89f75f5d2449f31db352fc1d6d51c156a cl-fam-20121125-git cl-fam.asd +cl-fastcgi http://beta.quicklisp.org/archive/cl-fastcgi/2019-12-27/cl-fastcgi-20191227-git.tgz 3728 ad0d29720060f795dfb4270d3deb554a 600c0a050de8293f0af7570abcf6c248bf5da8c5 cl-fastcgi-20191227-git cl-fastcgi.asd +cl-fbclient http://beta.quicklisp.org/archive/cl-fbclient/2014-01-13/cl-fbclient-20140113-git.tgz 9685 48d0afd4a519cac7c0b219063d51f6d9 09f3e78c416b6524ebe3c2d75e279eeda08b2277 cl-fbclient-20140113-git cl-fbclient.asd +cl-feedparser http://beta.quicklisp.org/archive/cl-feedparser/2019-07-10/cl-feedparser-20190710-git.tgz 1144159 fbb3d704161400b6fa1d59a067a21e01 ccece16e6ca4b553ce6425e08a33c2ed5c511a1d cl-feedparser-20190710-git cl-feedparser.asd test/cl-feedparser-tests.asd +cl-fixtures http://beta.quicklisp.org/archive/cl-fixtures/2018-04-30/cl-fixtures-20180430-git.tgz 13986 5c3e871d243c4de04b35953c252d05c4 6a159febf5270b88ef432027547a9aa2ce0b8f5c cl-fixtures-20180430-git cl-fixtures-test.asd cl-fixtures.asd +cl-flac http://beta.quicklisp.org/archive/cl-flac/2019-07-10/cl-flac-20190710-git.tgz 290402 a987ae59d6785b72735a7a102cbc9907 399983a24191cc0bc3e9657d3b4ba3bb0c9d6142 cl-flac-20190710-git cl-flac.asd +cl-flat-tree http://beta.quicklisp.org/archive/cl-flat-tree/2019-08-13/cl-flat-tree-20190813-git.tgz 5132 8705ad941f264bdedb08e4a1ad6afcfb 3f0fb91a38e4246e34d9a76d4c1dddb4515063b5 cl-flat-tree-20190813-git flat-tree.asd +cl-flow http://beta.quicklisp.org/archive/cl-flow/2018-08-31/cl-flow-stable-778a219a-git.tgz 5227 821e95bb7e4a43c42e7c581faf4bb7df f4c311f389d822e5b87d20cab264111eae5c056a cl-flow-stable-778a219a-git cl-flow.asd +cl-flowd http://beta.quicklisp.org/archive/cl-flowd/2014-07-13/cl-flowd-20140713-git.tgz 5753 c8ec0147510ab231d0e3377beaf5f897 b5382880a7203fb47f6d55b6b587a5645eb2322e cl-flowd-20140713-git cl-flowd.asd +cl-fluent-logger http://beta.quicklisp.org/archive/cl-fluent-logger/2019-02-02/cl-fluent-logger-20190202-git.tgz 4829 db5f23548d9f4c7c93375456cc12ba6a 4c8b44df1de4e803896bdfe72c55b3f5995738de cl-fluent-logger-20190202-git cl-fluent-logger.asd +cl-fluidinfo http://beta.quicklisp.org/archive/cl-fluidinfo/2013-03-12/cl-fluidinfo-20130312-git.tgz 8963 31baff1a738ad8dcf30b4f466d71366c 0c8485eba076578d271d6190ba75dd853ad5867c cl-fluidinfo-20130312-git cl-fluiddb-test.asd cl-fluiddb.asd cl-fluidinfo.asd +cl-fond http://beta.quicklisp.org/archive/cl-fond/2019-11-30/cl-fond-20191130-git.tgz 328112 15c6094682447b9bc49bfa253a064360 df52e6e1d9515e749da9cca6ee1e54d378153ea3 cl-fond-20191130-git cl-fond.asd +cl-forms http://beta.quicklisp.org/archive/cl-forms/2019-07-10/cl-forms-20190710-git.tgz 841887 6945c01e82db6c989baf74c9b93ed8ac 424fb61fa9483e85d15b977c79c5ea6a33dd0166 cl-forms-20190710-git cl-forms.asd cl-forms.demo.asd cl-forms.djula.asd cl-forms.test.asd cl-forms.who.asd +cl-freeimage http://beta.quicklisp.org/archive/cl-freeimage/2017-04-03/cl-freeimage-20170403-git.tgz 10611 92c8fff7a488a73ff5793f43145cb641 ca94e56e0a67d03b054160c6a78c705b0172f14d cl-freeimage-20170403-git cl-freeimage.asd +cl-freetype2 http://beta.quicklisp.org/archive/cl-freetype2/2019-10-07/cl-freetype2-20191007-git.tgz 43368 0d4482c5201de0ff9b959deac59d1d25 ca147fa768c83e540583b780d38067bec7314d48 cl-freetype2-20191007-git cl-freetype2-tests.asd cl-freetype2.asd +cl-fsnotify http://beta.quicklisp.org/archive/cl-fsnotify/2015-03-02/cl-fsnotify-20150302-git.tgz 5979 54fe23d75d2baa6f404aef9c4da39449 6a6f82a1fc13f6286e1e9ae071e4a827830192d4 cl-fsnotify-20150302-git cl-fsnotify.asd +cl-ftp http://beta.quicklisp.org/archive/cl-ftp/2015-06-08/cl-ftp-20150608-http.tgz 9367 0743157a9fe2eea7c4a3a79874df1d55 e2ffb352da8b73a6895499ab6a1c1004e8bc5198 cl-ftp-20150608-http cl-ftp.asd ftp.asd +cl-fuse http://beta.quicklisp.org/archive/cl-fuse/2019-12-27/cl-fuse-20191227-git.tgz 23534 3c6f85db7797a2890d8303d11595100d 632def3847f0cff4ed2cc39ccbdeabb69e39802d cl-fuse-20191227-git cl-fuse.asd +cl-fuse-meta-fs http://beta.quicklisp.org/archive/cl-fuse-meta-fs/2019-07-10/cl-fuse-meta-fs-20190710-git.tgz 16844 461f7023274fb273e6c759e881bdd636 ab7279115b939e7a1d701d8d74538109313db2dc cl-fuse-meta-fs-20190710-git cl-fuse-meta-fs.asd +cl-fuzz http://beta.quicklisp.org/archive/cl-fuzz/2018-10-18/cl-fuzz-20181018-git.tgz 4141 22e715b370ea886bbff1e09db20c4e32 bd6ff387648fcf0c47266b2be40c7214b6e84bb3 cl-fuzz-20181018-git cl-fuzz.asd +cl-gambol http://beta.quicklisp.org/archive/cl-gambol/2016-03-18/cl-gambol-20160318-git.tgz 14886 887b54fee9fa3d77865a3eb3caaeac3e 5e9f5015bb42df0d9c70be356ce15dbec537c295 cl-gambol-20160318-git gambol.asd +cl-gamepad http://beta.quicklisp.org/archive/cl-gamepad/2019-07-10/cl-gamepad-20190710-git.tgz 107573 28a21a3aff9d9ad530fe9b69257cd72a 501a2372777fc5a55a723b1316c964e09a5494c5 cl-gamepad-20190710-git cl-gamepad-visualizer.asd cl-gamepad.asd +cl-gap-buffer http://beta.quicklisp.org/archive/cl-gap-buffer/2019-03-07/cl-gap-buffer-20190307-hg.tgz 4587 48de07c260d666659464734743de3646 05aa46f3548f072197a6e75c075b1b8ae60d15f7 cl-gap-buffer-20190307-hg cl-gap-buffer.asd +cl-gbm http://beta.quicklisp.org/archive/cl-gbm/2018-04-30/cl-gbm-20180430-git.tgz 2187 d5f7e5c5d37248986d4a882b44ac43a9 b504515681fb74f54f2e0c3dd4e05226a72ae03c cl-gbm-20180430-git cl-gbm.asd +cl-gd http://beta.quicklisp.org/archive/cl-gd/2017-11-30/cl-gd-20171130-git.tgz 203897 eef761d6507da1576b60da09f49d1dbb f8918ce5cc783b2474d73fc19a600644ae5b0f5b cl-gd-20171130-git cl-gd-test.asd cl-gd.asd +cl-gdata http://beta.quicklisp.org/archive/cl-gdata/2017-11-30/cl-gdata-20171130-git.tgz 31765 94763ae151858d354d5e9d8af3bdc538 cbcb9f87b27846e757bf70cf5cea38394ec414d4 cl-gdata-20171130-git cl-gdata.asd +cl-gearman http://beta.quicklisp.org/archive/cl-gearman/2015-09-23/cl-gearman-20150923-git.tgz 7680 6d7496a301f9cbb2d69e16bea12e2760 b39af5a987148d2492c7f85d0b58ae67b97b6f61 cl-gearman-20150923-git cl-gearman-test.asd cl-gearman.asd +cl-gendoc http://beta.quicklisp.org/archive/cl-gendoc/2018-08-31/cl-gendoc-20180831-git.tgz 6187 f74903585bca304a72b9739261c5c980 c0b1fec403200e417008b960c5ddbb6bb6bc9f53 cl-gendoc-20180831-git cl-gendoc.asd +cl-gene-searcher http://beta.quicklisp.org/archive/cl-gene-searcher/2011-10-01/cl-gene-searcher-20111001-git.tgz 3309 1350073f7965574a146421e59533bb00 35abc2a2a5b5091f0bb821269bfc6980260ed1fa cl-gene-searcher-20111001-git cl-gene-searcher.asd +cl-general-accumulator http://beta.quicklisp.org/archive/cl-general-accumulator/2019-05-21/cl-general-accumulator-20190521-git.tgz 5408 a60a9c5cff36fd49591f3f4cfd8c1cfd f68acdcdf203c36c6ed525bffd8884a59d3a931f cl-general-accumulator-20190521-git general-accumulator.asd +cl-generator http://beta.quicklisp.org/archive/cl-generator/2019-03-07/cl-generator-20190307-git.tgz 4308 e5ea88e49ed25ffacc11cdab4c6d77f6 5f7b67551d6628ea14667d8a54e95368016e1adb cl-generator-20190307-git cl-generator-test.asd cl-generator.asd +cl-generic-arithmetic http://beta.quicklisp.org/archive/cl-generic-arithmetic/2019-03-07/cl-generic-arithmetic-20190307-hg.tgz 5684 66225b9a7b00a5c36c86e8ae35002dfc 918705d37a97aff0cd98b31066b1b799a166407f cl-generic-arithmetic-20190307-hg cl-generic-arithmetic.asd +cl-geocode http://beta.quicklisp.org/archive/cl-geocode/2019-08-13/cl-geocode-20190813-git.tgz 583489 9c5dea4fa9d4d25ecb5a12d58ca518d3 a6b99dd47185ed88a289271cc668ba1c6d5a9961 cl-geocode-20190813-git cl-geocode.asd +cl-geoip http://beta.quicklisp.org/archive/cl-geoip/2013-06-15/cl-geoip-20130615-git.tgz 1698 2d174e9d08cead4ae9a320273c332844 08916ca6c4253b06adce2a03210916935d88e797 cl-geoip-20130615-git cl-geoip.asd +cl-geometry http://beta.quicklisp.org/archive/cl-geometry/2016-05-31/cl-geometry-20160531-git.tgz 17003 c0aaccbb4e2df6c504e6c1cd15155353 940f33dadfdfc8be044a94b0166ad99b29893865 cl-geometry-20160531-git cl-geometry-tests.asd cl-geometry.asd +cl-geos http://beta.quicklisp.org/archive/cl-geos/2018-07-11/cl-geos-20180711-git.tgz 18007 087b13649ed86240dead36394b5fea89 a32b0710b2ab3febb1af0fccec6a9e294675abb3 cl-geos-20180711-git cl-geos.asd +cl-gimei http://beta.quicklisp.org/archive/cl-gimei/2018-03-28/cl-gimei-20180328-git.tgz 148851 14be1ab4a8a88f11d8ad44c14f66a57b e1115122633adac652992deb4777015ed62f9444 cl-gimei-20180328-git cl-gimei.asd +cl-gists http://beta.quicklisp.org/archive/cl-gists/2018-02-28/cl-gists-20180228-git.tgz 10807 adbd22dbdccd05776ad5589add0983b8 1d8c375299852e4a7de3e5495eaa066147cb445d cl-gists-20180228-git cl-gists-test.asd cl-gists.asd +cl-git http://beta.quicklisp.org/archive/cl-git/2015-07-09/cl-git-20150709-git.tgz 60507 cbe03f1b837c775729c0b66fa707577f c3e37ce1e8437f76664b6779bd35b40b9485a8b4 cl-git-20150709-git cl-git.asd +cl-github-v3 http://beta.quicklisp.org/archive/cl-github-v3/2019-12-27/cl-github-v3-20191227-git.tgz 2857 e116ddd20a76120573acfe6583c24cb3 353704ab1cf6849d9e4a12e9e0f4dfb9c99d2135 cl-github-v3-20191227-git cl-github-v3.asd +cl-glfw http://beta.quicklisp.org/archive/cl-glfw/2015-03-02/cl-glfw-20150302-git.tgz 461048 c939bd97538b254d445f4b0904bbb8fa 03b779d59b8807cc72bdc2a5d407a393f24fa7fd cl-glfw-20150302-git cl-glfw-ftgl.asd cl-glfw-glu.asd cl-glfw-opengl-core.asd cl-glfw-opengl-version_1_0.asd cl-glfw-opengl-version_1_1.asd cl-glfw-opengl-version_1_2.asd cl-glfw-opengl-version_1_3.asd cl-glfw-opengl-version_1_4.asd cl-glfw-opengl-version_1_5.asd cl-glfw-opengl-version_2_0.asd cl-glfw-opengl-version_2_1.asd cl-glfw-types.asd cl-glfw.asd lib/cl-glfw-opengl-3dfx_multisample.asd lib/cl-glfw-opengl-3dfx_tbuffer.asd lib/cl-glfw-opengl-3dfx_texture_compression_fxt1.asd lib/cl-glfw-opengl-amd_blend_minmax_factor.asd lib/cl-glfw-opengl-amd_depth_clamp_separate.asd lib/cl-glfw-opengl-amd_draw_buffers_blend.asd lib/cl-glfw-opengl-amd_multi_draw_indirect.asd lib/cl-glfw-opengl-amd_name_gen_delete.asd lib/cl-glfw-opengl-amd_performance_monitor.asd lib/cl-glfw-opengl-amd_sample_positions.asd lib/cl-glfw-opengl-amd_seamless_cubemap_per_texture.asd lib/cl-glfw-opengl-amd_vertex_shader_tesselator.asd lib/cl-glfw-opengl-apple_aux_depth_stencil.asd lib/cl-glfw-opengl-apple_client_storage.asd lib/cl-glfw-opengl-apple_element_array.asd lib/cl-glfw-opengl-apple_fence.asd lib/cl-glfw-opengl-apple_float_pixels.asd lib/cl-glfw-opengl-apple_flush_buffer_range.asd lib/cl-glfw-opengl-apple_object_purgeable.asd lib/cl-glfw-opengl-apple_rgb_422.asd lib/cl-glfw-opengl-apple_row_bytes.asd lib/cl-glfw-opengl-apple_specular_vector.asd lib/cl-glfw-opengl-apple_texture_range.asd lib/cl-glfw-opengl-apple_transform_hint.asd lib/cl-glfw-opengl-apple_vertex_array_object.asd lib/cl-glfw-opengl-apple_vertex_array_range.asd lib/cl-glfw-opengl-apple_vertex_program_evaluators.asd lib/cl-glfw-opengl-apple_ycbcr_422.asd lib/cl-glfw-opengl-arb_blend_func_extended.asd lib/cl-glfw-opengl-arb_color_buffer_float.asd lib/cl-glfw-opengl-arb_copy_buffer.asd lib/cl-glfw-opengl-arb_depth_buffer_float.asd lib/cl-glfw-opengl-arb_depth_clamp.asd lib/cl-glfw-opengl-arb_depth_texture.asd lib/cl-glfw-opengl-arb_draw_buffers.asd lib/cl-glfw-opengl-arb_draw_buffers_blend.asd lib/cl-glfw-opengl-arb_draw_elements_base_vertex.asd lib/cl-glfw-opengl-arb_draw_indirect.asd lib/cl-glfw-opengl-arb_draw_instanced.asd lib/cl-glfw-opengl-arb_es2_compatibility.asd lib/cl-glfw-opengl-arb_fragment_program.asd lib/cl-glfw-opengl-arb_fragment_shader.asd lib/cl-glfw-opengl-arb_framebuffer_object.asd lib/cl-glfw-opengl-arb_framebuffer_object_deprecated.asd lib/cl-glfw-opengl-arb_framebuffer_srgb.asd lib/cl-glfw-opengl-arb_geometry_shader4.asd lib/cl-glfw-opengl-arb_get_program_binary.asd lib/cl-glfw-opengl-arb_gpu_shader5.asd lib/cl-glfw-opengl-arb_gpu_shader_fp64.asd lib/cl-glfw-opengl-arb_half_float_pixel.asd lib/cl-glfw-opengl-arb_half_float_vertex.asd lib/cl-glfw-opengl-arb_imaging.asd lib/cl-glfw-opengl-arb_imaging_deprecated.asd lib/cl-glfw-opengl-arb_instanced_arrays.asd lib/cl-glfw-opengl-arb_map_buffer_range.asd lib/cl-glfw-opengl-arb_matrix_palette.asd lib/cl-glfw-opengl-arb_multisample.asd lib/cl-glfw-opengl-arb_multitexture.asd lib/cl-glfw-opengl-arb_occlusion_query.asd lib/cl-glfw-opengl-arb_occlusion_query2.asd lib/cl-glfw-opengl-arb_pixel_buffer_object.asd lib/cl-glfw-opengl-arb_point_parameters.asd lib/cl-glfw-opengl-arb_point_sprite.asd lib/cl-glfw-opengl-arb_provoking_vertex.asd lib/cl-glfw-opengl-arb_robustness.asd lib/cl-glfw-opengl-arb_sample_shading.asd lib/cl-glfw-opengl-arb_sampler_objects.asd lib/cl-glfw-opengl-arb_seamless_cube_map.asd lib/cl-glfw-opengl-arb_separate_shader_objects.asd lib/cl-glfw-opengl-arb_shader_objects.asd lib/cl-glfw-opengl-arb_shader_subroutine.asd lib/cl-glfw-opengl-arb_shading_language_100.asd lib/cl-glfw-opengl-arb_shading_language_include.asd lib/cl-glfw-opengl-arb_shadow.asd lib/cl-glfw-opengl-arb_shadow_ambient.asd lib/cl-glfw-opengl-arb_tessellation_shader.asd lib/cl-glfw-opengl-arb_texture_border_clamp.asd lib/cl-glfw-opengl-arb_texture_buffer_object.asd lib/cl-glfw-opengl-arb_texture_buffer_object_rgb32.asd lib/cl-glfw-opengl-arb_texture_compression.asd lib/cl-glfw-opengl-arb_texture_compression_bptc.asd lib/cl-glfw-opengl-arb_texture_compression_rgtc.asd lib/cl-glfw-opengl-arb_texture_cube_map.asd lib/cl-glfw-opengl-arb_texture_cube_map_array.asd lib/cl-glfw-opengl-arb_texture_env_combine.asd lib/cl-glfw-opengl-arb_texture_env_dot3.asd lib/cl-glfw-opengl-arb_texture_float.asd lib/cl-glfw-opengl-arb_texture_gather.asd lib/cl-glfw-opengl-arb_texture_mirrored_repeat.asd lib/cl-glfw-opengl-arb_texture_multisample.asd lib/cl-glfw-opengl-arb_texture_rectangle.asd lib/cl-glfw-opengl-arb_texture_rg.asd lib/cl-glfw-opengl-arb_texture_rgb10_a2ui.asd lib/cl-glfw-opengl-arb_texture_swizzle.asd lib/cl-glfw-opengl-arb_timer_query.asd lib/cl-glfw-opengl-arb_transform_feedback2.asd lib/cl-glfw-opengl-arb_transpose_matrix.asd lib/cl-glfw-opengl-arb_uniform_buffer_object.asd lib/cl-glfw-opengl-arb_vertex_array_bgra.asd lib/cl-glfw-opengl-arb_vertex_array_object.asd lib/cl-glfw-opengl-arb_vertex_attrib_64bit.asd lib/cl-glfw-opengl-arb_vertex_blend.asd lib/cl-glfw-opengl-arb_vertex_buffer_object.asd lib/cl-glfw-opengl-arb_vertex_program.asd lib/cl-glfw-opengl-arb_vertex_shader.asd lib/cl-glfw-opengl-arb_vertex_type_2_10_10_10_rev.asd lib/cl-glfw-opengl-arb_viewport_array.asd lib/cl-glfw-opengl-arb_window_pos.asd lib/cl-glfw-opengl-ati_draw_buffers.asd lib/cl-glfw-opengl-ati_element_array.asd lib/cl-glfw-opengl-ati_envmap_bumpmap.asd lib/cl-glfw-opengl-ati_fragment_shader.asd lib/cl-glfw-opengl-ati_map_object_buffer.asd lib/cl-glfw-opengl-ati_meminfo.asd lib/cl-glfw-opengl-ati_pixel_format_float.asd lib/cl-glfw-opengl-ati_pn_triangles.asd lib/cl-glfw-opengl-ati_separate_stencil.asd lib/cl-glfw-opengl-ati_text_fragment_shader.asd lib/cl-glfw-opengl-ati_texture_env_combine3.asd lib/cl-glfw-opengl-ati_texture_float.asd lib/cl-glfw-opengl-ati_texture_mirror_once.asd lib/cl-glfw-opengl-ati_vertex_array_object.asd lib/cl-glfw-opengl-ati_vertex_attrib_array_object.asd lib/cl-glfw-opengl-ati_vertex_streams.asd lib/cl-glfw-opengl-ext_422_pixels.asd lib/cl-glfw-opengl-ext_abgr.asd lib/cl-glfw-opengl-ext_bgra.asd lib/cl-glfw-opengl-ext_bindable_uniform.asd lib/cl-glfw-opengl-ext_blend_color.asd lib/cl-glfw-opengl-ext_blend_equation_separate.asd lib/cl-glfw-opengl-ext_blend_func_separate.asd lib/cl-glfw-opengl-ext_blend_minmax.asd lib/cl-glfw-opengl-ext_blend_subtract.asd lib/cl-glfw-opengl-ext_clip_volume_hint.asd lib/cl-glfw-opengl-ext_cmyka.asd lib/cl-glfw-opengl-ext_color_subtable.asd lib/cl-glfw-opengl-ext_compiled_vertex_array.asd lib/cl-glfw-opengl-ext_convolution.asd lib/cl-glfw-opengl-ext_coordinate_frame.asd lib/cl-glfw-opengl-ext_copy_texture.asd lib/cl-glfw-opengl-ext_cull_vertex.asd lib/cl-glfw-opengl-ext_depth_bounds_test.asd lib/cl-glfw-opengl-ext_direct_state_access.asd lib/cl-glfw-opengl-ext_draw_buffers2.asd lib/cl-glfw-opengl-ext_draw_instanced.asd lib/cl-glfw-opengl-ext_draw_range_elements.asd lib/cl-glfw-opengl-ext_fog_coord.asd lib/cl-glfw-opengl-ext_framebuffer_blit.asd lib/cl-glfw-opengl-ext_framebuffer_multisample.asd lib/cl-glfw-opengl-ext_framebuffer_object.asd lib/cl-glfw-opengl-ext_framebuffer_srgb.asd lib/cl-glfw-opengl-ext_geometry_shader4.asd lib/cl-glfw-opengl-ext_gpu_program_parameters.asd lib/cl-glfw-opengl-ext_gpu_shader4.asd lib/cl-glfw-opengl-ext_histogram.asd lib/cl-glfw-opengl-ext_index_array_formats.asd lib/cl-glfw-opengl-ext_index_func.asd lib/cl-glfw-opengl-ext_index_material.asd lib/cl-glfw-opengl-ext_light_texture.asd lib/cl-glfw-opengl-ext_multi_draw_arrays.asd lib/cl-glfw-opengl-ext_multisample.asd lib/cl-glfw-opengl-ext_packed_depth_stencil.asd lib/cl-glfw-opengl-ext_packed_float.asd lib/cl-glfw-opengl-ext_packed_pixels.asd lib/cl-glfw-opengl-ext_paletted_texture.asd lib/cl-glfw-opengl-ext_pixel_buffer_object.asd lib/cl-glfw-opengl-ext_pixel_transform.asd lib/cl-glfw-opengl-ext_point_parameters.asd lib/cl-glfw-opengl-ext_polygon_offset.asd lib/cl-glfw-opengl-ext_provoking_vertex.asd lib/cl-glfw-opengl-ext_secondary_color.asd lib/cl-glfw-opengl-ext_separate_shader_objects.asd lib/cl-glfw-opengl-ext_separate_specular_color.asd lib/cl-glfw-opengl-ext_shader_image_load_store.asd lib/cl-glfw-opengl-ext_stencil_clear_tag.asd lib/cl-glfw-opengl-ext_stencil_two_side.asd lib/cl-glfw-opengl-ext_stencil_wrap.asd lib/cl-glfw-opengl-ext_subtexture.asd lib/cl-glfw-opengl-ext_texture.asd lib/cl-glfw-opengl-ext_texture3d.asd lib/cl-glfw-opengl-ext_texture_array.asd lib/cl-glfw-opengl-ext_texture_buffer_object.asd lib/cl-glfw-opengl-ext_texture_compression_latc.asd lib/cl-glfw-opengl-ext_texture_compression_rgtc.asd lib/cl-glfw-opengl-ext_texture_compression_s3tc.asd lib/cl-glfw-opengl-ext_texture_cube_map.asd lib/cl-glfw-opengl-ext_texture_env_combine.asd lib/cl-glfw-opengl-ext_texture_env_dot3.asd lib/cl-glfw-opengl-ext_texture_filter_anisotropic.asd lib/cl-glfw-opengl-ext_texture_integer.asd lib/cl-glfw-opengl-ext_texture_lod_bias.asd lib/cl-glfw-opengl-ext_texture_mirror_clamp.asd lib/cl-glfw-opengl-ext_texture_object.asd lib/cl-glfw-opengl-ext_texture_perturb_normal.asd lib/cl-glfw-opengl-ext_texture_shared_exponent.asd lib/cl-glfw-opengl-ext_texture_snorm.asd lib/cl-glfw-opengl-ext_texture_srgb.asd lib/cl-glfw-opengl-ext_texture_srgb_decode.asd lib/cl-glfw-opengl-ext_texture_swizzle.asd lib/cl-glfw-opengl-ext_timer_query.asd lib/cl-glfw-opengl-ext_transform_feedback.asd lib/cl-glfw-opengl-ext_vertex_array.asd lib/cl-glfw-opengl-ext_vertex_array_bgra.asd lib/cl-glfw-opengl-ext_vertex_attrib_64bit.asd lib/cl-glfw-opengl-ext_vertex_shader.asd lib/cl-glfw-opengl-ext_vertex_weighting.asd lib/cl-glfw-opengl-gremedy_frame_terminator.asd lib/cl-glfw-opengl-gremedy_string_marker.asd lib/cl-glfw-opengl-hp_convolution_border_modes.asd lib/cl-glfw-opengl-hp_image_transform.asd lib/cl-glfw-opengl-hp_occlusion_test.asd lib/cl-glfw-opengl-hp_texture_lighting.asd lib/cl-glfw-opengl-ibm_cull_vertex.asd lib/cl-glfw-opengl-ibm_multimode_draw_arrays.asd lib/cl-glfw-opengl-ibm_rasterpos_clip.asd lib/cl-glfw-opengl-ibm_texture_mirrored_repeat.asd lib/cl-glfw-opengl-ibm_vertex_array_lists.asd lib/cl-glfw-opengl-ingr_blend_func_separate.asd lib/cl-glfw-opengl-ingr_color_clamp.asd lib/cl-glfw-opengl-ingr_interlace_read.asd lib/cl-glfw-opengl-intel_parallel_arrays.asd lib/cl-glfw-opengl-mesa_pack_invert.asd lib/cl-glfw-opengl-mesa_packed_depth_stencil.asd lib/cl-glfw-opengl-mesa_program_debug.asd lib/cl-glfw-opengl-mesa_resize_buffers.asd lib/cl-glfw-opengl-mesa_shader_debug.asd lib/cl-glfw-opengl-mesa_trace.asd lib/cl-glfw-opengl-mesa_window_pos.asd lib/cl-glfw-opengl-mesa_ycbcr_texture.asd lib/cl-glfw-opengl-mesax_texture_stack.asd lib/cl-glfw-opengl-nv_conditional_render.asd lib/cl-glfw-opengl-nv_copy_depth_to_color.asd lib/cl-glfw-opengl-nv_copy_image.asd lib/cl-glfw-opengl-nv_depth_buffer_float.asd lib/cl-glfw-opengl-nv_depth_clamp.asd lib/cl-glfw-opengl-nv_evaluators.asd lib/cl-glfw-opengl-nv_explicit_multisample.asd lib/cl-glfw-opengl-nv_fence.asd lib/cl-glfw-opengl-nv_float_buffer.asd lib/cl-glfw-opengl-nv_fog_distance.asd lib/cl-glfw-opengl-nv_fragment_program.asd lib/cl-glfw-opengl-nv_fragment_program2.asd lib/cl-glfw-opengl-nv_framebuffer_multisample_coverage.asd lib/cl-glfw-opengl-nv_geometry_program4.asd lib/cl-glfw-opengl-nv_gpu_program4.asd lib/cl-glfw-opengl-nv_gpu_program5.asd lib/cl-glfw-opengl-nv_gpu_shader5.asd lib/cl-glfw-opengl-nv_half_float.asd lib/cl-glfw-opengl-nv_light_max_exponent.asd lib/cl-glfw-opengl-nv_multisample_coverage.asd lib/cl-glfw-opengl-nv_multisample_filter_hint.asd lib/cl-glfw-opengl-nv_occlusion_query.asd lib/cl-glfw-opengl-nv_packed_depth_stencil.asd lib/cl-glfw-opengl-nv_parameter_buffer_object.asd lib/cl-glfw-opengl-nv_pixel_data_range.asd lib/cl-glfw-opengl-nv_point_sprite.asd lib/cl-glfw-opengl-nv_present_video.asd lib/cl-glfw-opengl-nv_primitive_restart.asd lib/cl-glfw-opengl-nv_register_combiners.asd lib/cl-glfw-opengl-nv_register_combiners2.asd lib/cl-glfw-opengl-nv_shader_buffer_load.asd lib/cl-glfw-opengl-nv_shader_buffer_store.asd lib/cl-glfw-opengl-nv_tessellation_program5.asd lib/cl-glfw-opengl-nv_texgen_emboss.asd lib/cl-glfw-opengl-nv_texgen_reflection.asd lib/cl-glfw-opengl-nv_texture_barrier.asd lib/cl-glfw-opengl-nv_texture_env_combine4.asd lib/cl-glfw-opengl-nv_texture_expand_normal.asd lib/cl-glfw-opengl-nv_texture_multisample.asd lib/cl-glfw-opengl-nv_texture_rectangle.asd lib/cl-glfw-opengl-nv_texture_shader.asd lib/cl-glfw-opengl-nv_texture_shader2.asd lib/cl-glfw-opengl-nv_texture_shader3.asd lib/cl-glfw-opengl-nv_transform_feedback.asd lib/cl-glfw-opengl-nv_transform_feedback2.asd lib/cl-glfw-opengl-nv_vertex_array_range.asd lib/cl-glfw-opengl-nv_vertex_array_range2.asd lib/cl-glfw-opengl-nv_vertex_attrib_integer_64bit.asd lib/cl-glfw-opengl-nv_vertex_buffer_unified_memory.asd lib/cl-glfw-opengl-nv_vertex_program.asd lib/cl-glfw-opengl-nv_vertex_program2_option.asd lib/cl-glfw-opengl-nv_vertex_program3.asd lib/cl-glfw-opengl-nv_vertex_program4.asd lib/cl-glfw-opengl-oes_read_format.asd lib/cl-glfw-opengl-oml_interlace.asd lib/cl-glfw-opengl-oml_resample.asd lib/cl-glfw-opengl-oml_subsample.asd lib/cl-glfw-opengl-pgi_misc_hints.asd lib/cl-glfw-opengl-pgi_vertex_hints.asd lib/cl-glfw-opengl-rend_screen_coordinates.asd lib/cl-glfw-opengl-s3_s3tc.asd lib/cl-glfw-opengl-sgi_color_table.asd lib/cl-glfw-opengl-sgi_depth_pass_instrument.asd lib/cl-glfw-opengl-sgis_detail_texture.asd lib/cl-glfw-opengl-sgis_fog_function.asd lib/cl-glfw-opengl-sgis_multisample.asd lib/cl-glfw-opengl-sgis_pixel_texture.asd lib/cl-glfw-opengl-sgis_point_parameters.asd lib/cl-glfw-opengl-sgis_sharpen_texture.asd lib/cl-glfw-opengl-sgis_texture4d.asd lib/cl-glfw-opengl-sgis_texture_color_mask.asd lib/cl-glfw-opengl-sgis_texture_filter4.asd lib/cl-glfw-opengl-sgis_texture_select.asd lib/cl-glfw-opengl-sgix_async.asd lib/cl-glfw-opengl-sgix_depth_texture.asd lib/cl-glfw-opengl-sgix_flush_raster.asd lib/cl-glfw-opengl-sgix_fog_scale.asd lib/cl-glfw-opengl-sgix_fragment_lighting.asd lib/cl-glfw-opengl-sgix_framezoom.asd lib/cl-glfw-opengl-sgix_igloo_interface.asd lib/cl-glfw-opengl-sgix_instruments.asd lib/cl-glfw-opengl-sgix_line_quality_hint.asd lib/cl-glfw-opengl-sgix_list_priority.asd lib/cl-glfw-opengl-sgix_pixel_texture.asd lib/cl-glfw-opengl-sgix_polynomial_ffd.asd lib/cl-glfw-opengl-sgix_reference_plane.asd lib/cl-glfw-opengl-sgix_resample.asd lib/cl-glfw-opengl-sgix_scalebias_hint.asd lib/cl-glfw-opengl-sgix_shadow.asd lib/cl-glfw-opengl-sgix_shadow_ambient.asd lib/cl-glfw-opengl-sgix_slim.asd lib/cl-glfw-opengl-sgix_sprite.asd lib/cl-glfw-opengl-sgix_tag_sample_buffer.asd lib/cl-glfw-opengl-sgix_texture_coordinate_clamp.asd lib/cl-glfw-opengl-sgix_texture_lod_bias.asd lib/cl-glfw-opengl-sgix_texture_multi_buffer.asd lib/cl-glfw-opengl-sgix_ycrcba.asd lib/cl-glfw-opengl-sun_convolution_border_modes.asd lib/cl-glfw-opengl-sun_global_alpha.asd lib/cl-glfw-opengl-sun_mesh_array.asd lib/cl-glfw-opengl-sun_slice_accum.asd lib/cl-glfw-opengl-sun_triangle_list.asd lib/cl-glfw-opengl-sun_vertex.asd lib/cl-glfw-opengl-sunx_constant_data.asd lib/cl-glfw-opengl-win_phong_shading.asd lib/cl-glfw-opengl-win_specular_fog.asd +cl-glfw3 http://beta.quicklisp.org/archive/cl-glfw3/2019-07-10/cl-glfw3-20190710-git.tgz 13946 461eab74ffca4736d99436c73c1c54ad 5dd78157e4f4dc51ba4b9e206aaa9c4bf90c8a9f cl-glfw3-20190710-git cl-glfw3-examples.asd cl-glfw3.asd +cl-gobject-introspection http://beta.quicklisp.org/archive/cl-gobject-introspection/2019-11-30/cl-gobject-introspection-20191130-git.tgz 43736 c590518bb6bfa148e3eb58fe999f92a6 9850965e0bfced4f7cb2f8a1ac0b29fb318043e8 cl-gobject-introspection-20191130-git cl-gobject-introspection.asd +cl-gopher http://beta.quicklisp.org/archive/cl-gopher/2018-07-11/cl-gopher-20180711-git.tgz 10415 44843a10189c3f1b5ac6707512d1ab00 ba36371f358918f0724384537577da53ad71d657 cl-gopher-20180711-git cl-gopher.asd +cl-gpio http://beta.quicklisp.org/archive/cl-gpio/2019-07-10/cl-gpio-20190710-git.tgz 9091 1b490421fce75d573674f59e131a77c2 c69382364c82981b1eda62b5a7b8891e10824237 cl-gpio-20190710-git cl-gpio.asd +cl-grace http://beta.quicklisp.org/archive/cl-grace/2019-03-07/cl-grace-20190307-hg.tgz 13889 b703be6d2cbc1e7673cc5365ef213d08 839ba4127931baa62e6093d9ac15927fad413757 cl-grace-20190307-hg cl-grace.asd +cl-graph http://beta.quicklisp.org/archive/cl-graph/2017-12-27/cl-graph-20171227-git.tgz 60626 b133594d59ade148c07ad6fdec4cbdf6 2163417e2d2d61b2ad9d7c4eac1298d33573cdeb cl-graph-20171227-git cl-graph+hu.dwim.graphviz.asd cl-graph.asd +cl-gravatar http://beta.quicklisp.org/archive/cl-gravatar/2011-03-20/cl-gravatar-20110320-git.tgz 2127 6d4e5c83f238a7c301a572ddc926ef9b ae2e3b442465a3395c5f7d0948346bcd9562664e cl-gravatar-20110320-git gravatar.asd +cl-graylog http://beta.quicklisp.org/archive/cl-graylog/2018-04-30/cl-graylog-20180430-git.tgz 3582 4a821f6c2a6496f3fa7fefb4052186d5 5aa806c058074da350fd0208d5049bf1d4b1e4b9 cl-graylog-20180430-git graylog-log5.asd graylog.asd +cl-grnm http://beta.quicklisp.org/archive/cl-grnm/2018-01-31/cl-grnm-20180131-git.tgz 9511 9442e2489cf6894f4e61f9ec610d5c04 0609e0ac48299f120f71c2b86b7fec1f14897a08 cl-grnm-20180131-git cl-grnm.asd +cl-groupby http://beta.quicklisp.org/archive/cl-groupby/2017-08-30/cl-groupby-20170830-git.tgz 4240 5eab5f4784f0a154087daa7aa0caa930 9d7699457042096e05968c011013ad27b9271613 cl-groupby-20170830-git groupby.asd +cl-growl http://beta.quicklisp.org/archive/cl-growl/2016-12-08/cl-growl-20161208-git.tgz 9956 2a99024043323daf84837ae36fb89b2c 6dd1dfb8cec367fe2602a0b2b1bbaff83130f86c cl-growl-20161208-git cl-growl.asd +cl-gss http://beta.quicklisp.org/archive/cl-gss/2018-02-28/cl-gss-20180228-git.tgz 11188 62e9ab1eb233059a0b7f2276a95814d0 23537f4151f9472047e0725bd9e1f2899e766088 cl-gss-20180228-git cl-gss.asd +cl-gtk2 http://beta.quicklisp.org/archive/cl-gtk2/2012-09-09/cl-gtk2-20120909-git.tgz 377784 c61a7112e72154bf151b55d7ad6d93aa a5dc2aafc070b34b1ab09fdcd59dfed9ddd7b9c0 cl-gtk2-20120909-git cairo/cl-gtk2-cairo.asd gdk/cl-gtk2-gdk.asd glib/cl-gtk2-glib.asd gtk/cl-gtk2-gtk.asd pango/cl-gtk2-pango.asd +cl-hamcrest http://beta.quicklisp.org/archive/cl-hamcrest/2019-10-07/cl-hamcrest-20191007-git.tgz 26134 16b76ac7551db1a1567f511e3658890e f422c740a9c76af725d4235aceda909dc5cf675b cl-hamcrest-20191007-git hamcrest.asd +cl-haml http://beta.quicklisp.org/archive/cl-haml/2018-02-28/cl-haml-20180228-git.tgz 17830 0cc73c605a2f182eec47b645ace67498 474bdbb68dfaea7ffefd3396a6b1c14c63ecdfcb cl-haml-20180228-git cl-haml.asd +cl-hamt http://beta.quicklisp.org/archive/cl-hamt/2017-01-24/cl-hamt-20170124-git.tgz 12778 9b2e57f635917514c9a1f442023754ce 8f8ecbfb85c6c3f81b9f7490fc1ab867a18b8555 cl-hamt-20170124-git cl-hamt-examples.asd cl-hamt-test.asd cl-hamt.asd +cl-hash-table-destructuring http://beta.quicklisp.org/archive/cl-hash-table-destructuring/2016-05-31/cl-hash-table-destructuring-20160531-git.tgz 2604 05fb57c755f09ec4f2f5933fdaaedd4c 40d1d6441dd49fb7c51896d5f518d1addf4d2b7c cl-hash-table-destructuring-20160531-git cl-hash-table-destructuring.asd +cl-hash-util http://beta.quicklisp.org/archive/cl-hash-util/2019-01-07/cl-hash-util-20190107-git.tgz 7291 ff5044132c9684cf49f8b841096c67a2 c39b42dde00c70c608089c1c58c958bf46d152e9 cl-hash-util-20190107-git cl-hash-util-test.asd cl-hash-util.asd +cl-heap http://beta.quicklisp.org/archive/cl-heap/2013-03-12/cl-heap-0.1.6.tgz 26979 a12d71f7bbe22d6acdcc7cf36fb907b0 defa03668605e5a14a0431715adf2febf0aaa65a cl-heap-0.1.6 cl-heap-tests.asd cl-heap.asd +cl-heredoc http://beta.quicklisp.org/archive/cl-heredoc/2010-10-06/cl-heredoc-20101006-git.tgz 17070 122bfa8d85735a7ab83d26d827d83bf5 968e336ddb0fa28cbd963cea118e499a9b651c2a cl-heredoc-20101006-git cl-heredoc-test.asd cl-heredoc.asd +cl-html-diff http://beta.quicklisp.org/archive/cl-html-diff/2013-01-28/cl-html-diff-20130128-git.tgz 4134 70f93e60e968dad9a44ede60856dc343 62480247479faf7bad6c1bbd4f4135ac2485694e cl-html-diff-20130128-git cl-html-diff.asd +cl-html-parse http://beta.quicklisp.org/archive/cl-html-parse/2016-10-31/cl-html-parse-20161031-git.tgz 23507 7fe933c461eaf2dd442da189d6827a72 8dfd0cb5cebd248d33791d558e527c83c50bccbe cl-html-parse-20161031-git cl-html-parse.asd +cl-html5-parser http://beta.quicklisp.org/archive/cl-html5-parser/2019-05-21/cl-html5-parser-20190521-git.tgz 192746 149e5609d0a96c867fac6c22693c5e30 4b9882d952d5cf90ce0c874e0b134a04db64d0a4 cl-html5-parser-20190521-git cl-html5-parser.asd cxml/cl-html5-parser-cxml.asd tests/cl-html5-parser-tests.asd +cl-htmlprag http://beta.quicklisp.org/archive/cl-htmlprag/2016-06-28/cl-htmlprag-20160628-git.tgz 41128 8232a485fcb90e422bca541c4e81c263 3a1eb22bd66998acf5eb018237f4a85e0935d6c8 cl-htmlprag-20160628-git cl-htmlprag.asd +cl-httpsqs http://beta.quicklisp.org/archive/cl-httpsqs/2018-02-28/cl-httpsqs-20180228-git.tgz 2303 4ed58c978ada913cbff3fffa002f15eb 446c6bd9937ed987e9ed7bd0023b44512cb462c8 cl-httpsqs-20180228-git cl-httpsqs.asd +cl-hue http://beta.quicklisp.org/archive/cl-hue/2015-01-13/cl-hue-20150113-git.tgz 2734 c5703adb29241896c35f365be6470811 51c697d52abb18f0a370c50c7d9e83cf8d84c43a cl-hue-20150113-git cl-hue.asd +cl-i18n http://beta.quicklisp.org/archive/cl-i18n/2019-11-30/cl-i18n-20191130-git.tgz 50429 7e5d72d378b6585e8a516bb0361fcca7 a18e556f224065d061d239312633817dead01e55 cl-i18n-20191130-git cl-i18n.asd +cl-iconv http://beta.quicklisp.org/archive/cl-iconv/2017-12-27/cl-iconv-20171227-git.tgz 4909 3b6bccf9f50224194d2d0910cd563a6a 3509872d765d9d3a7557cecaa8fadd804f46fc4c cl-iconv-20171227-git iconv.asd +cl-inflector http://beta.quicklisp.org/archive/cl-inflector/2015-01-13/cl-inflector-20150113-git.tgz 6368 8563dd864200dc23b64648581ccec94f 7ef99cde744b4c4645bac4ea440fc1f2a709fdee cl-inflector-20150113-git cl-inflector.asd +cl-influxdb http://beta.quicklisp.org/archive/cl-influxdb/2018-01-31/cl-influxdb-20180131-git.tgz 15600 a34f8d1f70690f6c19465f9bd65f491c 8eb53449dbba61449beec84d34dcc989b06dd5a3 cl-influxdb-20180131-git cl-influxdb.asd +cl-inotify http://beta.quicklisp.org/archive/cl-inotify/2019-07-10/cl-inotify-20190710-git.tgz 11673 ab48770091489a0f6e177bdfb3794570 44417b941f8a79fd8dac1983cc27f8c8ca33637e cl-inotify-20190710-git cl-inotify-tests.asd cl-inotify.asd +cl-intbytes http://beta.quicklisp.org/archive/cl-intbytes/2015-09-23/cl-intbytes-20150923-git.tgz 3789 690cdfa2b0bc4829eeb1f8606291f0f5 f2a1bf6b3052fbd84755e3589d3370511f86b05c cl-intbytes-20150923-git cl-intbytes-test.asd cl-intbytes.asd +cl-interpol http://beta.quicklisp.org/archive/cl-interpol/2018-07-11/cl-interpol-20180711-git.tgz 43436 b2d6893ef703c5b6e5736fa33ba0794e a82431c7ecb6a7c73f2ba9d4d18e23f65d0e3d0b cl-interpol-20180711-git cl-interpol.asd +cl-ipfs-api2 http://beta.quicklisp.org/archive/cl-ipfs-api2/2019-08-13/cl-ipfs-api2-20190813-git.tgz 24730 90d1fdab8a26af11a2b561ce2e7c4177 b63e9d46ae949100396d31c989bf26bcba0fe805 cl-ipfs-api2-20190813-git cl-ipfs-api2.asd +cl-irc http://beta.quicklisp.org/archive/cl-irc/2015-09-23/cl-irc-0.9.2.tgz 921763 73e8ba73d8e4222cec427704c1a6aabd 8f0bf062ea520bfb6e4b0a0395c85c4250425cfb cl-irc-0.9.2 cl-irc.asd test/cl-irc-test.asd +cl-irregsexp http://beta.quicklisp.org/archive/cl-irregsexp/2016-08-25/cl-irregsexp-20160825-git.tgz 21596 717edf273168ca0ca638dcb8721ce4ac 40dd190eaf28eea03b2208469408590b390d07c2 cl-irregsexp-20160825-git cl-irregsexp.asd +cl-isaac http://beta.quicklisp.org/archive/cl-isaac/2015-08-04/cl-isaac-20150804-git.tgz 8731 03beb7c110fa638fa32c4afcb5a9d604 b879c74b9584ad644172e6cc616d159682e71029 cl-isaac-20150804-git cl-isaac.asd +cl-iterative http://beta.quicklisp.org/archive/cl-iterative/2016-03-18/cl-iterative-20160318-git.tgz 8987 7fc7c0e9e4451fc95b57db27e2e42f2c 85c5a21c03dc6e5c88bc3c9a2c1ece9731732a91 cl-iterative-20160318-git cl-iterative-tests.asd cl-iterative.asd +cl-itertools http://beta.quicklisp.org/archive/cl-itertools/2016-04-21/cl-itertools-20160421-git.tgz 6199 03577f82ecdbba2ed0977237a06c0017 97812f1df7ea506f413fee176e6897c85962a1bd cl-itertools-20160421-git cl-itertools.asd +cl-ixf http://beta.quicklisp.org/archive/cl-ixf/2018-02-28/cl-ixf-20180228-git.tgz 8677 23732795aa317d24c1a40cc321a0e394 7b99b33ef1a21049bc8eac1245f1d87fb38f98ea cl-ixf-20180228-git ixf.asd +cl-jpeg http://beta.quicklisp.org/archive/cl-jpeg/2017-06-30/cl-jpeg-20170630-git.tgz 25088 b6eb4ca5d893f428b5bbe46cd49f76ad 1e8f15736d3c038aae73b8283c5d13b50e23bdd0 cl-jpeg-20170630-git cl-jpeg.asd +cl-jpl-util http://beta.quicklisp.org/archive/cl-jpl-util/2015-10-31/cl-jpl-util-20151031-git.tgz 36026 e294bedace729724873e7633b8265a00 0d6d0d8d68c636de34c02e5b0f15b34758e50ac5 cl-jpl-util-20151031-git jpl-util.asd +cl-json http://beta.quicklisp.org/archive/cl-json/2014-12-17/cl-json-20141217-git.tgz 61399 9d873fa462b93c76d90642d8e3fb4881 a506ef6a9ce15a1b58b4d7fbeb9fd774e24008e2 cl-json-20141217-git cl-json.asd +cl-json-helper http://beta.quicklisp.org/archive/cl-json-helper/2018-12-10/cl-json-helper-20181210-git.tgz 2779 a681ca1edff40c68c65e2a6f4457ac01 38cfe3a53def3c09c9b013bc09a9b0c18577f24a cl-json-helper-20181210-git cl-json-helper.asd +cl-json-pointer http://beta.quicklisp.org/archive/cl-json-pointer/2019-05-21/cl-json-pointer-20190521-git.tgz 19712 927b20d2d60149978be02451a1245273 b582db7176bfda8f66bdd42007e7e21451defbaf cl-json-pointer-20190521-git cl-json-pointer.asd +cl-json-template http://beta.quicklisp.org/archive/cl-json-template/2017-06-30/cl-json-template-20170630-git.tgz 12106 cff23f61f7f349c6e9059e4083d95826 6b7435913677413c99e291886a0fab904128c2f9 cl-json-template-20170630-git json-template.asd +cl-jsx http://beta.quicklisp.org/archive/cl-jsx/2016-02-08/cl-jsx-20160208-git.tgz 6265 4e93808606526155d02fd3262e84e8bb 3e7d40b520e361bd8bc2dcd4c6e1fd92c3933672 cl-jsx-20160208-git cl-jsx-test.asd cl-jsx.asd +cl-junit-xml http://beta.quicklisp.org/archive/cl-junit-xml/2015-01-13/cl-junit-xml-20150113-git.tgz 5173 2a8e063e7431b6380ef6a6d268075af3 3d075953049523bb9b6071878607f59344201121 cl-junit-xml-20150113-git cl-junit-xml.asd cl-junit-xml.lisp-unit.asd cl-junit-xml.lisp-unit2.asd +cl-just-getopt-parser http://beta.quicklisp.org/archive/cl-just-getopt-parser/2019-07-10/cl-just-getopt-parser-20190710-git.tgz 7347 64419b6018a5f8012f7bc9445b2c1e8b 290fb2f9c52cf26680af825d1ab6866f22bafd9a cl-just-getopt-parser-20190710-git just-getopt-parser.asd +cl-k8055 http://beta.quicklisp.org/archive/cl-k8055/2019-07-10/cl-k8055-20190710-git.tgz 32114 4038e38dfb899c604beb50682fc85ace c20da9e467984ec6a920f95d12e1d60b1dcfb322 cl-k8055-20190710-git cl-k8055.asd +cl-kanren http://beta.quicklisp.org/archive/cl-kanren/2019-10-07/cl-kanren-20191007-git.tgz 12189 c6a29b570ac5047d4c5b1eb05a9f3b34 f11814e7348abcc947e9f22cfba4974d1277b691 cl-kanren-20191007-git cl-kanren.asd tests/cl-kanren-test.asd +cl-kanren-trs http://beta.quicklisp.org/archive/cl-kanren-trs/2012-03-05/cl-kanren-trs-20120305-svn.tgz 11024 7be1f8c2a6b396bf2403a51d9f5cd4b2 76bc8c61f0425273e137925aa278072284d5f6ef cl-kanren-trs-20120305-svn cl-kanren-trs/kanren-trs.asd cl-kanren-trs/tests/kanren-trs-test.asd +cl-keycloak http://beta.quicklisp.org/archive/cl-keycloak/2019-07-10/cl-keycloak-20190710-git.tgz 13878 c1fd4adadecb6bb9c8db69ea2a4a731e 08895e7fe14432588a82c1920c30d1865bbe63ea cl-keycloak-20190710-git cl-keycloak.asd +cl-kraken http://beta.quicklisp.org/archive/cl-kraken/2019-12-27/cl-kraken-20191227-git.tgz 21682 80c139f50020267f7091da3ba5a13ed1 e6194ec4c88b63bd629d6e1d9af822598eec7e2a cl-kraken-20191227-git cl-kraken.asd +cl-ksuid http://beta.quicklisp.org/archive/cl-ksuid/2017-08-30/cl-ksuid-20170830-git.tgz 15810 0d6c51c80711463b0d276455fc2d4bf9 63b788ba0f5bb0d1e4c436979e4be5a053b10994 cl-ksuid-20170830-git cl-ksuid.asd +cl-kyoto-cabinet http://beta.quicklisp.org/archive/cl-kyoto-cabinet/2019-11-30/cl-kyoto-cabinet-20191130-git.tgz 11166 e9ec82383fe859240e7711142878f8fa 9921f6a8e5750dfe6c300c3e6a7ccc41543bc203 cl-kyoto-cabinet-20191130-git cl-kyoto-cabinet.asd +cl-l10n http://beta.quicklisp.org/archive/cl-l10n/2016-12-04/cl-l10n-20161204-darcs.tgz 66664 c7cb0bb584b061799abaaaf2bd65c9c5 ea99b5ca38a28b28302222f9861a8c552cac4d67 cl-l10n-20161204-darcs cl-l10n.asd +cl-l10n-cldr http://beta.quicklisp.org/archive/cl-l10n-cldr/2012-09-09/cl-l10n-cldr-20120909-darcs.tgz 3538114 466e776f2f6b931d9863e1fc4d0b514e 6b3a2e8fbf2b933e13d85fb21d87943eac67cbf8 cl-l10n-cldr-20120909-darcs cl-l10n-cldr.asd +cl-langutils http://beta.quicklisp.org/archive/cl-langutils/2012-11-25/cl-langutils-20121125-git.tgz 2482768 ba2d1e4abbc7757c135273d76e8147db 0861ac6408e69c6bb155dc62a637ede5fac467de cl-langutils-20121125-git langutils.asd +cl-las http://beta.quicklisp.org/archive/cl-las/2019-12-27/cl-las-20191227-git.tgz 11248 0fccd424456784cbdeb8285a344afb77 1cbb5f4d24ac50519fa45d180c40b052a64c2579 cl-las-20191227-git cl-las.asd +cl-lastfm http://beta.quicklisp.org/archive/cl-lastfm/2014-07-13/cl-lastfm-0.2.1.tgz 22260 2eb42fa1964fe361108aa752fe7a9089 160d3d3dce74b91fadef38768494f1785882ad5b cl-lastfm-0.2.1 cl-lastfm-test.asd cl-lastfm.asd +cl-launch http://beta.quicklisp.org/archive/cl-launch/2015-10-31/cl-launch-4.1.4.1.tgz 94539 5f3d1dc76a5c734a8fd2dba5e567f2ad e809f8f3dcbb3d0b3f239ef3ade7686005aee383 cl-launch-4.1.4.1 cl-launch.asd +cl-ledger http://beta.quicklisp.org/archive/cl-ledger/2019-08-13/cl-ledger-20190813-git.tgz 1182473 7931d6ef3b6585821388d88cfc28a40c a04ab520522307ff5c748efdd69c6744b04699d5 cl-ledger-20190813-git cl-ledger.asd +cl-lex http://beta.quicklisp.org/archive/cl-lex/2016-09-29/cl-lex-20160929-git.tgz 15959 03ca8860afad55575c8747a12e58370a 249a1fb7e5d2070536213b83e9608bcba9cd79b1 cl-lex-20160929-git cl-lex.asd +cl-lexer http://beta.quicklisp.org/archive/cl-lexer/2019-10-07/cl-lexer-20191007-git.tgz 5477 810e054e68d67b18eaa3859114b62662 e8b213a35c04e07c34ca676ee5f7919548e092e2 cl-lexer-20191007-git cl-lexer.asd +cl-libevent2 http://beta.quicklisp.org/archive/cl-libevent2/2019-01-07/cl-libevent2-20190107-git.tgz 17801 e6cf8f0a5ead1184043107ae05505309 a0f45ed59ab51638f6a3081ab21a476ad495ea5d cl-libevent2-20190107-git cl-libevent2-ssl.asd cl-libevent2.asd +cl-libfarmhash http://beta.quicklisp.org/archive/cl-libfarmhash/2016-10-31/cl-libfarmhash-20161031-git.tgz 14254 18f1d5557e8cb18a8508d5aea161c29b f6246aa6bfc3d7d6add3f2f3cabbe574341a87ae cl-libfarmhash-20161031-git cl-libfarmhash.asd +cl-libhoedown http://beta.quicklisp.org/archive/cl-libhoedown/2016-10-31/cl-libhoedown-20161031-git.tgz 6116 e3e02a0108dd00d7d3d47eb7cb8933ba 8265b5849763171d07d9132a68fdf035e1e61f7e cl-libhoedown-20161031-git cl-libhoedown.asd +cl-libiio http://beta.quicklisp.org/archive/cl-libiio/2019-11-30/cl-libiio-20191130-git.tgz 8149 cc70d023b770af0ecdfd1f9e401ee6ff 2caa1a95b175464b2447926ca089babaa7656877 cl-libiio-20191130-git cl-libiio.asd +cl-libpuzzle http://beta.quicklisp.org/archive/cl-libpuzzle/2015-06-08/cl-libpuzzle-20150608-git.tgz 2604 6721ae95e9eaaac4b5cb23403c43f67c 9515ee0dbfe8dfc9af92c36c5bdd97d2cd754c88 cl-libpuzzle-20150608-git cl-libpuzzle-test.asd cl-libpuzzle.asd +cl-libssh2 http://beta.quicklisp.org/archive/cl-libssh2/2016-05-31/cl-libssh2-20160531-git.tgz 21638 f4fdafbe1ef21b9e9c9e07dd564faacd 479298ef75e5cc50679e6eb052606b3a7ebe8df7 cl-libssh2-20160531-git libssh2.asd libssh2.test.asd +cl-libsvm http://beta.quicklisp.org/archive/cl-libsvm/2014-11-06/cl-libsvm-20141106-git.tgz 295884 bf492a44400d6817b61a3ede9ddc6ed3 91d879748fa3b12f9144a1d1d5d6a4f7080e7201 cl-libsvm-20141106-git cl-liblinear.asd cl-libsvm.asd +cl-libsvm-format http://beta.quicklisp.org/archive/cl-libsvm-format/2018-07-11/cl-libsvm-format-20180711-git.tgz 9951 bac7636204a46c66cdfa135cdd147ca6 87adb8326851e29f2c96f0a02dca122336d95520 cl-libsvm-format-20180711-git cl-libsvm-format-test.asd cl-libsvm-format.asd +cl-libusb http://beta.quicklisp.org/archive/cl-libusb/2019-12-27/cl-libusb-20191227-git.tgz 7682 22a50679b150890000f41a697b7b812e 80035e10a4396dc9582554361fbb47b8f511fbe3 cl-libusb-20191227-git cl-libusb.asd libusb-ffi.asd +cl-libuv http://beta.quicklisp.org/archive/cl-libuv/2019-01-07/cl-libuv-20190107-git.tgz 14487 c09c505dc45812cc773454ffc6fdbd38 d4b0c20548ce1bf54bc44938317f437ec8733d8f cl-libuv-20190107-git cl-libuv.asd +cl-libxml2 http://beta.quicklisp.org/archive/cl-libxml2/2013-06-15/cl-libxml2-20130615-git.tgz 55579 88317bf302b5f1d2c1ac9efa6538fbe0 75977fe851405c2d85d67ed6df8dc3462628c661 cl-libxml2-20130615-git cl-libxml2.asd xfactory.asd xoverlay.asd +cl-libyaml http://beta.quicklisp.org/archive/cl-libyaml/2017-01-24/cl-libyaml-20170124-git.tgz 9324 407d5aa53ac8132fcce4b171feaf5d39 92cfe1f703bfe40ad94a2941d5d2d72c7feceb45 cl-libyaml-20170124-git cl-libyaml-test.asd cl-libyaml.asd +cl-locale http://beta.quicklisp.org/archive/cl-locale/2015-10-31/cl-locale-20151031-git.tgz 3916 7a8fb3678938af6dc5c9fd6431428aff b5e33ecae4ad91db85d6f3ead72a52a02547fd23 cl-locale-20151031-git cl-locale-syntax.asd cl-locale-test.asd cl-locale.asd +cl-locatives http://beta.quicklisp.org/archive/cl-locatives/2019-03-07/cl-locatives-20190307-hg.tgz 2705 f7dc0d49dccf787bc27c859ede74537e 83d8f4cc9457e0d907b44ab9d1422e9f75cec721 cl-locatives-20190307-hg cl-locatives.asd +cl-log http://beta.quicklisp.org/archive/cl-log/2013-01-28/cl-log.1.0.1.tgz 18463 fb960933eb748c14adc3ccb376ac8066 79eba93cc6a981a79d95b35533063b70083c6353 cl-log.1.0.1 cl-log-test.asd cl-log.asd +cl-logic http://beta.quicklisp.org/archive/cl-logic/2014-12-17/cl-logic-20141217-git.tgz 19237 1d2c46cd6d6b22eec42b0634ee6aad02 832125e585ebc79b14bad28a34bab16dede39272 cl-logic-20141217-git cl-logic.asd +cl-ltsv http://beta.quicklisp.org/archive/cl-ltsv/2014-07-13/cl-ltsv-20140713-git.tgz 1768 b0f6141d4d431c30cd3f89ed9b915cf9 78beea35eb74ae8e22963cbe6f5e8b7e03d5a578 cl-ltsv-20140713-git cl-ltsv-test.asd cl-ltsv.asd +cl-lzlib http://beta.quicklisp.org/archive/cl-lzlib/2019-10-07/cl-lzlib-20191007-git.tgz 584416 36b2ee8fac0805527d6a215375300123 c9c2bf1198e7f6e86a47f7cefbe8ff2b2f7f10a4 cl-lzlib-20191007-git lzlib-tests.asd lzlib.asd +cl-lzma http://beta.quicklisp.org/archive/cl-lzma/2019-11-30/cl-lzma-20191130-git.tgz 391732 839b371f342610b221e8455ec0e5ab9e 2d6b69f5e810f08f2c943ed3b5a977041608e1cc cl-lzma-20191130-git cl-lzma.asd +cl-m4 http://beta.quicklisp.org/archive/cl-m4/2013-03-12/cl-m4-20130312-git.tgz 43800 1b3c29d5e7fb294f95afd4a845f4c6b4 7dbee2d1711f7b212ba1f6b9a04ac1ba873f4e31 cl-m4-20130312-git cl-m4-test.asd cl-m4.asd +cl-mango http://beta.quicklisp.org/archive/cl-mango/2019-10-07/cl-mango-20191007-git.tgz 102780 771a85df4b2b62fec50913278fa6f27c 04487c9de38a8ef467c187e2506d5ea040b4c637 cl-mango-20191007-git cl-mango.asd +cl-markdown http://beta.quicklisp.org/archive/cl-markdown/2019-12-27/cl-markdown-20191227-git.tgz 73424 630fdb2615d0c7cd7b31a5d6295ae552 eebe40f532720a42422ecfca77bbb2ef60ecfe19 cl-markdown-20191227-git cl-markdown-comparisons.asd cl-markdown-test.asd cl-markdown.asd +cl-markless http://beta.quicklisp.org/archive/cl-markless/2019-10-07/cl-markless-20191007-git.tgz 73880 e9593b82942910bed2449495b7705323 6b690ae311a74c7f29f71abe87406a422633a291 cl-markless-20191007-git cl-markless-test.asd cl-markless.asd epub/cl-markless-epub.asd markdown/cl-markless-markdown.asd plump/cl-markless-plump.asd standalone/cl-markless-standalone.asd +cl-marklogic http://beta.quicklisp.org/archive/cl-marklogic/2017-04-03/cl-marklogic-20170403-git.tgz 1817555 a68c384b84563fa4d6f330ba6a02fb10 f32bfb51893fd300a1472b4891b86f4dbfe6bd7b cl-marklogic-20170403-git cl-marklogic.asd subsystem/ml-dsl/ml-dsl.asd subsystem/ml-optimizer/ml-optimizer.asd subsystem/ml-test/ml-test.asd +cl-markup http://beta.quicklisp.org/archive/cl-markup/2013-10-03/cl-markup-20131003-git.tgz 5785 3ec36b8e15435933f614959032987848 6aa4346b3ea4f1113934de898307229892252b12 cl-markup-20131003-git cl-markup-test.asd cl-markup.asd +cl-marshal http://beta.quicklisp.org/archive/cl-marshal/2018-03-28/cl-marshal-20180328-git.tgz 11220 2d13dd2a276f1e63965498d10d9406ce 47bdef36e420a338139a40e92003fa5d50401695 cl-marshal-20180328-git marshal-tests.asd marshal.asd +cl-match http://beta.quicklisp.org/archive/cl-match/2012-11-25/cl-match-20121125-git.tgz 23798 790a315e08136b3e9b3a42eaadc558a4 a747badf5dabd5b345df787c4b5765ee1d7bbe78 cl-match-20121125-git cl-match-test.asd cl-match.asd pcl-unit-test.asd standard-cl.asd +cl-mathstats http://beta.quicklisp.org/archive/cl-mathstats/2014-07-13/cl-mathstats-20140713-git.tgz 82601 f42fba86de264be6d626064228d15258 f53ab8b4758c0915a3389eb9d02824d226d128ab cl-mathstats-20140713-git cl-mathstats-test.asd cl-mathstats.asd +cl-maxsat http://beta.quicklisp.org/archive/cl-maxsat/2019-12-27/cl-maxsat-20191227-git.tgz 23197 beb673cdf1be131b12e5f2a6a77cf25e 9c6675f48a41c7ba12247c064ac293affde05e65 cl-maxsat-20191227-git cl-maxsat.asd cl-maxsat.test.asd +cl-mecab http://beta.quicklisp.org/archive/cl-mecab/2018-10-18/cl-mecab-20181018-git.tgz 2767 2ab93a1f4c43bab2428e5175108169a2 785e78ddcb996dc7d517f7796063d78f853c658c cl-mecab-20181018-git cl-mecab-test.asd cl-mecab.asd +cl-mechanize http://beta.quicklisp.org/archive/cl-mechanize/2018-07-11/cl-mechanize-20180711-git.tgz 3722 232d80473f28373048d93ca69f2b67a0 bfb4e5e0fcc4181fb4ba09c65c8b21e6bdafc9cc cl-mechanize-20180711-git cl-mechanize.asd +cl-mediawiki http://beta.quicklisp.org/archive/cl-mediawiki/2016-12-04/cl-mediawiki-20161204-git.tgz 16116 25991d3a28d94bf01f7a3a9464e2c3e9 5b3f1c43c010085a50b3459daec5b6b2fe16bd8a cl-mediawiki-20161204-git cl-mediawiki-test.asd cl-mediawiki.asd +cl-memcached http://beta.quicklisp.org/archive/cl-memcached/2015-06-08/cl-memcached-20150608-git.tgz 16575 d53b92973d51e95558aafaba56942c92 694deb82afc44290d593d4ca6d1242077af14fc9 cl-memcached-20150608-git cl-memcached.asd +cl-messagepack http://beta.quicklisp.org/archive/cl-messagepack/2019-03-07/cl-messagepack-20190307-git.tgz 11449 b106e4f7fa1817f7e15a519a4fca270a b49d4e18564a2a42336dec934eafbfa6509b14e5 cl-messagepack-20190307-git cl-messagepack-tests.asd cl-messagepack.asd +cl-messagepack-rpc http://beta.quicklisp.org/archive/cl-messagepack-rpc/2017-12-27/cl-messagepack-rpc-20171227-git.tgz 11177 6de2befbdd2a7e7ee028e0f9cc82bd7f 7b4c77bdb4dad0a365868591dbd75ad1ae3d4c10 cl-messagepack-rpc-20171227-git cl-messagepack-rpc-tests.asd cl-messagepack-rpc.asd +cl-migrations http://beta.quicklisp.org/archive/cl-migrations/2011-01-10/cl-migrations-20110110-http.tgz 3843 af513b9cd5bf182bd7c0910a98107823 cb5ae65cdda19f45cee7eaf4ad1726eddd3fd794 cl-migrations-20110110-http cl-migrations.asd +cl-mime http://beta.quicklisp.org/archive/cl-mime/2016-02-08/cl-mime-20160208-git.tgz 16217 7d91fe61a9d488bf61b2cfcc40aea430 37c0cfac084fd21c6c698023eff53af23d39357f cl-mime-20160208-git cl-mime.asd +cl-mixed http://beta.quicklisp.org/archive/cl-mixed/2019-07-10/cl-mixed-20190710-git.tgz 354610 c952a3a057a5e9c8cfe789f445e9532a dc47c3a46975ea4cd5ffa33eeccc7703fcb01ab0 cl-mixed-20190710-git cl-mixed.asd +cl-mlep http://beta.quicklisp.org/archive/cl-mlep/2018-04-30/cl-mlep-20180430-git.tgz 219387 378549be18c26b35a2a928b48f20e7c6 2e4e11c788b75de49c76163fb045d0741d33747e cl-mlep-20180430-git mlep-add.asd mlep.asd +cl-mock http://beta.quicklisp.org/archive/cl-mock/2016-04-21/cl-mock-20160421-git.tgz 7754 3d38feb9aa3a7d52b38ad18ff60d8f61 19d10980f1c83730327ca2f68e873586b3870dc5 cl-mock-20160421-git cl-mock-basic.asd cl-mock-tests-basic.asd cl-mock-tests.asd cl-mock.asd +cl-modlisp http://beta.quicklisp.org/archive/cl-modlisp/2015-09-23/cl-modlisp-20150923-git.tgz 10406 95f48447065e734ddfd23a58df53679b 5f92ef72be5b0897ed4ca226adbcbe9311a458bf cl-modlisp-20150923-git modlisp.asd +cl-monad-macros http://beta.quicklisp.org/archive/cl-monad-macros/2011-06-19/cl-monad-macros-20110619-svn.tgz 29833 8bff3b40a3720242b6f8f13932dd7b9e 46a54c95c093f7c263c8963479147624b3d234fd cl-monad-macros-20110619-svn cl-monad-macros.asd +cl-moneris http://beta.quicklisp.org/archive/cl-moneris/2011-04-18/cl-moneris-20110418-git.tgz 6676 ad2527ea7e6d8618757907dd2193224a 572b40deafdbd20a759bb36bc26250f6df64c8ac cl-moneris-20110418-git cl-moneris-test.asd cl-moneris.asd +cl-mongo http://beta.quicklisp.org/archive/cl-mongo/2016-05-31/cl-mongo-20160531-git.tgz 63737 f37c70b58ebbbc36dd855356b196c9a0 65b1c29c5c6bf02f9bbd7d64a260089968c41eec cl-mongo-20160531-git cl-mongo.asd +cl-mongo-id http://beta.quicklisp.org/archive/cl-mongo-id/2018-02-28/cl-mongo-id-20180228-git.tgz 3909 7c3a41a0801e9d8c9f03ce440f8a792f 3711c34c4d1a8f4ac40f014d8400339d2f2fb77d cl-mongo-id-20180228-git cl-mongo-id.asd +cl-monitors http://beta.quicklisp.org/archive/cl-monitors/2019-07-10/cl-monitors-20190710-git.tgz 30426 1c6c7f00915b0301a44f99eb5db282fe 6cbc22dbdf2b5dff91722aa12346e35a9a91f8c9 cl-monitors-20190710-git cl-monitors.asd +cl-mop http://beta.quicklisp.org/archive/cl-mop/2015-01-13/cl-mop-20150113-git.tgz 3524 2fafd8a889b9ad8455e0451d97a60f66 b6fd23f5ff74a7343158fcb9979362f24104a670 cl-mop-20150113-git cl-mop.asd +cl-moss http://beta.quicklisp.org/archive/cl-moss/2017-10-19/cl-moss-20171019-git.tgz 15420 5a242fbf7bc9a257a163dffd37467f1b 33a67534114561c248037d59806161a3c3281a05 cl-moss-20171019-git cl-moss.asd +cl-mount-info http://beta.quicklisp.org/archive/cl-mount-info/2019-12-27/cl-mount-info-20191227-git.tgz 22410 100934867273f68e6aed9da3e709637f 99c4259aa58db89fa480eba7429578233244761d cl-mount-info-20191227-git cl-mount-info.asd +cl-mpg123 http://beta.quicklisp.org/archive/cl-mpg123/2019-07-10/cl-mpg123-20190710-git.tgz 1362662 6a816599e8260a8509e39ba7a5d331aa f598325fa9e18963b96c3d9753370054a3d81d71 cl-mpg123-20190710-git cl-mpg123-example.asd cl-mpg123.asd +cl-mpi http://beta.quicklisp.org/archive/cl-mpi/2019-07-10/cl-mpi-20190710-git.tgz 29951 084a37f38bc915e7cb446f0d659e745c 6aec00040dd9c6d789642e78799a97f93bd15de3 cl-mpi-20190710-git cl-mpi-asdf-integration.asd cl-mpi-extensions.asd cl-mpi-test-suite.asd cl-mpi.asd examples/cl-mpi-examples.asd +cl-mssql http://beta.quicklisp.org/archive/cl-mssql/2019-08-13/cl-mssql-20190813-git.tgz 15740 53dce223161f2c5e015366c6b241d713 762a80f7edb4f0af09e000c3f5ec9afff663646d cl-mssql-20190813-git mssql.asd +cl-mtgnet http://beta.quicklisp.org/archive/cl-mtgnet/2018-07-11/cl-mtgnet-20180711-git.tgz 13584 552af7cb3547102849920f639964c694 91a94bf40fb828bc3c8353ca1a17bdc53b1d4960 cl-mtgnet-20180711-git cl-mtgnet-async.asd cl-mtgnet-sync.asd cl-mtgnet.asd +cl-murmurhash http://beta.quicklisp.org/archive/cl-murmurhash/2019-12-27/cl-murmurhash-20191227-git.tgz 6973 71f7d56d247ea19fef5880f8e5f04cb9 3fa7acea151a7124d4dcfcf0573ed08bcb0f5334 cl-murmurhash-20191227-git cl-murmurhash.asd +cl-mustache http://beta.quicklisp.org/archive/cl-mustache/2015-09-23/cl-mustache-20150923-git.tgz 15598 8eaa6901f070bd04cb30aed0c87ba252 c32a2a223da7d39568cc9337153492dfb55aef91 cl-mustache-20150923-git cl-mustache-test.asd cl-mustache.asd +cl-muth http://beta.quicklisp.org/archive/cl-muth/2018-07-11/cl-muth-stable-64e722c5-git.tgz 4920 0759a5f528c77b078bc00264f803d134 99d6871946b18f992c99d14f9c6d48b15c066860 cl-muth-stable-64e722c5-git cl-muth.asd +cl-mw http://beta.quicklisp.org/archive/cl-mw/2015-04-07/cl-mw-20150407-git.tgz 89150 688397a73badb51c626bb5633cfbf9bb 4a3d5e5a5d6413396e759c0895838bc03f70b93d cl-mw-20150407-git cl-mw.asd cl-mw.examples.argument-processing.asd cl-mw.examples.hello-world.asd cl-mw.examples.higher-order.asd cl-mw.examples.monte-carlo-pi.asd cl-mw.examples.ping.asd cl-mw.examples.with-task-policy.asd +cl-mysql http://beta.quicklisp.org/archive/cl-mysql/2017-10-19/cl-mysql-20171019-git.tgz 25620 e1021da4d35cbb584d4df4f0d7e2bbb9 629d419c6d0a1ab3ebb5cb2dadeb0efbc2988564 cl-mysql-20171019-git cl-mysql-test.asd cl-mysql.asd +cl-naive-store http://beta.quicklisp.org/archive/cl-naive-store/2019-12-27/cl-naive-store-20191227-git.tgz 30052 6e45ba6f62992382b70c37ded923235b 9903789369a53dc7af5f10daa4f1c41e02c1e594 cl-naive-store-20191227-git cl-naive-store.asd data-type-defs/cl-naive-data-type-defs.asd data-types/cl-naive-data-types.asd naive-indexed/cl-naive-indexed.asd naive-items/cl-naive-items.asd tests/cl-naive-store-tests.asd +cl-ncurses http://beta.quicklisp.org/archive/cl-ncurses/2010-10-06/cl-ncurses_0.1.4.tgz 23603 60cde15b3c037f394e0c24eb55ad56f8 8d7cfd9bb56ba8c2e6f98bcb298bfc121f8d51bd cl-ncurses_0.1.4 cl-ncurses.asd +cl-neo4j http://beta.quicklisp.org/archive/cl-neo4j/2013-01-28/cl-neo4j-release-b8ad637a-git.tgz 9194 cb073877ef9a06784c7d1964e0c9266d f8a127e60e89f6a419ac4c59f4e734ce3f513258 cl-neo4j-release-b8ad637a-git cl-neo4j.asd +cl-neovim http://beta.quicklisp.org/archive/cl-neovim/2019-05-21/cl-neovim-20190521-git.tgz 28387 c74dc12e6ebcac2f55b0c5f510740734 a47dc4c6b386f74eb24f8370b14ebe489a70753c cl-neovim-20190521-git cl-neovim.asd +cl-netpbm http://beta.quicklisp.org/archive/cl-netpbm/2019-12-27/cl-netpbm-20191227-hg.tgz 406726 456baffc4d3e3cd1c96a5bfc96831c3c 31ce4b59811ce99f0b9bb3bc6a5afbaf9d491be0 cl-netpbm-20191227-hg cl-netpbm.asd +cl-netstring-plus http://beta.quicklisp.org/archive/cl-netstring-plus/2015-07-09/cl-netstring-plus-20150709-git.tgz 4433 6e8765afb3524b15982841b1351e1f8c 21e3f577bcb812b607b5a1b180e97ee8763cf6c1 cl-netstring-plus-20150709-git cl-netstring+.asd +cl-netstrings http://beta.quicklisp.org/archive/cl-netstrings/2012-10-13/cl-netstrings-20121013-git.tgz 3736 8869774ca304843bb00041d63d80ba1e 9bf9f017e4e1b95c067e38c9fdc1e6db85a1457a cl-netstrings-20121013-git cl-netstrings.asd +cl-ntp-client http://beta.quicklisp.org/archive/cl-ntp-client/2019-07-10/cl-ntp-client-20190710-git.tgz 3473 2053825ff92db3e37d533619e64045ad 6b4472231012fda91a1e99de6b8cd930636898d1 cl-ntp-client-20190710-git cl-ntp-client.asd +cl-ntriples http://beta.quicklisp.org/archive/cl-ntriples/2019-03-07/cl-ntriples-20190307-hg.tgz 6167 118afd8c0a65aad8e83e92f19e31117b e6bbc4ad2c50a998124d50ec4b8fdc8eb99f807a cl-ntriples-20190307-hg cl-ntriples.asd +cl-num-utils http://beta.quicklisp.org/archive/cl-num-utils/2013-12-11/cl-num-utils-20131211-git.tgz 64210 a715b9ef4288025bb87a0f4d259763c5 f875e1452b9a0df2729ef874fe4b041557c8905d cl-num-utils-20131211-git cl-num-utils.asd +cl-nxt http://beta.quicklisp.org/archive/cl-nxt/2015-06-08/cl-nxt-20150608-git.tgz 25121 a63efb53921dfb220e9085b7c67a989a c453129fbccbffe7dc25c77c1fe974b453d97b32 cl-nxt-20150608-git nxt-proxy.asd nxt.asd +cl-oauth http://beta.quicklisp.org/archive/cl-oauth/2015-08-04/cl-oauth-20150804-git.tgz 22871 280ca181aaf219d292dfcc5795d68b01 b2dcc9fde0faa4a38dc07d20f523182e0d6ccb21 cl-oauth-20150804-git cl-oauth.asd +cl-oclapi http://beta.quicklisp.org/archive/cl-oclapi/2018-08-31/cl-oclapi-20180831-git.tgz 17154 e80585c65e677f1ad10c5ae6b10879fd 1e73f38e41e931301d229a751cb8eb7e7bd2e27b cl-oclapi-20180831-git cl-oclapi-test.asd cl-oclapi.asd +cl-octet-streams http://beta.quicklisp.org/archive/cl-octet-streams/2018-03-28/cl-octet-streams-20180328-git.tgz 16943 70aa3af68ea8ffa0d69312260f5e5287 5aaf8f807b502d33706fa0f5318cd8fa19a0e1b7 cl-octet-streams-20180328-git cl-octet-streams.asd +cl-ode http://beta.quicklisp.org/archive/cl-ode/2016-06-28/cl-ode-20160628-git.tgz 10617 21c1ba1c91b5910a201cfb824c45fbf0 756649c7ff0912184bb0fa7c8a7e6abafc20273e cl-ode-20160628-git cl-ode.asd +cl-odesk http://beta.quicklisp.org/archive/cl-odesk/2015-06-08/cl-odesk-20150608-git.tgz 6930 e19a70b04c5f7204d46b7bd33a14e054 ab5f306a08b087e175dfe6389e1634444e147adb cl-odesk-20150608-git odesk.asd +cl-ohm http://beta.quicklisp.org/archive/cl-ohm/2018-02-28/cl-ohm-20180228-git.tgz 18129 988fa480a9196cd349782dfefb91b173 e18484324b8fdb9c372d0ad9aa3ebd150c328ec7 cl-ohm-20180228-git cl-ohm.asd +cl-olefs http://beta.quicklisp.org/archive/cl-olefs/2015-07-09/cl-olefs-20150709-git.tgz 21367 e2051eb090625ecf6ef295bbee5e3f65 7dd0fb6d14d42fdb4d3f331c1f15770d8277eda4 cl-olefs-20150709-git cl-olefs.asd +cl-one-time-passwords http://beta.quicklisp.org/archive/cl-one-time-passwords/2017-10-19/cl-one-time-passwords-20171019-git.tgz 4901 c565262b547110b1d5528671483a6166 4b5b6788ed4c8c3b80d1d573779dfff638a30c9a cl-one-time-passwords-20171019-git cl-one-time-passwords-test.asd cl-one-time-passwords.asd +cl-online-learning http://beta.quicklisp.org/archive/cl-online-learning/2019-12-27/cl-online-learning-20191227-git.tgz 47081 8c6d99b9550ce542482229b43d8ac610 0e8108d5f5263a6482b1b94bbec46c661a6daadd cl-online-learning-20191227-git cl-online-learning-test.asd cl-online-learning.asd +cl-openal http://beta.quicklisp.org/archive/cl-openal/2015-03-02/cl-openal-20150302-git.tgz 10197 f85c83d057edf2f6273b0d9f89adfde9 6e4d3ead3768a92da6ab01cc41b88e54c37d7172 cl-openal-20150302-git cl-alc.asd cl-alut.asd cl-openal-examples.asd cl-openal.asd +cl-opengl http://beta.quicklisp.org/archive/cl-opengl/2019-11-30/cl-opengl-20191130-git.tgz 439215 c5387f051960e9179b2ed32fafb67e72 12c358b808eb731ea8519ef6bed602c3c7438cfa cl-opengl-20191130-git cl-glu.asd cl-glut-examples.asd cl-glut.asd cl-opengl.asd +cl-openstack-client http://beta.quicklisp.org/archive/cl-openstack-client/2019-10-07/cl-openstack-client-20191007-git.tgz 15217 21d5f62c63d36ec3b51bac01be54122c ac507feb7962ce6654e7c434f8abd3bfd59edad1 cl-openstack-client-20191007-git cl-openstack-client-test.asd cl-openstack-client.asd +cl-opsresearch http://beta.quicklisp.org/archive/cl-opsresearch/2017-04-03/cl-opsresearch-20170403-git.tgz 169006 3f9d2d4fa2e5bd0bd262c3e7d8473933 d5ec56c8385fdecddd862753f1941f476b6c4797 cl-opsresearch-20170403-git cl-opsresearch.asd subsystem/or-cluster/or-cluster.asd subsystem/or-fann/or-fann.asd subsystem/or-glpk/or-glpk.asd subsystem/or-gsl/or-gsl.asd subsystem/or-test/or-test.asd +cl-org-mode http://beta.quicklisp.org/archive/cl-org-mode/2010-12-07/cl-org-mode-20101207-git.tgz 16460 f4220fc89b86010c37f682b937e48758 4bb1c14e15eaacc107bbf539fc308766cd8f90d0 cl-org-mode-20101207-git cl-org-mode.asd +cl-out123 http://beta.quicklisp.org/archive/cl-out123/2019-07-10/cl-out123-20190710-git.tgz 793012 fe497cc028c073c1b28390c704a98e56 13f4bf99dd9d41f7f326f39c7d2acf561fc63b40 cl-out123-20190710-git cl-out123.asd +cl-pack http://beta.quicklisp.org/archive/cl-pack/2018-04-30/cl-pack-20180430-git.tgz 13791 cb9f9b4929d4d175316b3f3c7f0bff64 d9740ef0fe2d1dc2cd1897511e0b83cc8aac1e9c cl-pack-20180430-git cl-pack.asd +cl-package-locks http://beta.quicklisp.org/archive/cl-package-locks/2011-12-03/cl-package-locks-20111203-git.tgz 3225 27ed43ed35ef89c3b1d7c5b2594f854c 1cb55bc796f5325a251868413e66a915596477cb cl-package-locks-20111203-git cl-package-locks.asd +cl-pango http://beta.quicklisp.org/archive/cl-pango/2017-04-03/cl-pango-20170403-git.tgz 14796 3a55e08abc5f99a853b80c835edb868d 3a8f8780b761e9f58b803a743928c98741be4a4c cl-pango-20170403-git cl-pango.asd +cl-parallel http://beta.quicklisp.org/archive/cl-parallel/2013-03-12/cl-parallel-20130312-git.tgz 3888 246f314b0ffa627a311e775b00dd0b65 b1d4c6defe936a70b5a9bbe431e94c65f8d0c023 cl-parallel-20130312-git cl-parallel.asd +cl-parser-combinators http://beta.quicklisp.org/archive/cl-parser-combinators/2013-11-11/cl-parser-combinators-20131111-git.tgz 36429 25ad9b1459901738a6394422a41b8fec a708a8b6996a18c3aed1d9d909f9c52477c72fba cl-parser-combinators-20131111-git parser-combinators-cl-ppcre.asd parser-combinators-debug.asd parser-combinators-tests.asd parser-combinators.asd +cl-pass http://beta.quicklisp.org/archive/cl-pass/2018-02-28/cl-pass-20180228-git.tgz 2758 feb6fe90104a78686b6255ed8f88c3ed 20e7a18ffafe8683aa0a00f0cbd07b6b925fe29a cl-pass-20180228-git cl-pass-test.asd cl-pass.asd +cl-password-store http://beta.quicklisp.org/archive/cl-password-store/2018-02-28/cl-password-store-20180228-git.tgz 19029 77cc428e880cd136d7c2c0fe279ee90c 3ebe2c16fb1b89913040e2a21c10319ef959b335 cl-password-store-20180228-git cl-password-store.asd +cl-pattern http://beta.quicklisp.org/archive/cl-pattern/2014-07-13/cl-pattern-20140713-git.tgz 5143 cf8e74def535c66a358df1ada9d89785 cab8b56cdf63e359614d33840ef2faa539b351f3 cl-pattern-20140713-git cl-pattern-benchmark.asd cl-pattern.asd +cl-patterns http://beta.quicklisp.org/archive/cl-patterns/2019-12-27/cl-patterns-20191227-git.tgz 95628 a5aacb40f62573d42220d44e67b95a3b cf180356d08ad0ea68c6863ed997884a27c4d0f5 cl-patterns-20191227-git cl-patterns.asd +cl-paymill http://beta.quicklisp.org/archive/cl-paymill/2013-11-11/cl-paymill-20131111-git.tgz 7224 1c240a7da7b22b55d16f7e6922191aa9 95e9052fb40ff1dbbf7925287e1e4f1409198e7a cl-paymill-20131111-git cl-paymill.asd +cl-paypal http://beta.quicklisp.org/archive/cl-paypal/2010-10-06/cl-paypal-20101006-git.tgz 1701376 b24dd8ccbdb60e1dd220076d8a5baa4d 9cf3a3bba7d5ff0feea25875639f6728ac5b2d6a cl-paypal-20101006-git cl-paypal.asd +cl-pcg http://beta.quicklisp.org/archive/cl-pcg/2019-12-27/cl-pcg-20191227-git.tgz 11396 49d212680e99f7bcd2c76dbaa3fa2aab 0834c4cfec434c4d5e04b7590a5e2e1d8981d3ec cl-pcg-20191227-git cl-pcg.asd cl-pcg.test.asd +cl-pdf http://beta.quicklisp.org/archive/cl-pdf/2019-10-07/cl-pdf-20191007-git.tgz 477591 edde2f2da08ec10be65364737ed5fa5c f3740ece395f03b06e573054353d9ef7db6041dc cl-pdf-20191007-git cl-pdf-parser.asd cl-pdf.asd +cl-performance-tuning-helper http://beta.quicklisp.org/archive/cl-performance-tuning-helper/2013-06-15/cl-performance-tuning-helper-20130615-git.tgz 3639 79f43c12d4c35fc6ae10d28467fa5318 2ef8321821c30635eb0eedee03d9cba474b2f2c3 cl-performance-tuning-helper-20130615-git cl-performance-tuning-helper-test.asd cl-performance-tuning-helper.asd +cl-permutation http://beta.quicklisp.org/archive/cl-permutation/2019-10-07/cl-permutation-20191007-git.tgz 59069 bc3408a44f85fc6427c1b70f21015d87 fee0ab3a41141b552e98fad21654819852fc2ea3 cl-permutation-20191007-git cl-permutation-examples.asd cl-permutation-tests.asd cl-permutation.asd +cl-photo http://beta.quicklisp.org/archive/cl-photo/2015-09-23/cl-photo-20150923-git.tgz 12618 1cdf69f41104fcfb0a4ae99a01023148 16a6d27a0e01fc224be9741fb6dd4f0d4a568ef3 cl-photo-20150923-git cl-photo-tests.asd cl-photo.asd +cl-piglow http://beta.quicklisp.org/archive/cl-piglow/2019-12-27/cl-piglow-20191227-git.tgz 6186 2224abe7e444cbc90e6543165635a650 a58791224824666be3dabf06be83d257fa32ac7a cl-piglow-20191227-git cl-piglow.asd +cl-pixman http://beta.quicklisp.org/archive/cl-pixman/2017-08-30/cl-pixman-20170830-git.tgz 11694 5c0938bdf43ebe65574e446b47353e33 77f127fb3a0e55b4814a9796390070c86cc9ee94 cl-pixman-20170830-git pixman.asd +cl-plplot http://beta.quicklisp.org/archive/cl-plplot/2018-02-28/cl-plplot-20180228-git.tgz 289049 e4ac142b064ed3b20bdedd18c602e2c7 21da728b21572839150f71995713c7d54690bd70 cl-plplot-20180228-git cl-plplot.asd +cl-plumbing http://beta.quicklisp.org/archive/cl-plumbing/2018-10-18/cl-plumbing-20181018-git.tgz 3296 835188b1879ae9ad323bafb9cca36c0f fe1c2c004ee5f93822ecb669486ab9c5d6137c88 cl-plumbing-20181018-git cl-plumbing-test.asd cl-plumbing.asd +cl-ply http://beta.quicklisp.org/archive/cl-ply/2015-05-05/cl-ply-20150505-git.tgz 5845 54d8a7725a43455cd4d49ad6e2f1552b 16e20f501dd49b7c965542ee799b6e17c285fdfd cl-ply-20150505-git cl-ply-test.asd cl-ply.asd +cl-png http://beta.quicklisp.org/archive/cl-png/2019-07-10/cl-png-vl-anyversion-04dbb706-git.tgz 8510528 3bff5677a5fb7eecdb348b0f5ad3b2f9 f90b5c9d8b9b75e30872a4139e98687ade71be83 cl-png-vl-anyversion-04dbb706-git png.asd test/bmp-test.asd test/image-test.asd test/ops-test.asd test/png-test.asd +cl-poker-eval http://beta.quicklisp.org/archive/cl-poker-eval/2015-08-04/cl-poker-eval-20150804-git.tgz 15226 7771236a5bda08d88c85a4e33f30047d 5f1611423e82f6132b0ecbc1286f88083642566f cl-poker-eval-20150804-git cl-poker-eval.asd +cl-pop http://beta.quicklisp.org/archive/cl-pop/2011-04-18/cl-pop-20110418-http.tgz 50142 95c0c3418f4740938467514787857bf7 2f413630bb3a0bd507e7a6314f7063f8415c64eb cl-pop-20110418-http cl-pop.asd +cl-portaudio http://beta.quicklisp.org/archive/cl-portaudio/2017-12-27/cl-portaudio-20171227-git.tgz 262470 8a6c175dace75c13eea2378746e6f610 525f6d244842268db1ca65954d57d98854a04c7a cl-portaudio-20171227-git cl-portaudio.asd +cl-portmanteau http://beta.quicklisp.org/archive/cl-portmanteau/2018-10-18/cl-portmanteau-20181018-git.tgz 4041 69dc35a5efd5a58644a86291f114d0ae 1873a59021da676c57cb60a8624ca62231445ab4 cl-portmanteau-20181018-git portmanteau-tests.asd portmanteau.asd +cl-postgres-datetime http://beta.quicklisp.org/archive/cl-postgres-datetime/2019-05-21/cl-postgres-datetime-20190521-git.tgz 2835 2a8346142cf960438f21504a76b48f14 45becc2cce71b8582c605e5727c51f650d3fdf11 cl-postgres-datetime-20190521-git cl-postgres-datetime.asd +cl-postgres-plus-uuid http://beta.quicklisp.org/archive/cl-postgres-plus-uuid/2018-10-18/cl-postgres-plus-uuid-20181018-git.tgz 2270 2fe4f3d80a987192c303695d8629f522 4ca2391fa2cf146d789969453d066da82962af5d cl-postgres-plus-uuid-20181018-git cl-postgres-plus-uuid.asd +cl-ppcre http://beta.quicklisp.org/archive/cl-ppcre/2019-05-21/cl-ppcre-20190521-git.tgz 155009 a980b75c1b386b49bcb28107991eb4ec d6593d8f842bcf6af810ff93c6c02b757bd49ecf cl-ppcre-20190521-git cl-ppcre-unicode.asd cl-ppcre.asd +cl-prevalence http://beta.quicklisp.org/archive/cl-prevalence/2019-11-30/cl-prevalence-20191130-git.tgz 21174 7615cb79ec797a5520941aedc3101390 17538f96a0b5c73cc87d576dbaa63ecd1cbfd713 cl-prevalence-20191130-git cl-prevalence.asd test/cl-prevalence-test.asd +cl-primality http://beta.quicklisp.org/archive/cl-primality/2015-06-08/cl-primality-20150608-git.tgz 5079 e1590227314e5b4edee345232e8a4904 7698c3bcc32494cc4acf4ee91166745160668904 cl-primality-20150608-git cl-primality-test.asd cl-primality.asd +cl-prime-maker http://beta.quicklisp.org/archive/cl-prime-maker/2015-03-02/cl-prime-maker-20150302-git.tgz 5286 018c603dd74eb6a2f760188c1e9e581b b25b00051812d0c302e0e894dd3f3b6cb57cb4c9 cl-prime-maker-20150302-git cl-prime-maker.asd +cl-progress-bar http://beta.quicklisp.org/archive/cl-progress-bar/2018-10-18/cl-progress-bar-20181018-git.tgz 3607 c98f7a9ee6062e19c2a995d1c4952ecb 5de1c70cd16e6463ce9b21de87f3ed0b04f4dc3c cl-progress-bar-20181018-git cl-progress-bar.asd +cl-proj http://beta.quicklisp.org/archive/cl-proj/2019-03-07/cl-proj-20190307-git.tgz 27086 22f867c1041bf6483839be8f96201347 264035de8164730017178560ca47528b6cf53b87 cl-proj-20190307-git cl-proj.asd +cl-project http://beta.quicklisp.org/archive/cl-project/2019-05-21/cl-project-20190521-git.tgz 5426 1468189ff8880f43034c44adc317274f 879f47ff471149e1ad26ac3dfef124aeaceabd95 cl-project-20190521-git cl-project-test.asd cl-project.asd +cl-prolog2 http://beta.quicklisp.org/archive/cl-prolog2/2019-12-27/cl-prolog2-20191227-git.tgz 15590 9d662a6a868c59b66ddb91eae285a959 e09fa6b9921d8986e94738f7fc04a17426b08f27 cl-prolog2-20191227-git bprolog/cl-prolog2.bprolog.asd bprolog/cl-prolog2.bprolog.test.asd cl-prolog2.asd cl-prolog2.test.asd gprolog/cl-prolog2.gprolog.asd gprolog/cl-prolog2.gprolog.test.asd swi/cl-prolog2.swi.asd swi/cl-prolog2.swi.test.asd xsb/cl-prolog2.xsb.asd xsb/cl-prolog2.xsb.test.asd yap/cl-prolog2.yap.asd yap/cl-prolog2.yap.test.asd +cl-protobufs http://beta.quicklisp.org/archive/cl-protobufs/2018-03-28/cl-protobufs-20180328-git.tgz 590732 6573322beb8f27653f0c9b418c5f5b92 85505d3372e06de350a639f55e0e297cd364bcbd cl-protobufs-20180328-git cl-protobufs.asd tests/cl-protobufs-tests.asd +cl-pslib http://beta.quicklisp.org/archive/cl-pslib/2019-12-27/cl-pslib-20191227-git.tgz 41611 89c65c71420ab24a673c60fb68fc317f 14da423eee96d3ac21b4cee5481c85c2628eaf99 cl-pslib-20191227-git cl-pslib.asd +cl-pslib-barcode http://beta.quicklisp.org/archive/cl-pslib-barcode/2019-05-21/cl-pslib-barcode-20190521-git.tgz 25499 fa5459d7daee9546d972c859633d6fe9 3e954175d90c4b76c2b1697f97993f1ada1e67a3 cl-pslib-barcode-20190521-git cl-pslib-barcode.asd +cl-punch http://beta.quicklisp.org/archive/cl-punch/2019-01-07/cl-punch-20190107-git.tgz 1994 b5c6400872ae19221bf5a17f34750c63 e85b56b80563b86ab01b174561df88628c1ece7e cl-punch-20190107-git cl-punch-test.asd cl-punch.asd +cl-python http://beta.quicklisp.org/archive/cl-python/2019-08-13/cl-python-20190813-git.tgz 236882 c802663b1ac6cfa03df0e01c027a817a 3b554320dc2a5fdf31a91df9703f33250b2aaecd cl-python-20190813-git clpython.asd +cl-qprint http://beta.quicklisp.org/archive/cl-qprint/2015-08-04/cl-qprint-20150804-git.tgz 33969 74376a69e0b078724c94cc268f69e0f7 2e2600e7a6ea7c1c21df10f3fb37a531fa1c9382 cl-qprint-20150804-git cl-qprint.asd +cl-qrencode http://beta.quicklisp.org/archive/cl-qrencode/2019-10-07/cl-qrencode-20191007-git.tgz 31145 e94ac1137949ef70dea11ca78431e956 0e6589fa846a65032275cbb576bc13d194476b8f cl-qrencode-20191007-git cl-qrencode-test.asd cl-qrencode.asd +cl-quickcheck http://beta.quicklisp.org/archive/cl-quickcheck/2018-12-10/cl-quickcheck-20181210-git.tgz 18643 e17b3f199c97bfce961c1f9fa2c7602b e7eba42a2283c32af232a8e453c4155af6140a33 cl-quickcheck-20181210-git cl-quickcheck.asd +cl-rabbit http://beta.quicklisp.org/archive/cl-rabbit/2019-07-10/cl-rabbit-20190710-git.tgz 19444 1367680ba8d742821e98a0af16f5df48 a5b026d7e660368aae76cb95a1ac6e606818c447 cl-rabbit-20190710-git cl-rabbit-tests.asd cl-rabbit.asd +cl-rail http://beta.quicklisp.org/archive/cl-rail/2017-12-27/cl-rail-20171227-git.tgz 3644 7da276363c4b689b0bfd85edb449b5d2 95cfb2281dd525f4e6597364a7896022dc715939 cl-rail-20171227-git rail.asd +cl-randist http://beta.quicklisp.org/archive/cl-randist/2015-01-13/cl-randist-20150113-git.tgz 29385 3e79d7d52e4410f2dc2c9bd7287a9379 91d4779af0ce0a9d62364950780ac2d7ded03316 cl-randist-20150113-git cl-randist.asd +cl-random http://beta.quicklisp.org/archive/cl-random/2018-03-28/cl-random-20180328-git.tgz 47082 0f302ea0cf77c5120e85cda903a1026e 46bc508532878a29dfc9cd99fe61c0e18c9c88cc cl-random-20180328-git cl-random.asd +cl-random-forest http://beta.quicklisp.org/archive/cl-random-forest/2019-12-27/cl-random-forest-20191227-git.tgz 64264 f6ef2c6fb92a5763efad27aec06be165 60d5aa0fdc5c3570609ef25685946b4b73d4ab9f cl-random-forest-20191227-git cl-random-forest-test.asd cl-random-forest.asd +cl-rcfiles http://beta.quicklisp.org/archive/cl-rcfiles/2011-12-03/cl-rcfiles-20111203-http.tgz 1905 c6d90a1fe1488fba48dfc8174e829c63 58fbfde7a9339e3129ab1f67da5da7fbe13a493d cl-rcfiles-20111203-http com.dvlsoft.rcfiles.asd +cl-rdfxml http://beta.quicklisp.org/archive/cl-rdfxml/2014-07-13/cl-rdfxml-20140713-git.tgz 24185 ec6e7be8c793352109ab0b633c67c9b8 c27a5bb25404175ec960dccb0805fe8ff82caf5e cl-rdfxml-20140713-git cl-rdfxml.asd +cl-rdkafka http://beta.quicklisp.org/archive/cl-rdkafka/2019-11-30/cl-rdkafka-20191130-git.tgz 42963 4a0cf0f90eea364de2832ef973d9fd74 9481c15a668512774ec086b88b5465fa845ce10a cl-rdkafka-20191130-git cl-rdkafka.asd +cl-readline http://beta.quicklisp.org/archive/cl-readline/2019-08-13/cl-readline-20190813-git.tgz 74175 18272faddf5576e08e0976d98d7475c4 a92e5832b658ff3fdf78d3448636839b86eadd35 cl-readline-20190813-git cl-readline.asd +cl-recaptcha http://beta.quicklisp.org/archive/cl-recaptcha/2015-06-08/cl-recaptcha-20150608-git.tgz 2351 02198a25a246df0e1d2326d5a46bb9bb 127298018d8364bbc2b8c6763c772eef5d55651d cl-recaptcha-20150608-git cl-recaptcha.asd +cl-reddit http://beta.quicklisp.org/archive/cl-reddit/2019-05-21/cl-reddit-20190521-git.tgz 10181 23c2901b8bbffaefd648e8cf5e79db72 5f45f83eceb917e3ca830e714a11c3272078e8e3 cl-reddit-20190521-git cl-reddit.asd +cl-redis http://beta.quicklisp.org/archive/cl-redis/2019-11-30/cl-redis-20191130-git.tgz 25337 74f15acfea85009ca1d6807b35565c20 e2d90d578b588fc9ca4af915ef4dca8609b8ab6b cl-redis-20191130-git cl-redis.asd +cl-reexport http://beta.quicklisp.org/archive/cl-reexport/2015-07-09/cl-reexport-20150709-git.tgz 2621 207d02771cbd906d033ff704ca5c3a3d 5c0c92aab4f892e585116168c3622daf86e5f2ca cl-reexport-20150709-git cl-reexport-test.asd cl-reexport.asd +cl-rethinkdb http://beta.quicklisp.org/archive/cl-rethinkdb/2016-08-25/cl-rethinkdb-20160825-git.tgz 32793 b08605b7cfdc8351472c3764c1c86120 2d087d3e621659974f63a6c3a5fb28c1f22244bc cl-rethinkdb-20160825-git cl-rethinkdb-test.asd cl-rethinkdb.asd +cl-rfc2047 http://beta.quicklisp.org/archive/cl-rfc2047/2015-08-04/cl-rfc2047-20150804-git.tgz 6167 18e4a78b37f0b6bfb650907cb1dc8a17 4554d0124034923310e5134da555a5ac86c810e8 cl-rfc2047-20150804-git cl-rfc2047.asd test/cl-rfc2047-test.asd +cl-riff http://beta.quicklisp.org/archive/cl-riff/2018-01-31/cl-riff-20180131-git.tgz 3545 ab459dd87a44dea617ff845d4fc71191 4469a44389e88b68dff496dfa0b65c9530676400 cl-riff-20180131-git cl-riff.asd +cl-rlimit http://beta.quicklisp.org/archive/cl-rlimit/2015-06-08/cl-rlimit-20150608-git.tgz 3785 ea8d2343b95011bce0de3b699adf0cee 96e1fb8e23a5ad62b865930843dd6150488b8d84 cl-rlimit-20150608-git cl-rlimit.asd +cl-rmath http://beta.quicklisp.org/archive/cl-rmath/2018-03-28/cl-rmath-20180328-git.tgz 5219 0a7e999618e9381b458fea9703774f45 eb85ac5db3f73bba9f919287232e4ea895354424 cl-rmath-20180328-git cl-rmath.asd +cl-routes http://beta.quicklisp.org/archive/cl-routes/2017-01-24/cl-routes-20170124-git.tgz 16959 00cf290e3908eae5cfe4291da87fb7ec b6cf44512de1794cd364a428bd184b9663e8dfc6 cl-routes-20170124-git routes.asd +cl-rrd http://beta.quicklisp.org/archive/cl-rrd/2013-01-28/cl-rrd-20130128-git.tgz 6990 6ed1292cb978445d9952e464d547d149 e820e55875b893f4014ae7358768e480f0d1a28c cl-rrd-20130128-git cl-rrd.asd +cl-rrt http://beta.quicklisp.org/archive/cl-rrt/2015-06-08/cl-rrt-20150608-git.tgz 120843 eeb595209ff5b0c7a6c8c03b918c21c1 25c4808063a57c1af41122e1e17e17159ecc8568 cl-rrt-20150608-git cl-rrt.asd cl-rrt.benchmark.asd cl-rrt.rtree.asd cl-rrt.test.asd +cl-rss http://beta.quicklisp.org/archive/cl-rss/2015-09-23/cl-rss-20150923-git.tgz 6625 9aef52d11324357d191bd4f08cfb8db8 f53cfacd06eb140c1676eca5b1fb953546d5db5f cl-rss-20150923-git rss.asd +cl-rsvg2 http://beta.quicklisp.org/archive/cl-rsvg2/2012-01-07/cl-rsvg2-20120107-git.tgz 52077 a3843a8d8bb4a009252eb70b1cb6cf5d dac64d5abfdaca3743acf1d3b9f8cdf78fba659d cl-rsvg2-20120107-git cl-rsvg2-pixbuf.asd cl-rsvg2-test.asd cl-rsvg2.asd +cl-rules http://beta.quicklisp.org/archive/cl-rules/2019-07-10/cl-rules-20190710-git.tgz 19882 1630f82d032594f14e3eb73afa7cca02 30a3aa278f1df25ed0279dd26a755164d559c2e3 cl-rules-20190710-git cl-rules-test.asd cl-rules.asd +cl-s3 http://beta.quicklisp.org/archive/cl-s3/2013-01-28/cl-s3-20130128-git.tgz 5843 4d064571012b9604f35d38b54d394357 07603d2daf79010091a344f9818c07b435c2d5f2 cl-s3-20130128-git cl-s3.asd +cl-sam http://beta.quicklisp.org/archive/cl-sam/2015-06-08/cl-sam-20150608-git.tgz 4054488 63b1c3bb023e3ef06e5f3855e6144b24 b3e8816022b2cbed60171db86596242905c0edf3 cl-sam-20150608-git cl-sam-test.asd cl-sam.asd +cl-sandbox http://beta.quicklisp.org/archive/cl-sandbox/2018-01-31/cl-sandbox-20180131-git.tgz 6539 86be3668d5ac97547a5043a48f155303 fc1e5b23275df9e8fadea34ac67a19a52b6e1073 cl-sandbox-20180131-git cl-sandbox.asd +cl-sane http://beta.quicklisp.org/archive/cl-sane/2015-06-08/cl-sane-20150608-git.tgz 9398 eb13c4f10552e26bc25a3a262416b71d c956a99e26239fb1c7a7646a9372c1fe7d616c24 cl-sane-20150608-git sane.asd +cl-sanitize http://beta.quicklisp.org/archive/cl-sanitize/2013-07-20/cl-sanitize-20130720-git.tgz 14858 704397eb4bfd6eef71f7bdbba5a672bf 2cf5ca23dcb811cad0796d45ee062d30cc4ad682 cl-sanitize-20130720-git sanitize.asd +cl-sasl http://beta.quicklisp.org/archive/cl-sasl/2019-05-21/cl-sasl-v0.3.2.tgz 7083 61105fc8faf396a39fc9d9c3400b3c21 bed7a2a1a1908c83f5ee47d8d698aba828a12d83 cl-sasl-v0.3.2 cl-sasl.asd +cl-sat http://beta.quicklisp.org/archive/cl-sat/2019-08-13/cl-sat-20190813-git.tgz 18954 3f787f59692c9e962d2d37b2bec74da4 31adeffae9e4d430ac294ca80bb96302ba013372 cl-sat-20190813-git cl-sat.asd cl-sat.test.asd +cl-sat.glucose http://beta.quicklisp.org/archive/cl-sat.glucose/2019-08-13/cl-sat.glucose-20190813-git.tgz 2987 dc40b48ee3f9dcf7cbe9ab4a7c30f8a3 e8c69c7a3bf8f00b18c30cb271af3a96400a3a7d cl-sat.glucose-20190813-git cl-sat.glucose.asd cl-sat.glucose.test.asd +cl-sat.minisat http://beta.quicklisp.org/archive/cl-sat.minisat/2019-08-13/cl-sat.minisat-20190813-git.tgz 2868 25c3abddf6c4cbf76772862bd0d53ee6 9f63b2656623707b841a20d3af40557d3b374e87 cl-sat.minisat-20190813-git cl-sat.minisat.asd cl-sat.minisat.test.asd +cl-scram http://beta.quicklisp.org/archive/cl-scram/2015-09-23/cl-scram-20150923-git.tgz 5503 a010b20d5532a08fc85c2c532ddea09f 3e7475151f474a9d54817daebef5590da99a78a1 cl-scram-20150923-git cl-scram.asd +cl-scribd http://beta.quicklisp.org/archive/cl-scribd/2013-03-12/cl-scribd-20130312-git.tgz 3363 b87c90e9a765d543c2edf464479d5f88 c7995da5ad011d99cd74fee78889138678cf71d2 cl-scribd-20130312-git cl-scribd.asd +cl-scripting http://beta.quicklisp.org/archive/cl-scripting/2017-04-03/cl-scripting-20170403-git.tgz 3953 796475a259527bf7519811c2f567c4ec b56d960acee0ae374f0593ecb72c6900dacb5213 cl-scripting-20170403-git cl-scripting.asd +cl-scrobbler http://beta.quicklisp.org/archive/cl-scrobbler/2011-11-05/cl-scrobbler-20111105-git.tgz 10687 367d3741fc72df62a122ef7188117409 e14659ef82c2107a42ae6767c3137597a72202c1 cl-scrobbler-20111105-git cl-scrobbler.asd +cl-scsu http://beta.quicklisp.org/archive/cl-scsu/2019-05-21/cl-scsu-20190521-git.tgz 19345 057ab3d9bb1cfc12d0fae38e3ae4fd9d da65307115d9439ad16ee89359251eecf2ba0de8 cl-scsu-20190521-git cl-scsu-test.asd cl-scsu.asd +cl-sdl2 http://beta.quicklisp.org/archive/cl-sdl2/2019-11-30/cl-sdl2-20191130-git.tgz 1522180 ece07c78f925f43dddc5b99101248fe7 cdfbc6a245d8bf0f94fccfb75592bd0db1471999 cl-sdl2-20191130-git sdl2.asd +cl-sdl2-image http://beta.quicklisp.org/archive/cl-sdl2-image/2019-02-02/cl-sdl2-image-20190202-git.tgz 400442 d0771409506b37b0f56d0258396d31fd da0dd9f2ca73880afd6303d6f9a616ce976ce486 cl-sdl2-image-20190202-git sdl2-image.asd +cl-sdl2-mixer http://beta.quicklisp.org/archive/cl-sdl2-mixer/2018-10-18/cl-sdl2-mixer-20181018-git.tgz 365901 f5206e179e3fac259cce41b819b5e94d a5a406f8ffd8f08549951d63b919b4dc8dc01d0d cl-sdl2-mixer-20181018-git sdl2-mixer.asd +cl-sdl2-ttf http://beta.quicklisp.org/archive/cl-sdl2-ttf/2018-10-18/cl-sdl2-ttf-20181018-git.tgz 857358 4c174535752393ad7ed1e3546602584e b134b8a4a8ab3d4e9e1293fa70e1a7a8308bd395 cl-sdl2-ttf-20181018-git sdl2-ttf-examples.asd sdl2-ttf.asd +cl-selenium http://beta.quicklisp.org/archive/cl-selenium/2016-05-31/cl-selenium-20160531-git.tgz 15740 308b72c1bdad85a13bf79803c822ee95 9fa23dcb879cab1c8894e0bf8e207490c5acd8a3 cl-selenium-20160531-git selenium.asd +cl-selenium-webdriver http://beta.quicklisp.org/archive/cl-selenium-webdriver/2018-03-28/cl-selenium-webdriver-20180328-git.tgz 7935 d9ee1973788ddfd81380a33495c4ec85 1b90f0da0d3ce8d74e408be28b2c4884b7885b2a cl-selenium-webdriver-20180328-git cl-selenium-test.asd cl-selenium.asd +cl-sentiment http://beta.quicklisp.org/archive/cl-sentiment/2013-01-28/cl-sentiment-20130128-git.tgz 15819 2f3445dffa9105370751fa8ba7c2005c fc4a0651df4d453162919d5bd43540cba491c81e cl-sentiment-20130128-git cl-sentiment.asd +cl-server-manager http://beta.quicklisp.org/archive/cl-server-manager/2013-10-03/cl-server-manager-20131003-git.tgz 4564 046913915897f50caec525748a58cc01 8d8183ebce0e93f9e5e8f6a807b915995c1e6359 cl-server-manager-20131003-git cl-server-manager.asd +cl-shellwords http://beta.quicklisp.org/archive/cl-shellwords/2015-09-23/cl-shellwords-20150923-git.tgz 3943 c2c62c6a2ce4ed2590d60707ead2e084 e925f0d8cc96238116bc7f29b75eb3572e9ce325 cl-shellwords-20150923-git cl-shellwords-test.asd cl-shellwords.asd +cl-shlex http://beta.quicklisp.org/archive/cl-shlex/2019-10-07/cl-shlex-20191007-git.tgz 8580 814f4b1055bbd8423263a6ed5bde564a 1f5471b3cbe80db08b4162a413baa26c42b3b6aa cl-shlex-20191007-git shlex.asd +cl-simple-concurrent-jobs http://beta.quicklisp.org/archive/cl-simple-concurrent-jobs/2015-05-05/cl-simple-concurrent-jobs-20150505-git.tgz 4297 01612838d9d398b13eec9a5b0bc28abb ebe1febd1180f311c340458960719d74cb8bda21 cl-simple-concurrent-jobs-20150505-git cl-simple-concurrent-jobs.asd +cl-simple-fsm http://beta.quicklisp.org/archive/cl-simple-fsm/2019-12-27/cl-simple-fsm-20191227-git.tgz 3517 98e5f4fd0a0ab2cb328fe84db00e82c0 643aae5a3f87b97798b4bbac27925ac5dcdc1b5b cl-simple-fsm-20191227-git finite-state-machine.asd +cl-simple-table http://beta.quicklisp.org/archive/cl-simple-table/2013-03-12/cl-simple-table-20130312-git.tgz 5746 6b100dbdefa432b04a9dd2b36a7aa47b 701fddeefc3cbb1220fc31f7fcbd56294c7aa2a2 cl-simple-table-20130312-git cl-simple-table.asd +cl-singleton-mixin http://beta.quicklisp.org/archive/cl-singleton-mixin/2015-05-05/cl-singleton-mixin-20150505-git.tgz 2088 dbe6e7e009c5051cb4920e9965eff799 20a7748134ec477d642afc98e2a6117e817f8588 cl-singleton-mixin-20150505-git cl-singleton-mixin-test.asd cl-singleton-mixin.asd +cl-skip-list http://beta.quicklisp.org/archive/cl-skip-list/2013-06-15/cl-skip-list-20130615-git.tgz 13233 d8c7b91764103aa5f3db7dbf839968a3 999911f84161239c37601b3d87ed5f9792ee74c2 cl-skip-list-20130615-git cl-skip-list.asd +cl-skkserv http://beta.quicklisp.org/archive/cl-skkserv/2019-05-21/cl-skkserv-20190521-git.tgz 28061 10b4fd63908e842dd7b68abfaaf0a0d3 c2f6d01c3ae857e3acf6aba2fb9e35753fd1277a cl-skkserv-20190521-git cl-skkserv.asd +cl-sl4a http://beta.quicklisp.org/archive/cl-sl4a/2015-08-04/cl-sl4a-20150804-git.tgz 1951 dbfee5c96a7f36682929591319236b24 346a2d6dd6942fa65cd5326a15d127b86a3a99b3 cl-sl4a-20150804-git cl-android.asd +cl-slice http://beta.quicklisp.org/archive/cl-slice/2017-11-30/cl-slice-20171130-git.tgz 7633 b83a7a9aa503dc01cba43cf1e494e67d 0b4a4ecdec181ee34d57fca9d02a91d91a31594e cl-slice-20171130-git cl-slice.asd +cl-slp http://beta.quicklisp.org/archive/cl-slp/2014-08-26/cl-slp-20140826-git.tgz 7716 24dfaadf60cd54dfa811aa9d4e37d07e 0e6a27441f94c6e6ce46e0aead20fc9b2db4dfc7 cl-slp-20140826-git cl-slp.asd +cl-slug http://beta.quicklisp.org/archive/cl-slug/2018-02-28/cl-slug-20180228-git.tgz 7416 2b59b63bb9a234cb14959fda6f12fa2e 9512dd1601d8bcc265598fe6e49cdddf772eeb8f cl-slug-20180228-git cl-slug-test.asd cl-slug.asd +cl-smt-lib http://beta.quicklisp.org/archive/cl-smt-lib/2019-10-07/cl-smt-lib-20191007-git.tgz 4112 5c2af5fbcc3ec8863e909cad6cb921a7 be7e36d0edb1697685edd17839b2ca08aa50b91f cl-smt-lib-20191007-git cl-smt-lib.asd +cl-smtp http://beta.quicklisp.org/archive/cl-smtp/2019-11-30/cl-smtp-20191130-git.tgz 37408 880f09b9fd22e358d1b94a3caf3bd34b 9a19db97a6f0d4e1cc90ae2c03a989f723bcba71 cl-smtp-20191130-git cl-smtp.asd +cl-soil http://beta.quicklisp.org/archive/cl-soil/2018-08-31/cl-soil-release-quicklisp-f27087ce-git.tgz 330400 e26e1e23f2a4bf10a4e4d7c8e2fcd70c 6d7ad0c6aef48bb614d85a709222afcefa75c692 cl-soil-release-quicklisp-f27087ce-git cl-soil.asd +cl-soloud http://beta.quicklisp.org/archive/cl-soloud/2019-07-10/cl-soloud-20190710-git.tgz 521503 59b094adf83863dbf491001ec9dc0e33 f028ca7c4cbc2c3aa86a4341fdeb61e3d9482db4 cl-soloud-20190710-git cl-soloud.asd +cl-sophia http://beta.quicklisp.org/archive/cl-sophia/2015-06-08/cl-sophia-20150608-git.tgz 5748 4fa639f26d38c37be18c0d4e0da4b153 186948212d713ac7bac820f476e63a372b591b69 cl-sophia-20150608-git cl-sophia.asd +cl-spark http://beta.quicklisp.org/archive/cl-spark/2015-07-09/cl-spark-20150709-git.tgz 12519 0eec4e41100c4bbb0ab512e779399604 674f1bc695ae33dc00ab02502078af72720bf098 cl-spark-20150709-git cl-spark-test.asd cl-spark.asd +cl-speedy-queue http://beta.quicklisp.org/archive/cl-speedy-queue/2015-03-02/cl-speedy-queue-20150302-git.tgz 3631 509d1acf7e4cfcef99127de75b16521f 476412e42d63703c0b070d23e7e4cbd389d447e9 cl-speedy-queue-20150302-git cl-speedy-queue.asd +cl-sphinx http://beta.quicklisp.org/archive/cl-sphinx/2011-06-19/cl-sphinx-20110619-git.tgz 162782 0aa9e282a8ecc190b788d121071373d6 2ca537aaaac0a4d45151b6a7c8ca71909d10ff5d cl-sphinx-20110619-git sphinx.asd +cl-spidev http://beta.quicklisp.org/archive/cl-spidev/2019-07-10/cl-spidev-20190710-git.tgz 10495 59a6d3341753da1fed9b05864deaabc4 b9338baf09481b93f21f16cea80fc9023b195807 cl-spidev-20190710-git cl-spidev.asd +cl-splicing-macro http://beta.quicklisp.org/archive/cl-splicing-macro/2014-07-13/cl-splicing-macro-20140713-git.tgz 3041 d9ff0c4c0aa1a649ae7f6866ae5ce570 9b0b263f55f29e0dc141c8928f0151ce21bad99f cl-splicing-macro-20140713-git cl-splicing-macro.asd +cl-sqlite http://beta.quicklisp.org/archive/cl-sqlite/2019-08-13/cl-sqlite-20190813-git.tgz 14632 2269773eeb4a101ddd3b33f0f7e05e76 4edb0bfcfc4ec79ab48038c420e415b817c054f8 cl-sqlite-20190813-git sqlite.asd +cl-ssdb http://beta.quicklisp.org/archive/cl-ssdb/2017-08-30/cl-ssdb-20170830-git.tgz 16126 82ae579cf245edd48997fcb45c5a901c 3056cf48da051b98929d584dc5b841a2d15d55bd cl-ssdb-20170830-git cl-ssdb-test.asd cl-ssdb.asd +cl-statsd http://beta.quicklisp.org/archive/cl-statsd/2017-01-24/cl-statsd-20170124-git.tgz 6437 bc58e298a1cf3657375eeb7e9981d993 65edf0606df6f93ff2b212c619c1f315e68a0de1 cl-statsd-20170124-git cl-statsd.asd cl-statsd.test.asd +cl-stdutils http://beta.quicklisp.org/archive/cl-stdutils/2011-10-01/cl-stdutils-20111001-git.tgz 114509 0fa8879ce4004924ff1f534e9fb92dba 4204504d7107cd3eae33550c4e00797fa4dfba98 cl-stdutils-20111001-git stdutils.asd +cl-steamworks http://beta.quicklisp.org/archive/cl-steamworks/2019-08-13/cl-steamworks-20190813-git.tgz 99838 790744d59a1435552a001ed6c32b9c48 d9e683874159eae48619172982b9595248aad946 cl-steamworks-20190813-git cl-steamworks-generator.asd cl-steamworks.asd +cl-stomp http://beta.quicklisp.org/archive/cl-stomp/2019-05-21/cl-stomp-20190521-git.tgz 7487 8f0ec87e3a0bb05e97bf5e4d2509074e a9f15eac2d88439c1d93b7dec9a12a7262dd32f3 cl-stomp-20190521-git cl-stomp.asd +cl-stopwatch http://beta.quicklisp.org/archive/cl-stopwatch/2019-03-07/cl-stopwatch-20190307-hg.tgz 3481 f8aca8aac1dcaa3ff818e558dfb8471b 3963d39f4cdba3e518f0d027124d647592e77545 cl-stopwatch-20190307-hg cl-stopwatch.asd +cl-store http://beta.quicklisp.org/archive/cl-store/2019-11-30/cl-store-20191130-git.tgz 47654 d6052274cd0c6a86bfc2de1e4a8a0886 e486b6ae28113215280cb5d3bbf30f1ad5804613 cl-store-20191130-git cl-store.asd +cl-str http://beta.quicklisp.org/archive/cl-str/2019-12-27/cl-str-20191227-git.tgz 14864 b2800b32209061b274432c7e699d92b4 4b48d2a3a9348897e1318dffa9f8b574d57d5000 cl-str-20191227-git str.asd str.test.asd +cl-stream http://beta.quicklisp.org/archive/cl-stream/2019-05-21/cl-stream-20190521-git.tgz 10083 99bb43715db14c688bb32be11e4fee8b bd4e03b1155b2a3fe9a9a6faaae493f48bc0ad95 cl-stream-20190521-git cl-stream.asd +cl-strftime http://beta.quicklisp.org/archive/cl-strftime/2016-03-18/cl-strftime-20160318-git.tgz 7797 73097d6d00eca45c52ca5bedc99d0146 27c12e403c68bd330feffadd2b766cb9db160347 cl-strftime-20160318-git cl-strftime.asd +cl-string-complete http://beta.quicklisp.org/archive/cl-string-complete/2019-03-07/cl-string-complete-20190307-hg.tgz 5305 e828ace268105ad02b58ed26498ad28f eab194a8bfb0efe55ac8f0c7d8411e5e16408556 cl-string-complete-20190307-hg cl-string-complete.asd +cl-string-match http://beta.quicklisp.org/archive/cl-string-match/2019-03-07/cl-string-match-20190307-hg.tgz 176593 68e27c214f63e7c30f1e0c2ccad86131 7d2a654be746559ace31ef188a977826f86a0bfe cl-string-match-20190307-hg ascii-strings.asd cl-string-match-test.asd cl-string-match.asd simple-scanf.asd +cl-strings http://beta.quicklisp.org/archive/cl-strings/2018-01-31/cl-strings-20180131-git.tgz 11078 c10eee2534f8476b59acf13f34787a56 5256d9d0725aa96208b47d91a565f6e005670bba cl-strings-20180131-git cl-strings.asd +cl-svg http://beta.quicklisp.org/archive/cl-svg/2018-02-28/cl-svg-20180228-git.tgz 83379 672145ecadef2259a3833886dbe68617 1640e08a5ddbcc328a3b4240c13ff91cac3c5454 cl-svg-20180228-git cl-svg.asd +cl-svm http://beta.quicklisp.org/archive/cl-svm/2011-04-18/cl-svm-20110418-git.tgz 435539 c093c5810a77b5258a6b463168c7c8bb 8e4d8ad0cb5ec177c2373b14c251c5932a84615b cl-svm-20110418-git cl-svm.asd +cl-swagger-codegen http://beta.quicklisp.org/archive/cl-swagger-codegen/2018-08-31/cl-swagger-codegen-20180831-git.tgz 43309 5066805afea5280e16e3e58f05cd88e1 9b69504759ff81308c486b266ff3484d2a6e8531 cl-swagger-codegen-20180831-git cl-swagger.asd +cl-sxml http://beta.quicklisp.org/archive/cl-sxml/2016-08-25/cl-sxml-20160825-git.tgz 15206 5bf02bf2dcb4ddf1c1a869a0ff7277df f993c08874902296c2b2b6ddcbc21cae0cfbbbda cl-sxml-20160825-git cl-sxml.asd +cl-syntax http://beta.quicklisp.org/archive/cl-syntax/2015-04-07/cl-syntax-20150407-git.tgz 3102 602b84143aafe59d65f4e08ac20a124a e00e7def72875fd635f7e9d27e24fd3f23076247 cl-syntax-20150407-git cl-syntax-annot.asd cl-syntax-anonfun.asd cl-syntax-clsql.asd cl-syntax-fare-quasiquote.asd cl-syntax-interpol.asd cl-syntax-markup.asd cl-syntax.asd +cl-syslog http://beta.quicklisp.org/archive/cl-syslog/2019-02-02/cl-syslog-20190202-git.tgz 14759 eafff19eb1f38a36a9535c729d2217fe de0c891d0168db0a3079707794b5fafae6d99282 cl-syslog-20190202-git cl-syslog.asd +cl-table http://beta.quicklisp.org/archive/cl-table/2013-01-28/cl-table-20130128-git.tgz 4002 793e1222aebf00d28d4ec58173bd36b5 93e0aa5fb21ae9722e78814471019d1c2c62f6a3 cl-table-20130128-git cl-table.asd +cl-tasukete http://beta.quicklisp.org/archive/cl-tasukete/2018-02-28/cl-tasukete-20180228-git.tgz 5602 f4dc086f01e384684b371fbcf631c29b 793c27bce80661019dd5920e02074e538bd22855 cl-tasukete-20180228-git cl-tasukete-test.asd cl-tasukete.asd +cl-tcod http://beta.quicklisp.org/archive/cl-tcod/2019-03-07/cl-tcod-20190307-hg.tgz 88998 19b214124c8034ef7fab350ee8cac85d 7c1935d7f9d77ec4e954396b175a12e00ff4bb32 cl-tcod-20190307-hg parse-rgb.asd tcod.asd +cl-template http://beta.quicklisp.org/archive/cl-template/2013-06-15/cl-template-20130615-git.tgz 8316 9ff3872864a04535fa4fdd541e5fef70 3407880226be0be8fd02890e3ef18a2c9c8899f6 cl-template-20130615-git cl-template.asd +cl-tesseract http://beta.quicklisp.org/archive/cl-tesseract/2017-11-30/cl-tesseract-20171130-git.tgz 8190 761384aa2cde1733a96d6fca82d00750 98cef4ac03acf09549444079e5da579b19ebdc7a cl-tesseract-20171130-git cl-tesseract.asd +cl-tetris3d http://beta.quicklisp.org/archive/cl-tetris3d/2018-12-10/cl-tetris3d-20181210-git.tgz 5744 66d1a4aa18316e25bc0a7df127be71e7 5ea752a06b16d0d4aff9ad6a1bf5acc3eda92faf cl-tetris3d-20181210-git cl-tetris3d.asd +cl-textmagic http://beta.quicklisp.org/archive/cl-textmagic/2015-12-18/cl-textmagic-20151218-git.tgz 2035 f746d2e7ddea99e9cbe443e4a6c08175 3473012d8f21242b2a9bb6a85544938fe2c4a536 cl-textmagic-20151218-git cl-textmagic-test.asd cl-textmagic.asd +cl-tga http://beta.quicklisp.org/archive/cl-tga/2016-03-18/cl-tga-20160318-git.tgz 312452 84bf8ad6fc66ffd2519b933469ae3660 2d2b8b4fd47dde90818f6600bd73bf3cc0ede60f cl-tga-20160318-git cl-tga.asd +cl-threadpool http://beta.quicklisp.org/archive/cl-threadpool/2018-02-28/cl-threadpool-quickload-current-release-67b33ca4-git.tgz 7043 24d77e379a133b440f1ef61ba375ac68 24ab5b625c94a9dd1521bacc44da7316d4260060 cl-threadpool-quickload-current-release-67b33ca4-git cl-threadpool-test.asd cl-threadpool.asd +cl-tidy http://beta.quicklisp.org/archive/cl-tidy/2017-08-30/cl-tidy-20170830-git.tgz 6451 753b926424eaf57415e3cdb2545f4b51 8510d6d70053a5dcf0471a22507013b245695875 cl-tidy-20170830-git cl-tidy.asd +cl-tiled http://beta.quicklisp.org/archive/cl-tiled/2019-11-30/cl-tiled-20191130-git.tgz 18051 9b235a4a51b858842661c95871f72855 7e6134e180a45e3f52502be2f0f580be5538f25a cl-tiled-20191130-git cl-tiled.asd +cl-tk http://beta.quicklisp.org/archive/cl-tk/2015-06-08/cl-tk-20150608-git.tgz 11254 c6711a6dea114a6c3dec446420eec0f7 a69f6d26b9018482347f83542b91d5f913c13d4c cl-tk-20150608-git cl-tk.asd +cl-tld http://beta.quicklisp.org/archive/cl-tld/2014-09-14/cl-tld-20140914-git.tgz 42598 c1a599db2ff8f0bb76acb206743b8d98 bb55b6b60e8cf822c80fb220117d81b809616325 cl-tld-20140914-git cl-tld.asd +cl-tokyo-cabinet http://beta.quicklisp.org/archive/cl-tokyo-cabinet/2016-08-25/cl-tokyo-cabinet-20160825-git.tgz 19667 00d4bb23e393c6966b4acf17d9184627 9d22fd186290b36752b32010589d8f6b6c31024d cl-tokyo-cabinet-20160825-git cl-tokyo-cabinet-test.asd cl-tokyo-cabinet.asd +cl-toml http://beta.quicklisp.org/archive/cl-toml/2019-11-30/cl-toml-20191130-git.tgz 8835 093bee6524054b0b515d52db070eb300 8cf25c892ca26097b7d4880e49b8d32439ed4095 cl-toml-20191130-git cl-toml-test.asd cl-toml.asd +cl-torrents http://beta.quicklisp.org/archive/cl-torrents/2019-12-27/cl-torrents-20191227-git.tgz 579423 11d40517d088db7dbc506dede11ac452 c0707a0ffcfef7844340d48ea004ea5b6806f4b9 cl-torrents-20191227-git torrents-test.asd torrents.asd +cl-transmission http://beta.quicklisp.org/archive/cl-transmission/2019-11-30/cl-transmission-20191130-git.tgz 8850 403607bb79c4df111d3af41d03607b76 da1f5bf1637e728c1da70439e85a73016cafcee7 cl-transmission-20191130-git cl-transmission-test.asd cl-transmission.asd +cl-trie http://beta.quicklisp.org/archive/cl-trie/2018-02-28/cl-trie-20180228-git.tgz 11400 20a0f0facbed0ccfad54bfeac6dcbba7 3e5dc74d7aeb063b2cdb3a8a267b946606c1e541 cl-trie-20180228-git cl-trie-examples.asd cl-trie.asd +cl-tulip-graph http://beta.quicklisp.org/archive/cl-tulip-graph/2013-06-15/cl-tulip-graph-20130615-git.tgz 14772 eaf9d92e3bffcf93220052fd42b4d002 060726c29d1b14f683149de192541e5b30a99877 cl-tulip-graph-20130615-git cl-tulip-graph.asd +cl-tuples http://beta.quicklisp.org/archive/cl-tuples/2014-07-13/cl-tuples-20140713-git.tgz 28047 8676dd7e0be1af17f5ffa8aac21d0ab3 c977ce6c441bd413c363d63cc99382ff33192dff cl-tuples-20140713-git cl-tuples.asd +cl-twitter http://beta.quicklisp.org/archive/cl-twitter/2018-02-28/cl-twitter-20180228-git.tgz 70934 83638a0508cda507500ef9e633f6cec4 620458f22d28ab5e6f33027c492e7fe1cae28c48 cl-twitter-20180228-git cl-twit-repl.asd cl-twitter.asd twitter-mongodb-driver.asd +cl-typesetting http://beta.quicklisp.org/archive/cl-typesetting/2017-08-30/cl-typesetting-20170830-git.tgz 335971 e12b9f249c60c220c5dc4a0939eb3343 25acaabf4593729cebb2c2ee79d056633f9b2fdb cl-typesetting-20170830-git cl-typesetting.asd contrib/xhtml-renderer/xml-render.asd documentation/lisp-source/cl-pdf-doc.asd +cl-uglify-js http://beta.quicklisp.org/archive/cl-uglify-js/2015-07-09/cl-uglify-js-20150709-git.tgz 17631 f0ac4a43bb9da2478e995802b86df6dd b806550d06d7844466d36235876ff0a1698e854b cl-uglify-js-20150709-git cl-uglify-js.asd +cl-unicode http://beta.quicklisp.org/archive/cl-unicode/2019-05-21/cl-unicode-20190521-git.tgz 590698 04009a1266edbdda4d38902907caba25 58b893a1a34cee2803c9bfcc1ff1ac1056741c96 cl-unicode-20190521-git cl-unicode.asd +cl-unification http://beta.quicklisp.org/archive/cl-unification/2019-01-07/cl-unification-20190107-git.tgz 32390 a7a12789cc48e571b0871d55cef11b7f de98a21a56c2a219afca5cfc43b4cd8f74ed1abb cl-unification-20190107-git cl-unification-lib.asd cl-unification-test.asd cl-unification.asd lib-dependent/cl-ppcre-template.asd +cl-utilities http://beta.quicklisp.org/archive/cl-utilities/2010-10-06/cl-utilities-1.2.4.tgz 22998 c3a4ba38b627448d3ed40ce888048940 187862251617676b95b1386e277fb2c449472bf8 cl-utilities-1.2.4 cl-utilities.asd +cl-variates http://beta.quicklisp.org/archive/cl-variates/2018-01-31/cl-variates-20180131-darcs.tgz 13536 dd441faa5cf87e4f41102c4a2323f95f 0ee1831ebbfe0c3efb4a5a02936f8a01b624abcc cl-variates-20180131-darcs cl-variates.asd +cl-vectors http://beta.quicklisp.org/archive/cl-vectors/2018-02-28/cl-vectors-20180228-git.tgz 31415 9d9629786d4f2c19c15cc6cd3049c343 55f19b15187b1a1026c7fd139fedf3cb7663847b cl-vectors-20180228-git cl-aa-misc.asd cl-aa.asd cl-paths-ttf.asd cl-paths.asd cl-vectors.asd +cl-vhdl http://beta.quicklisp.org/archive/cl-vhdl/2016-04-21/cl-vhdl-20160421-git.tgz 38493 1cae44b3e18d5b1416e9c3afb7382f76 030aa263142eff790f30a947c7b606b7b6021d97 cl-vhdl-20160421-git cl-vhdl.asd +cl-video http://beta.quicklisp.org/archive/cl-video/2018-02-28/cl-video-20180228-git.tgz 9729 1390350148bca3730b1a7d24e298d0e2 82c761ab17ae349f4ec7efff0f438e1dfa57af3d cl-video-20180228-git cl-video-avi.asd cl-video-gif.asd cl-video-player.asd cl-video-wav.asd cl-video.asd +cl-virtualbox http://beta.quicklisp.org/archive/cl-virtualbox/2018-08-31/cl-virtualbox-20180831-git.tgz 5029 f75919b162c344bf5b3bee1bf3f91e32 90de58049f50133366139c8e37e5e8548ff1bce9 cl-virtualbox-20180831-git cl-virtualbox.asd +cl-voxelize http://beta.quicklisp.org/archive/cl-voxelize/2015-07-09/cl-voxelize-20150709-git.tgz 118708 2e3d839d201d64659726f553bebd6ac0 104f867098b7cde4f4ccd449633cd9a407e8ce46 cl-voxelize-20150709-git cl-voxelize-examples.asd cl-voxelize-test.asd cl-voxelize.asd +cl-wadler-pprint http://beta.quicklisp.org/archive/cl-wadler-pprint/2019-10-07/cl-wadler-pprint-20191007-git.tgz 4900 030262f0ac47b84a4cfbfa3e423b7eee c68f97c39c540a1bcd35023df432e026b651ded3 cl-wadler-pprint-20191007-git cl-wadler-pprint.asd +cl-wav http://beta.quicklisp.org/archive/cl-wav/2018-01-31/cl-wav-20180131-git.tgz 3469 c487c47fb702747ad1e0faffe5b7d388 b45d07885c30d4205d3d952b3a20ead799574b2e cl-wav-20180131-git cl-wav.asd +cl-wayland http://beta.quicklisp.org/archive/cl-wayland/2019-03-07/cl-wayland-20190307-git.tgz 44560 31887db1bf34dcf36f3978c8004d4e0f 9a189cafa43b0da7d79a9421afa30bebbf7db6ec cl-wayland-20190307-git cl-wayland.asd +cl-weather-jp http://beta.quicklisp.org/archive/cl-weather-jp/2016-02-08/cl-weather-jp-20160208-git.tgz 3398 705667b6c865f440d1667ccc5f83a8fb 3c40d7f65d92a9485ec4bb8e89c0d0af8d5e73c3 cl-weather-jp-20160208-git cl-weather-jp-test.asd cl-weather-jp.asd +cl-webdav http://beta.quicklisp.org/archive/cl-webdav/2017-08-30/cl-webdav-20170830-git.tgz 77311 9b5b1bbe0b24734a652a464f6924a019 68cbdcabb6c6e8c61ff4757554efa3e83af3e2a1 cl-webdav-20170830-git cl-webdav.asd +cl-webkit http://beta.quicklisp.org/archive/cl-webkit/2017-12-27/cl-webkit-20171227-git.tgz 19659 defcdf910b41f57bc33030b491596f6f 1915c831bf12e3418db939e7828021ec0b35c402 cl-webkit-20171227-git dom/cl-webkit-dom.asd soup/cl-soup.asd tests/cl-webkit2-tests.asd webkit2/cl-webkit2.asd +cl-who http://beta.quicklisp.org/archive/cl-who/2019-07-10/cl-who-20190710-git.tgz 24786 e5bb2856ed62d76528e4cef7b5e701c0 5ef6d9b6609320a8f11655194b9139f5e0a1555a cl-who-20190710-git cl-who.asd +cl-why http://beta.quicklisp.org/archive/cl-why/2018-02-28/cl-why-20180228-git.tgz 25872 00a337f35a516372da41415d25fb879b 86790d0b92642b89a6fde16249597db175cfb407 cl-why-20180228-git cl-why.asd +cl-wordcut http://beta.quicklisp.org/archive/cl-wordcut/2016-04-21/cl-wordcut-20160421-git.tgz 301706 1f251cf2df7f1946887d09c82e3ce968 4b7bbb407529d93d44f9799646a19301c9a81826 cl-wordcut-20160421-git cl-wordcut.asd +cl-xdg http://beta.quicklisp.org/archive/cl-xdg/2017-01-24/cl-xdg-20170124-git.tgz 22666 eaf304bd5c23c58f45f161afe180c2d4 dbdcbe7542181ebf9bfde5c57f120543a937911a cl-xdg-20170124-git cl-xdg.asd +cl-xkb http://beta.quicklisp.org/archive/cl-xkb/2018-02-28/cl-xkb-20180228-git.tgz 2792 97ba20ff9ea183afe00ea2cf7e0469f4 1a9f7395f10de77372af1dceee3b930814ae3173 cl-xkb-20180228-git cl-xkb.asd +cl-xkeysym http://beta.quicklisp.org/archive/cl-xkeysym/2014-09-14/cl-xkeysym-20140914-git.tgz 38246 15ad40d06aa25589bdb59ac5ef485b8c 3d95e7111d9560e75772dbdbd6655b917ede6d47 cl-xkeysym-20140914-git cl-xkeysym.asd +cl-xmlspam http://beta.quicklisp.org/archive/cl-xmlspam/2010-10-06/cl-xmlspam-20101006-http.tgz 10705 6e3a0944e96e17916b1445f4207babb8 82b47ae3227d537486d6bea267c473a068729ecd cl-xmlspam-20101006-http cl-xmlspam.asd +cl-xmpp http://beta.quicklisp.org/archive/cl-xmpp/2010-10-06/cl-xmpp-0.8.1.tgz 15271 303b035edd3bde5aa85c423278298e88 23935110f714202ce650c7e31af12fbbc1f22130 cl-xmpp-0.8.1 cl-xmpp-sasl.asd cl-xmpp-tls.asd cl-xmpp.asd +cl-xul http://beta.quicklisp.org/archive/cl-xul/2016-03-18/cl-xul-20160318-git.tgz 518863 2fbb767b222e632df40a3b7a57aa7f3e 19ad37e6129833ed96d57f92246922462d8f9fb9 cl-xul-20160318-git cl-xul-test.asd cl-xul.asd +cl-yacc http://beta.quicklisp.org/archive/cl-yacc/2010-10-06/cl-yacc-20101006-darcs.tgz 18774 748b9d59de8be3ccfdf0f001e15972ba 7e224cde172cc9db229385fcef1ee411403f9ff6 cl-yacc-20101006-darcs yacc.asd +cl-yaclyaml http://beta.quicklisp.org/archive/cl-yaclyaml/2016-08-25/cl-yaclyaml-20160825-git.tgz 35546 73ddfe97a2b8214e319b366245a216c2 fd3ddd09d55fb1176db7b23f16e3874d6c5018a6 cl-yaclyaml-20160825-git cl-yaclyaml.asd +cl-yahoo-finance http://beta.quicklisp.org/archive/cl-yahoo-finance/2013-03-12/cl-yahoo-finance-20130312-git.tgz 7759 ef1129e9f2bd7afbdde50048db25cc94 9801bb213a303af511c38d63a126b718a2b65085 cl-yahoo-finance-20130312-git cl-yahoo-finance.asd +cl-yaml http://beta.quicklisp.org/archive/cl-yaml/2017-01-24/cl-yaml-20170124-git.tgz 13310 97c545287084ae110c9ef9a76f44285e 5cd19d7b27dde6dfe7322e09729589d5b7839798 cl-yaml-20170124-git cl-yaml-test.asd cl-yaml.asd +cl-yesql http://beta.quicklisp.org/archive/cl-yesql/2019-12-27/cl-yesql-20191227-git.tgz 13398 d3fdef812f1c623db325feddb748449f 4036cd4d7f36483f83c4df9be5c76aa440c90b41 cl-yesql-20191227-git cl-yesql.asd +cl-zmq http://beta.quicklisp.org/archive/cl-zmq/2016-03-18/cl-zmq-20160318-git.tgz 13519 2edc111c3fa50504eb2ef997f9ded9c4 b50410e4f435a9e85b3d91df8101fb2048594ab0 cl-zmq-20160318-git zeromq.asd +cl4store http://beta.quicklisp.org/archive/cl4store/2015-03-02/cl4store-20150302-git.tgz 11305 a1a877db84a10e143004f580317c682f b29433e5ff5be42bdf7cea25e30ff378e22aa935 cl4store-20150302-git cl4store-tests.asd cl4store.asd +clache http://beta.quicklisp.org/archive/clache/2017-11-30/clache-20171130-git.tgz 5875 e319e26205af015787e5cd893eeb58cd 2c09d8401c5e225019bb7393ca899e0056f31790 clache-20171130-git clache-test.asd clache.asd +clack http://beta.quicklisp.org/archive/clack/2019-10-07/clack-20191007-git.tgz 194174 25741855fa1e989d373ac06ddfabf351 b7adffcaef66722766d91b6cd684f2bf1123a839 clack-20191007-git clack-handler-fcgi.asd clack-handler-hunchentoot.asd clack-handler-toot.asd clack-handler-wookie.asd clack-socket.asd clack-test.asd clack-v1-compat.asd clack.asd t-clack-handler-fcgi.asd t-clack-handler-hunchentoot.asd t-clack-handler-toot.asd t-clack-handler-wookie.asd t-clack-v1-compat.asd v1-compat/clack-middleware-auth-basic.asd v1-compat/clack-middleware-clsql.asd v1-compat/clack-middleware-csrf.asd v1-compat/clack-middleware-dbi.asd v1-compat/clack-middleware-oauth.asd v1-compat/clack-middleware-postmodern.asd v1-compat/clack-middleware-rucksack.asd v1-compat/clack-session-store-dbi.asd v1-compat/t-clack-middleware-auth-basic.asd v1-compat/t-clack-middleware-csrf.asd +clack-errors http://beta.quicklisp.org/archive/clack-errors/2019-08-13/clack-errors-20190813-git.tgz 278838 bbae5cf71b4d95e5dbb51c1b8cc11ff0 35df80382645afdbc51214118d2542bd446e3e6a clack-errors-20190813-git clack-errors-demo.asd clack-errors-test.asd clack-errors.asd lack-middleware-clack-errors.asd +clack-pretend http://beta.quicklisp.org/archive/clack-pretend/2017-11-30/clack-pretend-20171130-git.tgz 6573 618f531237dd52bfd5a5a821adaf2e39 a9979ccdd776ed6045de839bbd946f36162610e9 clack-pretend-20171130-git clack-pretend.asd +clack-static-asset-middleware http://beta.quicklisp.org/archive/clack-static-asset-middleware/2016-06-28/clack-static-asset-middleware-20160628-git.tgz 21786 9ee4736d1d084e1481454454a019b6fc 646c3fe12943be8d595913db958b2bc9bdcbaefe clack-static-asset-middleware-20160628-git clack-static-asset-djula-helpers.asd clack-static-asset-middleware-test.asd clack-static-asset-middleware.asd +clad http://beta.quicklisp.org/archive/clad/2019-03-07/clad-20190307-git.tgz 2549 bcac73710bff9ee6179f9c3b58f7da8e 36c35e7c4469b7ae22901c0c24e205fec94dc02e clad-20190307-git clad.asd +classimp http://beta.quicklisp.org/archive/classimp/2017-10-19/classimp-20171019-git.tgz 31643 25b91b1fa7d0b66c2ff89670fd6b54a9 5c31a29f474b74a20e0c91f253d44128450dcafc classimp-20171019-git classimp-samples.asd classimp.asd +classowary http://beta.quicklisp.org/archive/classowary/2019-10-07/classowary-20191007-git.tgz 24900 a2587986780a40251b0327686b817cc6 cce68e75254543ae11458499c408544f67dda874 classowary-20191007-git classowary-test.asd classowary.asd +clath http://beta.quicklisp.org/archive/clath/2017-11-30/clath-20171130-git.tgz 19773 e0c7ad1e7ac1c23f3ff8839ac48df7e8 0dea05c8eb86ad2816a4458cf15b1e5f5ec44a12 clath-20171130-git clath.asd cljwt-custom.asd +clavatar http://beta.quicklisp.org/archive/clavatar/2012-10-13/clavatar-20121013-git.tgz 3375 2861593e34c92b4faa7edb77be6044bb caf33a796f42b398be84fb304753622550cd41f1 clavatar-20121013-git clavatar.asd +clavier http://beta.quicklisp.org/archive/clavier/2017-08-30/clavier-20170830-git.tgz 7176 f6a24e93771e4426843fe5d13a3ff9b9 b3750931a63da718edec5a58e169adb00a3e24a9 clavier-20170830-git clavier.asd clavier.test.asd +claw http://beta.quicklisp.org/archive/claw/2018-08-31/claw-stable-9877cb7d-git.tgz 30850 6395c0bc853474d8ffb7a12754ccaade d9b1acdca9ecfaec7371f87452b6062e13cd81b0 claw-stable-9877cb7d-git claw.asd +clawk http://beta.quicklisp.org/archive/clawk/2011-11-05/clawk-20111105-git.tgz 14059 8ca7378b4dbae7d51644834cd9641f67 eaf0348d0ddcd167ed799e3b19d2eb976982537e clawk-20111105-git clawk.asd +clazy http://beta.quicklisp.org/archive/clazy/2019-01-07/clazy-20190107-git.tgz 24055 e0c29871eb4c7e80658511e9d20de6ea 3eeac3b7b971ea4ef80ebafafacbf650dc0e61f3 clazy-20190107-git clazy.asd +clem http://beta.quicklisp.org/archive/clem/2019-03-07/clem-20190307-git.tgz 84528 444f88b3b087a833d005b2b11f218e39 fd1abd391562801cc472c1e73bb74235b421cc01 clem-20190307-git clem-benchmark.asd clem-test.asd clem.asd +cleric http://beta.quicklisp.org/archive/cleric/2014-11-06/cleric-20141106-git.tgz 19915 2d51ed0118d3e4bd2c72668f109687a7 1226afbf0cd42110008438f9f283d3c52b2bfc46 cleric-20141106-git cleric-test.asd cleric.asd +clesh http://beta.quicklisp.org/archive/clesh/2019-07-10/clesh-20190710-git.tgz 8024 a9ce7e59326ca10074be1b73a1bfe83d e557ae5bff0ff9d20c43c91b63804c24049f6f79 clesh-20190710-git clesh-tests.asd clesh.asd +cletris http://beta.quicklisp.org/archive/cletris/2015-10-31/cletris-20151031-git.tgz 190792 d5b1f4c3a76675498491d191cadc7414 13e5975c8e01aedc97e4d14e5c1355e06c1fa6da cletris-20151031-git cletris-network.asd cletris-test.asd cletris.asd +clfswm http://beta.quicklisp.org/archive/clfswm/2016-12-04/clfswm-20161204-git.tgz 282721 dc976785ef899837ab0fc50a4ed6b740 f745e9682f549b4d92d31e3e7fcec68d561af370 clfswm-20161204-git clfswm.asd +clhs http://beta.quicklisp.org/archive/clhs/2015-04-07/clhs-0.6.3.tgz 2238743 37b804be8696e555a74f240ebc17bbc6 f1c4c385996573194e15316c2f4167f6d3998859 clhs-0.6.3 clhs.asd +clickr http://beta.quicklisp.org/archive/clickr/2014-07-13/clickr-20140713-git.tgz 23238 264cae768921c6e264d909bb4c40e873 af914f21f5a5cac958bfd57128000580dab268e5 clickr-20140713-git clickr.asd +clim-widgets http://beta.quicklisp.org/archive/clim-widgets/2018-02-28/clim-widgets-20180228-git.tgz 12167 b7f7093c7702fc6718c8b693a0ca9a6d db343ca3b774bb82515726ed5a509eb248b5e6a1 clim-widgets-20180228-git clim-widgets.asd +climacs http://beta.quicklisp.org/archive/climacs/2019-01-07/climacs-20190107-git.tgz 111467 a9b75b0f78c15d60ad47f7b87e68c903 c8d7a8ef35285367211e7867e1cd3f66891159bf climacs-20190107-git climacs.asd +climc http://beta.quicklisp.org/archive/climc/2015-09-23/climc-20150923-git.tgz 214296 c6ada8af39d27cf972f269fb2b0e3778 47cb3636d8a6bef908a58b6662d1020bbe6bf40a climc-20150923-git climc-test.asd climc.asd +climon http://beta.quicklisp.org/archive/climon/2015-10-31/climon-20151031-git.tgz 1005444 8e47631f5e0f6157e6581e746c5d3edf 6d02953a6250f423579e25efd65c1b5d2f1b6cec climon-20151031-git climon-test.asd climon.asd +clinch http://beta.quicklisp.org/archive/clinch/2018-02-28/clinch-20180228-git.tgz 15291213 26477d753d550ae020ae95c60315d8b3 232f53345667193c6f4899ab6322d31066e31eef clinch-20180228-git clinch-cairo.asd clinch-classimp.asd clinch-freeimage.asd clinch-pango.asd clinch.asd +clinenoise http://beta.quicklisp.org/archive/clinenoise/2018-01-31/clinenoise-20180131-git.tgz 5651 b72593638356978c952e69dc56fab335 c7837c33b327e4cf7db670804de80652e096d3c3 clinenoise-20180131-git clinenoise.asd +clip http://beta.quicklisp.org/archive/clip/2019-07-10/clip-20190710-git.tgz 23116 3a990d1a030d153c76def305df568c77 a48649b95c51b239c6f11ec4e592dd377c40a31c clip-20190710-git clip.asd +clipper http://beta.quicklisp.org/archive/clipper/2015-09-23/clipper-20150923-git.tgz 30698 a8d3f3fa89f2d31dd864a55a93604973 d45c4f34e7ea6db2ad08811d2f2b104dd9e5afbc clipper-20150923-git clipper-test.asd clipper.asd +clite http://beta.quicklisp.org/archive/clite/2013-06-15/clite-20130615-git.tgz 4207 e9ec17416118a4bc561b7ac0b1c8fe55 a33f68199901025b79110bb113ac204b47008231 clite-20130615-git clite.asd +clml http://beta.quicklisp.org/archive/clml/2018-08-31/clml-20180831-git.tgz 1008543 4c16c4b23748faa9f35e158f782404c2 358e2da5905a6b151724cd72e16d0bbde32aab7f clml-20180831-git addons/fork-future/fork-future.asd addons/future/future.asd association-rule/clml.association-rule.asd blas/clml.blas.asd blas/f2cl-lib.asd classifiers/clml.classifiers.asd clml.asd clustering/clml.clustering.asd data/clml.data.asd data/r-datasets/clml.data.r-datasets.asd decision-tree/clml.decision-tree.asd docs/clml.docs.asd graph/clml.graph.asd hjs/clml.hjs.asd lapack/clml.lapack.asd nearest-search/clml.nearest-search.asd nonparametric/clml.nonparametric.asd numeric/clml.numeric.asd pca/clml.pca.asd som/clml.som.asd statistics/clml.statistics.asd statistics/clml.statistics.rand.asd svm/clml.svm.asd test/clml.test.asd text/clml.text.asd time-series/clml.time-series.asd utility/clml.utility.asd +clnuplot http://beta.quicklisp.org/archive/clnuplot/2013-01-28/clnuplot-20130128-darcs.tgz 31274 0e5dccbbbe3408b3e0aebf639691c6a0 6a2749d3b7ef6bd1325b92160bb9eee35f099c96 clnuplot-20130128-darcs clnuplot.asd +clobber http://beta.quicklisp.org/archive/clobber/2019-05-21/clobber-20190521-git.tgz 6301 2a2d5490aa21ed847eff57bae8148582 f26247f00fc4821bb9a71756359ea4c78515d52c clobber-20190521-git clobber.asd +clod http://beta.quicklisp.org/archive/clod/2019-03-07/clod-20190307-hg.tgz 98259 df582b015aa80397402eee3bb5a13288 c3bc36581145c5abc6126b2c3ba88386f6ba7876 clod-20190307-hg clod.asd +clods-export http://beta.quicklisp.org/archive/clods-export/2017-10-19/clods-export-20171019-git.tgz 19990 342fb1799b9f0c2549666b204f9cb322 6554a4c2d68216e9fa33dc67a6096886c153df40 clods-export-20171019-git clods-export.asd +clon http://beta.quicklisp.org/archive/clon/2011-03-20/clon-20110320-git.tgz 7926 92c40493948d3466d1b149a000985ce0 db47fb37cae16262070c9d711ec49dd01b0075c0 clon-20110320-git clon-test.asd clon.asd +clonsigna http://beta.quicklisp.org/archive/clonsigna/2012-09-09/clonsigna-20120909-git.tgz 42948 3ae74680c33dfd5880914dac3873357c 11bf0a3df0e3309a054015629c01a282148208e5 clonsigna-20120909-git clonsigna.asd +clos-diff http://beta.quicklisp.org/archive/clos-diff/2015-06-08/clos-diff-20150608-git.tgz 14486 88dbce5dc199deb2ee44e7cb73946db0 8825ffc50639addefd79f604addcacf17309f512 clos-diff-20150608-git clos-diff.asd +clos-fixtures http://beta.quicklisp.org/archive/clos-fixtures/2016-08-25/clos-fixtures-20160825-git.tgz 2687 68898ca907a135d733ecdadb3f8b5723 75e8f147882b9e7fb56519a8c8a91d00798b1df7 clos-fixtures-20160825-git clos-fixtures-test.asd clos-fixtures.asd +closer-mop http://beta.quicklisp.org/archive/closer-mop/2019-12-27/closer-mop-20191227-git.tgz 23507 67dda2ff56690bb8eec6131983605031 7e849ccb36b31b485f8bb4b6a84f84ba03ced65c closer-mop-20191227-git closer-mop.asd +closure-common http://beta.quicklisp.org/archive/closure-common/2018-10-18/closure-common-20181018-git.tgz 27833 b09ee60c258a29f0c107960ec4c04ada 42e2f882070d49d3224c15a304354afb29f97841 closure-common-20181018-git closure-common.asd +closure-html http://beta.quicklisp.org/archive/closure-html/2018-07-11/closure-html-20180711-git.tgz 103413 461dc8caa65385da5f2d1cd8dd4f965f d8e52dc5d129aec699cd405c14a9080d01199506 closure-html-20180711-git closure-html.asd +clouchdb http://beta.quicklisp.org/archive/clouchdb/2012-04-07/clouchdb_0.0.16.tgz 33759 d39f8e71a5e1954b40af4291f0c05757 7d254f6edf1a28300e4c4c3fa387b4cfcdf24b28 clouchdb_0.0.16 clouchdb-examples.asd clouchdb.asd +clsql http://beta.quicklisp.org/archive/clsql/2016-02-08/clsql-20160208-git.tgz 968869 d1da7688361337a7de4fe7452c225a06 6cefb5c9d783acecb94b66e288faba7d1d7367e2 clsql-20160208-git clsql-aodbc.asd clsql-cffi.asd clsql-mysql.asd clsql-odbc.asd clsql-postgresql-socket.asd clsql-postgresql-socket3.asd clsql-postgresql.asd clsql-sqlite.asd clsql-sqlite3.asd clsql-tests.asd clsql-uffi.asd clsql.asd +clsql-fluid http://beta.quicklisp.org/archive/clsql-fluid/2017-08-30/clsql-fluid-20170830-git.tgz 4361 cd6191a16e81af2670f3ed84b29995b8 af7e03aca8277efe730c86075f3587be71a357c1 clsql-fluid-20170830-git clsql-fluid.asd +clsql-helper http://beta.quicklisp.org/archive/clsql-helper/2018-01-31/clsql-helper-20180131-git.tgz 31200 e3040bc42b24c8b0845abcd4a74d3db4 b92225c63d358fac585ce63bc132cca4bac1f50c clsql-helper-20180131-git clsql-helper-slot-coercer.asd clsql-helper.asd +clsql-local-time http://beta.quicklisp.org/archive/clsql-local-time/2019-11-30/clsql-local-time-20191130-git.tgz 1688 180d36508b76a5d9728f3e88fda8047d c0d26ade44c4ffbae84db81db346a6de3c727477 clsql-local-time-20191130-git clsql-local-time.asd +clsql-orm http://beta.quicklisp.org/archive/clsql-orm/2016-02-08/clsql-orm-20160208-git.tgz 19760 40b31c2bfbf7b27f35b362fc4cffb6bf 4d07a98d77328076b0844f4708c56087f5618426 clsql-orm-20160208-git clsql-orm.asd +clss http://beta.quicklisp.org/archive/clss/2019-11-30/clss-20191130-git.tgz 20000 9910677b36df00f3046905a9b84122a9 440121bc862ddcd72c421df4ade798ecfb26242a clss-20191130-git clss.asd +cltcl http://beta.quicklisp.org/archive/cltcl/2016-12-04/cltcl-20161204-git.tgz 338065 bb57496aeea233c7adb04e3bb6eca551 8d9140fafe4658324f8b354159cdef6d8c9d174b cltcl-20161204-git cltcl.asd +clump http://beta.quicklisp.org/archive/clump/2016-08-25/clump-20160825-git.tgz 25593 5132d2800138d435ef69f7e68b025c8f 68760a1e2e6e28ecf8f45e5b766774bc3a18e369 clump-20160825-git 2-3-tree/clump-2-3-tree.asd Binary-tree/clump-binary-tree.asd Test/clump-test.asd clump.asd +clunit http://beta.quicklisp.org/archive/clunit/2017-10-19/clunit-20171019-git.tgz 76811 389017f2f05a6287078ddacd0471817e 26340b858b8c784b90cda75ab57470410507d191 clunit-20171019-git clunit.asd +clunit2 http://beta.quicklisp.org/archive/clunit2/2018-10-18/clunit2-20181018-git.tgz 77822 44d69b87557a924fe8d49eaac739c20e cbb4457813e643061d977a5c5817f6a956888ed3 clunit2-20181018-git clunit2.asd +clutz http://beta.quicklisp.org/archive/clutz/2018-02-28/clutz-stable-0a544be0-git.tgz 2523 544e6326659345ecd6db81f774995660 1e9575546d2b360c777fb08aa8db7a61df62e651 clutz-stable-0a544be0-git clutz.asd +clweb http://beta.quicklisp.org/archive/clweb/2018-04-30/clweb-20180430-git.tgz 138871 a57892e3a6fe9fa2dbe7a2c1865e82c6 a37cbe2c941a71c08dbe47a5de7f55b9caeedc84 clweb-20180430-git clweb.asd +clws http://beta.quicklisp.org/archive/clws/2013-08-13/clws-20130813-git.tgz 32371 11a801aadeda244b749c2b36a19b9af9 521463b0aef355a1307f911327fee5ed5d65854d clws-20130813-git clws.asd +clx http://beta.quicklisp.org/archive/clx/2019-11-30/clx-20191130-git.tgz 457343 61e86a60727732df62c9fa383535fc89 0a39c0f03919c2e5c7730ef9c760fdd1f9471f6e clx-20191130-git clx.asd +clx-cursor http://beta.quicklisp.org/archive/clx-cursor/2018-01-31/clx-cursor-20180131-git.tgz 183731 227e05446493e0fc20836aeb90c0e500 6b37027d762656bb0b9fcaf82fa865b2dd57173c clx-cursor-20180131-git clx-cursor.asd +clx-truetype http://beta.quicklisp.org/archive/clx-truetype/2016-08-25/clx-truetype-20160825-git.tgz 376571 7c9dedb21d52dedf727de741ac6d9c60 9902edbe06af953b755beca024521c21d3f068c6 clx-truetype-20160825-git clx-truetype.asd +clx-xembed http://beta.quicklisp.org/archive/clx-xembed/2019-11-30/clx-xembed-20191130-git.tgz 21169 11d35eeb734c0694005a5e5cec4cad22 27ec06dc8e843deb1fd1b01058e78627e5dbf424 clx-xembed-20191130-git xembed.asd +clx-xkeyboard http://beta.quicklisp.org/archive/clx-xkeyboard/2012-08-11/clx-xkeyboard-20120811-git.tgz 47002 4e382b34e05d33f5de8e9c9dea33131c f18ddbbf8f7e5222cb44e2543386a8efd49abb7c clx-xkeyboard-20120811-git xkeyboard.asd +cmake-parser http://beta.quicklisp.org/archive/cmake-parser/2018-08-31/cmake-parser-20180831-git.tgz 5470 901e49335a490ad419aec7bcd4493d47 adc648f94bfc8e9e0834075e88f4098dafd9e982 cmake-parser-20180831-git cmake-parser.asd +cmu-infix http://beta.quicklisp.org/archive/cmu-infix/2018-02-28/cmu-infix-20180228-git.tgz 22615 6baab7e8fdbb211c1b1622073b9521c9 408f16c7594f02f53e39ea8b7684721d12406435 cmu-infix-20180228-git cmu-infix-tests.asd cmu-infix.asd +codata-recommended-values http://beta.quicklisp.org/archive/codata-recommended-values/2017-10-19/codata-recommended-values-20171019-git.tgz 186586 99a0ddb582b1182f499d0c94e41a45e9 628cba44e3699d2bb9194be9ceeac63c453008b5 codata-recommended-values-20171019-git codata-recommended-values.asd +codex http://beta.quicklisp.org/archive/codex/2018-12-10/codex-20181210-git.tgz 185947 7c33d0361d2e50d968aade71461443f4 7d7ee6fbc90ecdaa755d4f2f1b986d24d03ff912 codex-20181210-git codex-templates.asd codex.asd +coleslaw http://beta.quicklisp.org/archive/coleslaw/2019-11-30/coleslaw-20191130-git.tgz 165818 6c356af48e856daacfcd067c9e9a40af ce4f0603534ad09748bdbf16305084433f9ad6a1 coleslaw-20191130-git coleslaw-cli.asd coleslaw-test.asd coleslaw.asd +collectors http://beta.quicklisp.org/archive/collectors/2016-12-04/collectors-20161204-git.tgz 10522 59c8c885a8e512d4f09e73d3e0c97b1f 1e386552e3b2900580e3972c46152fb776dcc28a collectors-20161204-git collectors.asd +colleen http://beta.quicklisp.org/archive/colleen/2018-10-18/colleen-20181018-git.tgz 145758 b20ec13f6a9612e0f496af7eccb24f54 950fa71177e3966ae52eb7a986d9ceeeb5e117ed colleen-20181018-git colleen.asd +colliflower http://beta.quicklisp.org/archive/colliflower/2015-12-18/colliflower-20151218-git.tgz 24042 68f0d511fe9429919859b184e6b564e1 c02b61ea1e6f1732201ce36d3718c3eab9bce190 colliflower-20151218-git colliflower-test.asd colliflower.asd contrib/fset/colliflower-fset.asd garten/garten.asd liter/liter.asd silo/silo.asd +colorize http://beta.quicklisp.org/archive/colorize/2018-02-28/colorize-20180228-git.tgz 39488 1bc08c8f76b747e4d254669a205dc611 e0658fa18ae562a802f987eff7f16a8bc78906f8 colorize-20180228-git colorize.asd +com.clearly-useful.generic-collection-interface http://beta.quicklisp.org/archive/com.clearly-useful.generic-collection-interface/2019-07-10/com.clearly-useful.generic-collection-interface-20190710-git.tgz 14043 b22496129d4171c50de7ab85da024cc0 0dac346508bb07e3237054a0554c2c6d28153020 com.clearly-useful.generic-collection-interface-20190710-git com.clearly-useful.generic-collection-interface.asd com.clearly-useful.generic-collection-interface.test.asd +com.clearly-useful.iterate-plus http://beta.quicklisp.org/archive/com.clearly-useful.iterate-plus/2012-10-13/com.clearly-useful.iterate-plus-20121013-git.tgz 1981 691606442da9344a1b871a986dc83a42 c7a315d2b09d7666def427dc37cad324317caf51 com.clearly-useful.iterate-plus-20121013-git com.clearly-useful.iterate+.asd +com.clearly-useful.iterator-protocol http://beta.quicklisp.org/archive/com.clearly-useful.iterator-protocol/2013-03-12/com.clearly-useful.iterator-protocol-20130312-git.tgz 2846 b6219074982d29677ebf5a7ae1b5a22e 5f9051fdccbd78f3c919112a67acf80587c921d9 com.clearly-useful.iterator-protocol-20130312-git com.clearly-useful.iterator-protocol.asd +com.clearly-useful.protocols http://beta.quicklisp.org/archive/com.clearly-useful.protocols/2013-03-12/com.clearly-useful.protocols-20130312-git.tgz 8625 7a230b991c6f410f2f1f1cc016aa3ae1 174ae8cc771b48bc36f4ae2ee3dfb80fef266d60 com.clearly-useful.protocols-20130312-git com.clearly-useful.protocols.asd +com.google.base http://beta.quicklisp.org/archive/com.google.base/2015-10-31/com.google.base-20151031-git.tgz 6837 3ed818c26feeee4eba6dacbe4be622d5 51b658344270cf398a34798b321a377ca855bb8a com.google.base-20151031-git com.google.base-test.asd com.google.base.asd +command-line-arguments http://beta.quicklisp.org/archive/command-line-arguments/2019-12-27/command-line-arguments-20191227-git.tgz 11927 3ed82e1536b55fc0b7abc79626631aab 213d0538910a379a65c7919b2d39aee3abfe2cab command-line-arguments-20191227-git command-line-arguments.asd +common-doc http://beta.quicklisp.org/archive/common-doc/2016-04-21/common-doc-20160421-git.tgz 51299 516b26eb281a2c7a13161eb2346915f8 1a70ab2230e492f5f3a0bfb6ad8adc3a25332537 common-doc-20160421-git common-doc-contrib.asd common-doc-gnuplot.asd common-doc-graphviz.asd common-doc-include.asd common-doc-split-paragraphs.asd common-doc-test.asd common-doc-tex.asd common-doc.asd +common-doc-plump http://beta.quicklisp.org/archive/common-doc-plump/2016-04-21/common-doc-plump-20160421-git.tgz 6172 5e53d47b0bb2ad2d5bc1d6686b1446ba dc865b5fd8705da9ddbb20a44742ec5454679e12 common-doc-plump-20160421-git common-doc-plump-test.asd common-doc-plump.asd +common-html http://beta.quicklisp.org/archive/common-html/2016-04-21/common-html-20160421-git.tgz 7660 ab70df0dff34edb91d21b9eca3d5ba68 79ba08f283f191a1deeb0952447daded2e44cddf common-html-20160421-git common-html-test.asd common-html.asd +common-lisp-actors http://beta.quicklisp.org/archive/common-lisp-actors/2019-11-30/common-lisp-actors-20191130-git.tgz 4753 890e04c2f7df07e7180cbc7d81ed7bb5 5e927cacbb0fa3a49605423ca50b41626c1af00b common-lisp-actors-20191130-git cl-actors.asd +common-lisp-jupyter http://beta.quicklisp.org/archive/common-lisp-jupyter/2019-10-08/common-lisp-jupyter-20191008-git.tgz 84042 0a4b1e448dcaa528e7e43b2263a6bd59 2e3c7e7c98959c7200b651e744c43527ccdd2bd8 common-lisp-jupyter-20191008-git common-lisp-jupyter.asd +commonqt http://beta.quicklisp.org/archive/commonqt/2019-12-27/commonqt-20191227-git.tgz 61085 ec5826978ee14110ac866417388a24bf aaa433fca64abbf9b30d4714b8e1e9015bc2df37 commonqt-20191227-git qt+libs.asd qt-repl.asd qt-test.asd qt-tutorial.asd qt.asd +computable-reals http://beta.quicklisp.org/archive/computable-reals/2018-03-28/computable-reals-20180328-git.tgz 8146 9b7c4ffa4d91b1197be9f39621141175 f2d454e6bf5d6416d0a37605e9ec9f4a35c087f8 computable-reals-20180328-git computable-reals.asd +concrete-syntax-tree http://beta.quicklisp.org/archive/concrete-syntax-tree/2019-12-27/concrete-syntax-tree-20191227-git.tgz 42755 fc393a473bca784545f877c661e15fc7 36a516d426224a7d5e1e0b8bf06d608154ae7121 concrete-syntax-tree-20191227-git Destructuring/concrete-syntax-tree-destructuring.asd Lambda-list/Test/concrete-syntax-tree-lambda-list-test.asd Lambda-list/concrete-syntax-tree-lambda-list.asd Source-info/concrete-syntax-tree-source-info.asd concrete-syntax-tree-base.asd concrete-syntax-tree.asd +conduit-packages http://beta.quicklisp.org/archive/conduit-packages/2014-08-26/conduit-packages-20140826-http.tgz 5758 44257db8bdf0b87c42c5cb7e33e8efe3 a45e8aa50874f7837c4805df443266f9f496bb2a conduit-packages-20140826-http conduit-packages.asd +conf http://beta.quicklisp.org/archive/conf/2019-12-27/conf-20191227-git.tgz 15652 8b1e1498234b7b4d3ca9cd2f52b66415 9a5e80439fbb82d433465c632c8f901613a4baf5 conf-20191227-git conf.asd +configuration.options http://beta.quicklisp.org/archive/configuration.options/2019-07-10/configuration.options-20190710-git.tgz 129476 2ca51419ca5f6c62566cef94c5bf6c25 6a8c25c3a4ccb040f87f7b346df6d475fb8c415e configuration.options-20190710-git configuration.options-and-mop.asd configuration.options-and-puri.asd configuration.options-and-quri.asd configuration.options-and-service-provider.asd configuration.options-source-commandline.asd configuration.options-syntax-ini.asd configuration.options-syntax-xml.asd configuration.options.asd +conium http://beta.quicklisp.org/archive/conium/2018-08-31/conium-20180831-git.tgz 145062 60d1a37d859310d5bb50be5d2a011a1a 2ef38b57eda9a6bf6820729ab1ee6fddbe74cc2c conium-20180831-git conium.asd +consix http://beta.quicklisp.org/archive/consix/2014-12-17/consix-20141217-git.tgz 15428 6eb2f35075cab83f225f31bc72ffbb4f fb3e12d2614b5ec17d51bcc764990fbb997f4f2f consix-20141217-git consix.asd +constantfold http://beta.quicklisp.org/archive/constantfold/2019-12-27/constantfold-20191227-git.tgz 135729 e9e0021014c6f27280264be16166fee7 378cbed129d745f65125c9f3931f350e92d61c22 constantfold-20191227-git constantfold.asd constantfold.test.asd +contextl http://beta.quicklisp.org/archive/contextl/2019-05-21/contextl-20190521-git.tgz 26348 a4d8c6a69351ed26c0d8e26ebee0b8e1 c7ed0f7757991c10702a48c2d803344105075c23 contextl-20190521-git contextl.asd dynamic-wind.asd +copy-directory http://beta.quicklisp.org/archive/copy-directory/2016-06-28/copy-directory-20160628-git.tgz 2462 b82455b6979b785df488f990e156aa2b fe74b777a2f899c84de338f3c96b732cc1e2d06c copy-directory-20160628-git copy-directory-test.asd copy-directory.asd +corona http://beta.quicklisp.org/archive/corona/2016-08-25/corona-20160825-git.tgz 12412 75fdbf09861689695020ed0bcabb2bb3 bf12260d0c2c3b85f58fab8e872eaa059d9c12ca corona-20160825-git corona-test.asd corona-web.asd corona.asd +cover http://beta.quicklisp.org/archive/cover/2019-02-02/cover-20190202-git.tgz 17172 fdebe8767421553329d3620a2a0fcbc6 644769e371b3d0caaeb3cc676918a33dede6032a cover-20190202-git cover.asd +cqlcl http://beta.quicklisp.org/archive/cqlcl/2014-11-06/cqlcl-20141106-git.tgz 11896 2a63a524e1297e6a2577a29d63bd7ea2 7480e139c03880e1e41bca03ae6fde148a1ce161 cqlcl-20141106-git cqlcl.asd +crane http://beta.quicklisp.org/archive/crane/2016-02-08/crane-20160208-git.tgz 20738 df5119bed5754d9f7811efc770c09d47 d438f1997e83f251bb1b61653a2a0e6a08bccbda crane-20160208-git crane-test.asd crane.asd +croatoan http://beta.quicklisp.org/archive/croatoan/2019-12-27/croatoan-20191227-git.tgz 121276 beeb15e0c4008ad361d7ce20e1b72269 806cdd60ba813226684409a4c61978909343f10e croatoan-20191227-git croatoan-test.asd croatoan.asd +crypto-shortcuts http://beta.quicklisp.org/archive/crypto-shortcuts/2019-07-10/crypto-shortcuts-20190710-git.tgz 7150 2c6df84ebef1bc224c6c54c5112d0e04 bd30d942f16ef49e51a7dac01a799552d23c59fa crypto-shortcuts-20190710-git crypto-shortcuts.asd +cserial-port http://beta.quicklisp.org/archive/cserial-port/2017-04-03/cserial-port-20170403-git.tgz 10621 45e462dce2f7b68d1ca5e61906f115b3 4b2f943955a280573e46f95223f444a525759168 cserial-port-20170403-git cserial-port.asd +css-lite http://beta.quicklisp.org/archive/css-lite/2012-04-07/css-lite-20120407-git.tgz 6073 9b25afb0d2c3f0c32d2303ab1d3f570d 83ad13369198c8170fce93c6171f472fe8d7322a css-lite-20120407-git css-lite.asd +css-selectors http://beta.quicklisp.org/archive/css-selectors/2016-06-28/css-selectors-20160628-git.tgz 14832 28537144b89af4ebe28c2eb365d5569f 67e31993847a16f20b4eda93e1266644a426ff4c css-selectors-20160628-git css-selectors-simple-tree.asd css-selectors-stp.asd css-selectors.asd +csv http://beta.quicklisp.org/archive/csv/2019-07-10/csv-20190710-git.tgz 14041 cecd51e92195eb497c4b20d82c90930a 18cfd80c132c100ddac12ea2f82e9030783e0649 csv-20190710-git csv.asd +csv-parser http://beta.quicklisp.org/archive/csv-parser/2014-07-13/csv-parser-20140713-git.tgz 5012 d8f43b3da734b63f2064b7cd4c6f7550 033d33a6821c836cce4b2299e5ea688807ea12b3 csv-parser-20140713-git csv-parser.asd +cue-parser http://beta.quicklisp.org/archive/cue-parser/2018-02-28/cue-parser-20180228-git.tgz 6196 a762d2f16148e031ac658c19bc35fe95 dde1439487e627ca02f8d1e9641fbe40696b45bd cue-parser-20180228-git cue-parser.asd +curly http://beta.quicklisp.org/archive/curly/2012-04-07/curly-20120407-git.tgz 4647 abbdcfe5c08ee02a8f9014373db6fd86 adfe3715c7311e6a27755ca3da84155bcf93641a curly-20120407-git curly.asd +curry-compose-reader-macros http://beta.quicklisp.org/archive/curry-compose-reader-macros/2019-11-30/curry-compose-reader-macros-20191130-git.tgz 2800 013cf0caa673751961380f5f5d3d61be 25aa6825abe58369592458d8a5d855e7617ce396 curry-compose-reader-macros-20191130-git curry-compose-reader-macros.asd +curve http://beta.quicklisp.org/archive/curve/2013-01-28/curve-20130128-git.tgz 19617 f4c1a224405586a04d65cac6b38a5ccc 000367ed6ad72b814a533a633506ef30fda97271 curve-20130128-git com.elbeno.curve.asd +cxml http://beta.quicklisp.org/archive/cxml/2018-10-18/cxml-20181018-git.tgz 155061 33c5546de7099d65fdb2fbb716fd3de8 2e661fc6f2edb5d0d9c7923a4aa455803a90786b cxml-20181018-git cxml-dom.asd cxml-klacks.asd cxml-test.asd cxml.asd +cxml-rng http://beta.quicklisp.org/archive/cxml-rng/2019-07-10/cxml-rng-20190710-git.tgz 173375 ac7fb180022392f6cb689509bc14bab3 4cd12475c54fe7f34510a5d1d5b5fdb9c6403443 cxml-rng-20190710-git cxml-rng.asd +cxml-rpc http://beta.quicklisp.org/archive/cxml-rpc/2012-10-13/cxml-rpc-20121013-git.tgz 11422 58bca5e93a2f2eb5a5451e689b590c2b 0ada3a401ef59cbf83f0d4601b206895913711f6 cxml-rpc-20121013-git cxml-rpc.asd +cxml-stp http://beta.quicklisp.org/archive/cxml-stp/2019-05-21/cxml-stp-20190521-git.tgz 52265 9e0c99bd2b547e07b23305a5ff72aff6 d33d9dfe96de273f18696d15cf20e48c599f5678 cxml-stp-20190521-git cxml-stp.asd +daemon http://beta.quicklisp.org/archive/daemon/2017-04-03/daemon-20170403-git.tgz 4007 97d52817fa74191a6a07a49cd4a5b907 542f44f5a01f0d8bde303167edfa73cd2b5473cb daemon-20170403-git daemon.asd +dartsclemailaddress http://beta.quicklisp.org/archive/dartsclemailaddress/2016-04-21/dartsclemailaddress-quicklisp-release-48464635-git.tgz 11830 537619b8caa0c43db075a82f732a31ee bc0850e087137a945257bfafdc530b5f256ea5c6 dartsclemailaddress-quicklisp-release-48464635-git darts.lib.email-address-test.asd darts.lib.email-address.asd +dartsclhashtree http://beta.quicklisp.org/archive/dartsclhashtree/2019-11-30/dartsclhashtree-20191130-git.tgz 26824 98695e12a12439121037f85e65601406 2ca276fddec24d9815ad6646c4eb739267d371cf dartsclhashtree-20191130-git darts.lib.hashtree-test.asd darts.lib.hashtrie.asd darts.lib.wbtree.asd +dartsclmessagepack http://beta.quicklisp.org/archive/dartsclmessagepack/2015-05-05/dartsclmessagepack-20150505-git.tgz 8310 3323df326dfc7dc87219de82e14adaf7 5197fa8201d9dc3dccd13795058d49015dfcd57c dartsclmessagepack-20150505-git darts.lib.message-pack-test.asd darts.lib.message-pack.asd +dartsclsequencemetrics http://beta.quicklisp.org/archive/dartsclsequencemetrics/2013-03-12/dartsclsequencemetrics-20130312-git.tgz 8234 2440599722cb58ab64d30a687946166b 2a29fa7b05dff2273678b71dff33d1db79af1ff4 dartsclsequencemetrics-20130312-git darts.lib.sequence-metrics.asd +dartscltools http://beta.quicklisp.org/archive/dartscltools/2019-11-30/dartscltools-20191130-git.tgz 11484 87ea1ba235803b40f427fdcf844253e1 868175cc7f35ef717b1e2b67f55d3cdae4ae5fad dartscltools-20191130-git darts.lib.tools.asd +dartscluuid http://beta.quicklisp.org/archive/dartscluuid/2018-08-31/dartscluuid-20180831-git.tgz 7279 171eb01d8331bf101e4d4a8ca750e3e2 d532f54744a4578ced5481e49788dd034d02a0a0 dartscluuid-20180831-git darts.lib.uuid.asd +data-lens http://beta.quicklisp.org/archive/data-lens/2019-10-07/data-lens-20191007-git.tgz 39424 44764b0bc93f05b680e47c4f3b351a55 c41d78eea00a0beaf13d22a8868d6141842b5c34 data-lens-20191007-git data-lens.asd +data-sift http://beta.quicklisp.org/archive/data-sift/2013-01-28/data-sift-20130128-git.tgz 13070 2d023844d8a181dbbcc69368c3b90a9c 2ca3997e31fd229f29dc332b0a737ab23c62bb62 data-sift-20130128-git data-sift.asd +data-table http://beta.quicklisp.org/archive/data-table/2016-02-08/data-table-20160208-git.tgz 12042 0507150b0fcfdab96e0ef7668d31113c bfa3e175a53bea2d80b7358c7729e944d3781ec8 data-table-20160208-git data-table-clsql.asd data-table.asd +database-migrations http://beta.quicklisp.org/archive/database-migrations/2018-08-31/database-migrations-20180831-git.tgz 3983 2e3f0877c95e8fc8632a9fe7979bfe82 9c364cc2b74d76a3184be7e4a269e156521ae331 database-migrations-20180831-git database-migrations.asd +datafly http://beta.quicklisp.org/archive/datafly/2019-05-21/datafly-20190521-git.tgz 9762 e9f2d71b419516a501a5f9a782bf29d4 cfb320d68b303fa3851a70241bac28ee31aee280 datafly-20190521-git datafly-test.asd datafly.asd +datamuse http://beta.quicklisp.org/archive/datamuse/2019-12-27/datamuse-20191227-git.tgz 5912 a04c3124844336cdfad9bdb77828a11d d41fccf27d49d47e662345fc1e7ea06ef9498d04 datamuse-20191227-git datamuse.asd +date-calc http://beta.quicklisp.org/archive/date-calc/2019-12-27/date-calc-20191227-git.tgz 10417 fda245d738b350711fb614ba18ee01f4 6e55f21ffcedf6a36c8a212fde29a3ebb9f0ce85 date-calc-20191227-git date-calc.asd +datum-comments http://beta.quicklisp.org/archive/datum-comments/2019-08-13/datum-comments-20190813-git.tgz 3625 c3ad1f73fd4ece22e18f3b10106510f4 72113bce610b6b12d800586065c7425c70ae6fc8 datum-comments-20190813-git datum-comments.asd +dbd-oracle http://beta.quicklisp.org/archive/dbd-oracle/2018-03-28/dbd-oracle-20180328-git.tgz 39691 1e82985c46e557525af490981b5006ef fed08c112da3e508042b39d2bd47d59ceb4c3a1c dbd-oracle-20180328-git dbd-oracle-test.asd dbd-oracle.asd +dbus http://beta.quicklisp.org/archive/dbus/2019-05-21/dbus-20190521-git.tgz 23448 59e7ab92086503e4185273ec3f3ba3fc b63649ce3b7aae0107fb13d927a18e2d36cd284e dbus-20190521-git dbus.asd +de.setf.wilbur http://beta.quicklisp.org/archive/de.setf.wilbur/2018-12-10/de.setf.wilbur-20181210-git.tgz 77937 76864fbe1ad7bdf810efa74e2bb4765e 3a699742b7b8738c9f8cf51f391e9571f74b9f15 de.setf.wilbur-20181210-git src/wilbur.asd +declt http://beta.quicklisp.org/archive/declt/2019-11-30/declt-3.0.tgz 63861 3dff95e04c8e2e5b57ae0635b5cd32ec 519ceaae45727e2d7b982a53b657466714cf33bf declt-3.0 core/net.didierverna.declt.core.asd net.didierverna.declt.asd setup/net.didierverna.declt.setup.asd +deeds http://beta.quicklisp.org/archive/deeds/2019-07-10/deeds-20190710-git.tgz 35104 e450e559648cc639d52cd860c3f3acc6 833c7a206bc07c4671717d934d819b65157ec0be deeds-20190710-git deeds.asd +defclass-std http://beta.quicklisp.org/archive/defclass-std/2015-08-04/defclass-std-20150804-git.tgz 8922 cb335ba608a0ba468d3ab4ac8ab7d13c 8d3a192420a1124546d51844d5126732bb06635f defclass-std-20150804-git defclass-std-test.asd defclass-std.asd +defenum http://beta.quicklisp.org/archive/defenum/2019-01-07/defenum-20190107-git.tgz 13085 b6e5252710200ffff90cd26c551315eb aaffa0b7c21837ec518deae878c755be319dd07d defenum-20190107-git defenum.asd +deferred http://beta.quicklisp.org/archive/deferred/2019-07-10/deferred-20190710-git.tgz 5908 0830491b2d6bb9cfbc2a95036b9a7332 438d3927bc5dfe4215aaa39f79207e768ab45444 deferred-20190710-git deferred.asd +define-json-expander http://beta.quicklisp.org/archive/define-json-expander/2014-07-13/define-json-expander-20140713-git.tgz 5026 4f67d0f505ff548d386e3f6f3d24bef9 8ac3161ab7afd1de0a40473d86201b2fff87f17e define-json-expander-20140713-git define-json-expander.asd +definitions http://beta.quicklisp.org/archive/definitions/2019-10-07/definitions-20191007-git.tgz 22808 f108ab481145731b551d7e925658c1a1 e53c14d05bb4326f06e2165b751e5ab102c10761 definitions-20191007-git definitions.asd +definitions-systems http://beta.quicklisp.org/archive/definitions-systems/2018-12-10/definitions-systems-1.0.tgz 7147 611cd6ba8686c7644c6d0247e69e8118 af1e880079f06b7070f926e2a80de74f2d4d500e definitions-systems-1.0 definitions-systems.asd tests/definitions-systems_tests.asd +deflate http://beta.quicklisp.org/archive/deflate/2018-02-28/deflate-20180228-git.tgz 9418 a836910bc7b4b8cd1122d6da73316631 4772d9601c99ea4f91bb956f6e6e705fdb7a8d94 deflate-20180228-git deflate.asd +defmemo http://beta.quicklisp.org/archive/defmemo/2012-04-07/defmemo-20120407-git.tgz 1953 542105d03e8a0d012c21cefffed2f8ad e7d6f9f95ef8866e063c5e35eee1458e6022d7af defmemo-20120407-git defmemo.asd +defpackage-plus http://beta.quicklisp.org/archive/defpackage-plus/2018-01-31/defpackage-plus-20180131-git.tgz 6485 de7af07da901fe5623450d32fd4b7ddc dea6c565dee9b6d821b21a25f4169515e52595df defpackage-plus-20180131-git defpackage-plus.asd +defrec http://beta.quicklisp.org/archive/defrec/2019-03-07/defrec-20190307-hg.tgz 2488 28b1762c6fb45a24487be334d7d5db14 f5ea970dac951fd12455449ba66da09b471596e4 defrec-20190307-hg defrec.asd +defstar http://beta.quicklisp.org/archive/defstar/2014-07-13/defstar-20140713-git.tgz 46970 36db8379ba81239923e5f97dba352d8b 2983be99196ad25ad29404af66a6c61b6eca212a defstar-20140713-git defstar.asd +defsystem-compatibility http://beta.quicklisp.org/archive/defsystem-compatibility/2010-10-06/defsystem-compatibility-20101006-darcs.tgz 9848 ad19788379d30f53165b74683deee776 bc441cffe18d811b971e130cfa94b57938e353ec defsystem-compatibility-20101006-darcs defsystem-compatibility-test.asd defsystem-compatibility.asd +defvariant http://beta.quicklisp.org/archive/defvariant/2014-07-13/defvariant-20140713-git.tgz 10059 34cae097b3a510c71aec8638e6244384 8d43269b616dad7f0d0c9a6725e1614cb5c330c2 defvariant-20140713-git defvariant.asd +delorean http://beta.quicklisp.org/archive/delorean/2013-06-15/delorean-20130615-git.tgz 3788 441d44c6c37939df46fc1f6a549f97d6 f9b4b8ed3e1cf9811a32e19fa64f868598baf1c3 delorean-20130615-git delorean.asd +delta-debug http://beta.quicklisp.org/archive/delta-debug/2018-08-31/delta-debug-20180831-git.tgz 5769 0cfd1860910888e5d129e3a134a58e12 28dd1ae4e76fcd381539b1a09622525b083a7830 delta-debug-20180831-git delta-debug.asd +dendrite http://beta.quicklisp.org/archive/dendrite/2017-10-23/dendrite-release-quicklisp-409b1061-git.tgz 5988 574bb8da79376d36fdf04ae254ba04c5 d14f3b6356f3d6443fd76296e6c1ef32036045ca dendrite-release-quicklisp-409b1061-git dendrite.asd dendrite.micro-l-system.asd dendrite.primitives.asd +deoxybyte-gzip http://beta.quicklisp.org/archive/deoxybyte-gzip/2014-01-13/deoxybyte-gzip-20140113-git.tgz 130916 e6e373d376f3598f7ee3792e586a7dc3 53a1f55a7db874c66d5cf1f1ebf0800559e1584e deoxybyte-gzip-20140113-git deoxybyte-gzip-test.asd deoxybyte-gzip.asd +deoxybyte-io http://beta.quicklisp.org/archive/deoxybyte-io/2014-01-13/deoxybyte-io-20140113-git.tgz 40992 7283270d2df168edda80ec15bede2aa3 b4326e35061b6bed2625cb26cf545dd8984cb0e7 deoxybyte-io-20140113-git deoxybyte-io-test.asd deoxybyte-io.asd +deoxybyte-systems http://beta.quicklisp.org/archive/deoxybyte-systems/2014-01-13/deoxybyte-systems-20140113-git.tgz 3677 cb63033baf4ff3c8aaba80252e77f5d6 c306db96a2de41c23f2284164b9577cc1ba2c718 deoxybyte-systems-20140113-git deoxybyte-systems.asd +deoxybyte-unix http://beta.quicklisp.org/archive/deoxybyte-unix/2014-01-13/deoxybyte-unix-20140113-git.tgz 20104 058d5bc317967f587535fae8ee97a39f 6886a7daf781f97173d9cbb8fa84e3229054d260 deoxybyte-unix-20140113-git deoxybyte-unix-test.asd deoxybyte-unix.asd +deoxybyte-utilities http://beta.quicklisp.org/archive/deoxybyte-utilities/2014-01-13/deoxybyte-utilities-20140113-git.tgz 32707 1d29f3a612c1e7901b0fd053cac93f87 d9fa17f1f96255a973fe1c13b0b982197b303220 deoxybyte-utilities-20140113-git deoxybyte-utilities-test.asd deoxybyte-utilities.asd +deploy http://beta.quicklisp.org/archive/deploy/2019-11-30/deploy-20191130-git.tgz 20923 06a1abb219d7f23670bd3391beaa520a c02e00609dce7d2745ec799ced101a099321bddb deploy-20191130-git deploy-test.asd deploy.asd +descriptions http://beta.quicklisp.org/archive/descriptions/2015-03-02/descriptions-20150302-git.tgz 23662 b16c4d4768515759094d08043f6cd181 bae261da6cae337aabc0daa49fbe0f2d399dcecb descriptions-20150302-git descriptions-test.asd descriptions.asd descriptions.serialization.asd descriptions.validation.asd +destructuring-bind-star http://beta.quicklisp.org/archive/destructuring-bind-star/2018-10-18/destructuring-bind-star-20181018-git.tgz 3212 55e616f9df29c1d948f582cfbc7fe5af 4009c6cdb2aee5c28947b1b974934cd4f07d9584 destructuring-bind-star-20181018-git destructuring-bind-star.asd +dexador http://beta.quicklisp.org/archive/dexador/2019-10-07/dexador-20191007-git.tgz 235731 aa1c435f809a794610fe599987cb73a8 7144517ad2da8038bdbf61bcfabbb5adc7aaa06f dexador-20191007-git dexador-test.asd dexador.asd +diff http://beta.quicklisp.org/archive/diff/2013-08-13/diff-20130813-git.tgz 16642 c13a4545b12b26e6d99c5535048a435d dc6993e2890a59dd59dad95a098771117396e650 diff-20130813-git diff.asd +diff-match-patch http://beta.quicklisp.org/archive/diff-match-patch/2016-10-31/diff-match-patch-20161031-git.tgz 31108 70256cec4e141e3d0f88f0626e4cad8a 5bd2caadf478f6d941cf0771ce522ee02be862b5 diff-match-patch-20161031-git diff-match-patch.asd +dirt http://beta.quicklisp.org/archive/dirt/2017-10-19/dirt-release-quicklisp-0d13ebc2-git.tgz 5590 c3242835717a9db9c2db803d1b25f545 4ba2d03d1d5fad8f92e2683ac9c86e2d23b31678 dirt-release-quicklisp-0d13ebc2-git dirt.asd +disposable http://beta.quicklisp.org/archive/disposable/2016-02-08/disposable-20160208-git.tgz 1504 dd4e4ff956fb44ed624f8dafcaa4bea5 9ddcaa8fbf5ad43195e179882190fc68d4b58039 disposable-20160208-git disposable.asd +dissect http://beta.quicklisp.org/archive/dissect/2019-07-10/dissect-20190710-git.tgz 28483 fb0e90e86fe4c184c08d19c1ef61d4e4 a0330b1b69f02f46221e749956d78105e81d3d39 dissect-20190710-git dissect.asd +djula http://beta.quicklisp.org/archive/djula/2019-12-27/djula-20191227-git.tgz 84165 cc2836b922f4a6a6a09955bca4c2353c b482e8d335b4d44bca6b10173896383b896b0657 djula-20191227-git djula-demo.asd djula-test.asd djula.asd +dlist http://beta.quicklisp.org/archive/dlist/2012-11-25/dlist-20121125-git.tgz 14699 c935ee7e9bf0e30a5fd70ae703195f9e 2b23fc66cf9c4829828d4ef04b61938215c39c0f dlist-20121125-git dlist.asd +dml http://beta.quicklisp.org/archive/dml/2018-10-18/dml-20181018-git.tgz 440514 7423921f88d0a15f12fcba859ff518d9 48be480e302c2dd2151cda1d62ff8df9483c8814 dml-20181018-git dml.asd +do-urlencode http://beta.quicklisp.org/archive/do-urlencode/2018-10-18/do-urlencode-20181018-git.tgz 2318 cb6ab78689fe52680ee1b94cd7738b94 7eaef5c9b5cf8dfe004ad3a8fa101bad8193b3f1 do-urlencode-20181018-git do-urlencode.asd +docbrowser http://beta.quicklisp.org/archive/docbrowser/2019-07-10/docbrowser-20190710-git.tgz 905902 bfc1424c8de6eaf7150bb6e00a0222e7 004c4019482d81f82ffe5654a4fb0bb1f9656d1a docbrowser-20190710-git docbrowser.asd +docparser http://beta.quicklisp.org/archive/docparser/2018-12-10/docparser-20181210-git.tgz 13474 1fe23ad568298e975242358517e9871f 3391e2ee13c6c2c78fb8ed8028c6130ac7bf209e docparser-20181210-git docparser-test-system.asd docparser-test.asd docparser.asd +documentation-template http://beta.quicklisp.org/archive/documentation-template/2014-12-17/documentation-template-0.4.4.tgz 8721 847d38e9131779931cb7063e019afe5d 2cd71d1884d3eff7b76a0f907969b986c4125744 documentation-template-0.4.4 documentation-template.asd +documentation-utils http://beta.quicklisp.org/archive/documentation-utils/2019-07-10/documentation-utils-20190710-git.tgz 8913 4f45f511ac55008b8b8aa04f7feaa2d4 1071335af99636f62943713298b46a0244b5bda4 documentation-utils-20190710-git documentation-utils.asd multilang-documentation-utils.asd +documentation-utils-extensions http://beta.quicklisp.org/archive/documentation-utils-extensions/2018-07-11/documentation-utils-extensions-20180711-git.tgz 4676 e44cb3fbe27b04e2cceeb2240859a716 aaad552e01854bfc2fdd7758dde31edd3a2f5892 documentation-utils-extensions-20180711-git documentation-utils-extensions.asd +donuts http://beta.quicklisp.org/archive/donuts/2012-07-03/donuts-20120703-git.tgz 1232132 5d3e62b6453941a0bf64741c3df70b54 9c8061bcd3b2dd1443a1bccef991115169137482 donuts-20120703-git donuts.asd +doplus http://beta.quicklisp.org/archive/doplus/2019-03-07/doplus-20190307-hg.tgz 26769 6784a90135fc635ee016c490c535a218 014fdd3f79104f08209210fcf7806af3c428e1dd doplus-20190307-hg doplus-fset.asd doplus.asd +doubly-linked-list http://beta.quicklisp.org/archive/doubly-linked-list/2019-07-10/doubly-linked-list-20190710-git.tgz 3464 315b9f70ee726211f694fd81f17f5283 24a1e9aa58ecf2dd19c8a6bd7b82b0acdfc3862c doubly-linked-list-20190710-git doubly-linked-list.asd +drakma http://beta.quicklisp.org/archive/drakma/2019-11-30/drakma-v2.0.7.tgz 74290 f166498aaed67f726060e9e997df10a3 0920ad374a9b5d513efae5dc61af2484dc901d86 drakma-v2.0.7 drakma-test.asd drakma.asd +drakma-async http://beta.quicklisp.org/archive/drakma-async/2015-10-31/drakma-async-20151031-git.tgz 24061 7048777c70eeba4456b19e2cb6ab83ae c4cf9dcbc5a295bbf3187ef39e9b391155f36392 drakma-async-20151031-git drakma-async.asd +draw-cons-tree http://beta.quicklisp.org/archive/draw-cons-tree/2013-10-03/draw-cons-tree-20131003-git.tgz 2252 ce720e2ddf395246927e5765f5116084 94e6c5794403485da7bce440547e4e5cb59afb92 draw-cons-tree-20131003-git draw-cons-tree.asd +dso-lex http://beta.quicklisp.org/archive/dso-lex/2011-01-10/dso-lex-0.3.2.tgz 16481 fe8a4a6b9689c06f93f19c1b5506132d 2fac198fb75b4db2d2a1eb02479c94c0c3fa255a dso-lex-0.3.2 dso-lex.asd +dso-util http://beta.quicklisp.org/archive/dso-util/2011-01-10/dso-util-0.1.2.tgz 11309 ad11cec0f5a04142bcd5e117e53c7267 d861e27a509cd972ede6c7377fdc93abfa2c727a dso-util-0.1.2 dso-util.asd +dufy http://beta.quicklisp.org/archive/dufy/2019-11-30/dufy-20191130-git.tgz 482953 a61931fe902574a80df60eed19bb6805 fcb19f7921d363f04eb2196fb28ec00afa5dced3 dufy-20191130-git dufy.asd +duologue http://beta.quicklisp.org/archive/duologue/2015-04-07/duologue-20150407-git.tgz 6711 c5fca14a43ee08bc81f89e1cec71e0b0 49147aaaed48dcab2e57ce97e2ff07d4bfdced92 duologue-20150407-git duologue.asd +dweet http://beta.quicklisp.org/archive/dweet/2014-12-17/dweet-20141217-git.tgz 3051 68c4fe0638b6f9febe93925d4fd0cc33 b13c3333a955b851ee4286f5bd1583f09e9e8f75 dweet-20141217-git dweet.asd +dyna http://beta.quicklisp.org/archive/dyna/2018-04-30/dyna-20180430-git.tgz 25788 9ee5811b22d4692a11320a3ad9ce1ec5 f9981ccccdbf77753179dab0e77150c57d9a817b dyna-20180430-git dyna-test.asd dyna.asd +dynamic-classes http://beta.quicklisp.org/archive/dynamic-classes/2013-01-28/dynamic-classes-20130128-git.tgz 7148 a6ed01c4f21df2b6a142328b24ac7ba3 641573761b2d4fab3b17196cc10a9d46486ab495 dynamic-classes-20130128-git dynamic-classes-test.asd dynamic-classes.asd +dynamic-collect http://beta.quicklisp.org/archive/dynamic-collect/2019-03-07/dynamic-collect-20190307-hg.tgz 447578 c182c60ccb418c9f996f2fe48478cfbf 13d9d81f629b6c665753741ffa45b646f7caeb56 dynamic-collect-20190307-hg dynamic-collect.asd +dynamic-mixins http://beta.quicklisp.org/archive/dynamic-mixins/2018-10-18/dynamic-mixins-20181018-git.tgz 2492 8b2072af2b472c2c7bbaf28ff38e43be a389ddf18ddec5f634f28e506e349b83117085eb dynamic-mixins-20181018-git dynamic-mixins.asd +eager-future http://beta.quicklisp.org/archive/eager-future/2010-10-06/eager-future-20101006-darcs.tgz 3181 33ec9918cece34f35f2354e1f94a245c 862750b95d33edacbc73b08a636b9689a6167336 eager-future-20101006-darcs eager-future.asd +eager-future2 http://beta.quicklisp.org/archive/eager-future2/2019-11-30/eager-future2-20191130-git.tgz 26961 72298620b0fb2f874d86d887cce4acf0 70c0531898eddae204d38b0f5f2dd7c9d7381e8b eager-future2-20191130-git eager-future2.asd test.eager-future2.asd +easing http://beta.quicklisp.org/archive/easing/2018-02-28/easing-20180228-git.tgz 4636 775f27d44c58ff05c38ead610168f1ee 2e8889e1e4e5ece9d39b0d1f99cbe7b352b55ace easing-20180228-git easing-demo.asd easing-test.asd easing.asd +easy-audio http://beta.quicklisp.org/archive/easy-audio/2019-12-27/easy-audio-20191227-git.tgz 48893 144ad89fb846739df044683e05ee7aac 4c4a7c22d1cc3edb311822fa35d87590d19ef62c easy-audio-20191227-git easy-audio-examples.asd easy-audio-tests.asd easy-audio.asd +easy-bind http://beta.quicklisp.org/archive/easy-bind/2019-02-02/easy-bind-20190202-git.tgz 16880 ee624a12d458bdb17f4b3dfe7772f699 9240ed116049d326453d744303e65213704859c8 easy-bind-20190202-git easy-bind.asd +easy-routes http://beta.quicklisp.org/archive/easy-routes/2019-08-13/easy-routes-20190813-git.tgz 6334 8716f16268ed259deb98ac29662722d9 13649c2cd2a61ec73ab1fe159ee0060bca1387ff easy-routes-20190813-git easy-routes.asd +eazy-documentation http://beta.quicklisp.org/archive/eazy-documentation/2019-12-27/eazy-documentation-20191227-git.tgz 17422 494e67c0a0de0e1c45854129e1551f96 1b0c6db59b09899d8a1f424ed7c419f30f4bc554 eazy-documentation-20191227-git eazy-documentation.asd +eazy-gnuplot http://beta.quicklisp.org/archive/eazy-gnuplot/2018-08-31/eazy-gnuplot-20180831-git.tgz 8339018 5847b95b76c3a6ca908572c01ecd8474 d2ef349292b5c42baf46cd53834aefa9cb2df2cf eazy-gnuplot-20180831-git eazy-gnuplot.asd eazy-gnuplot.test.asd +eazy-process http://beta.quicklisp.org/archive/eazy-process/2015-12-18/eazy-process-20151218-git.tgz 27785 67eb10100308f984571ad75db1f77bf6 98ab4e587b7ccf079c8f77d5a6013289a21a36d1 eazy-process-20151218-git eazy-process.asd eazy-process.test.asd +eazy-project http://beta.quicklisp.org/archive/eazy-project/2019-07-10/eazy-project-20190710-git.tgz 15917 5b365c1ae21d9faf6eb7cfbb79b729cd 1e037cfaa916d41d7192fac829034426042a5bb4 eazy-project-20190710-git eazy-project.asd eazy-project.autoload.asd eazy-project.test.asd +ec2 http://beta.quicklisp.org/archive/ec2/2012-09-09/ec2-20120909-git.tgz 23603 0c6dea76f190aaa25305490b3e048437 d82ca8949aced8d7ef5fe3ca6bc02a1a3f1ab2a7 ec2-20120909-git ec2.asd +eclector http://beta.quicklisp.org/archive/eclector/2019-12-27/eclector-20191227-git.tgz 132183 b63ea9792bb5808adddd17fdedd35a38 3446a00516f7bda6135a5136bcd482f5e73ad969 eclector-20191227-git eclector-concrete-syntax-tree.asd eclector.asd +eco http://beta.quicklisp.org/archive/eco/2019-08-13/eco-20190813-git.tgz 6304 f27079c961c837ffc28f4d8c1a5cf81e 386d0cea4efbb4269e6b22d8387e447986c870cd eco-20190813-git eco-test.asd eco.asd +elb-log http://beta.quicklisp.org/archive/elb-log/2015-09-23/elb-log-20150923-git.tgz 6870 5eb6513fd03c1b015b9f215f96ba9d3b bd104f69efa8db03bdade2bf6fe70c61cd4b58e3 elb-log-20150923-git elb-log-test.asd elb-log.asd +electron-tools http://beta.quicklisp.org/archive/electron-tools/2016-04-21/electron-tools-20160421-git.tgz 2560 70ce32f5c79a23cff6c7fef7677422b4 d3de418ea520e7d7e672ad391a5905e1e72efd06 electron-tools-20160421-git electron-tools-test.asd electron-tools.asd +elf http://beta.quicklisp.org/archive/elf/2019-07-10/elf-20190710-git.tgz 473583 7edebf956ba1892304407f475bf6bdfe 6f7a1bfb3c1930c586d374122158c5a28dc34c56 elf-20190710-git elf.asd +enhanced-eval-when http://beta.quicklisp.org/archive/enhanced-eval-when/2012-11-25/enhanced-eval-when-1.0.tgz 1875 4cf59d63539f41b7b0c412f6d9e89ff5 48f3d1a21ddb4f8440d0c04f5a2b45da9bb4438c enhanced-eval-when-1.0 enhanced-eval-when.asd +enhanced-multiple-value-bind http://beta.quicklisp.org/archive/enhanced-multiple-value-bind/2012-11-25/enhanced-multiple-value-bind-1.0.1.tgz 2589 a0fdb32762b7bf6a8cd4b04f07bb05a1 cf4a330e2b640e43bb70ff5da1c7ab7fc97e8a19 enhanced-multiple-value-bind-1.0.1 enhanced-multiple-value-bind.asd +envy http://beta.quicklisp.org/archive/envy/2019-08-13/envy-20190813-git.tgz 3558 1f82d7f3221043577e44772d27d44932 73a1c0d37dfd06abd6bd7a1368aa4735c52845b7 envy-20190813-git envy-test.asd envy.asd +eos http://beta.quicklisp.org/archive/eos/2015-06-08/eos-20150608-git.tgz 13161 94f6a72534171ff6adcc823c31e3d53f bbfeefe9f70dd744142060ef1e96f85092bfdef7 eos-20150608-git eos.asd +epigraph http://beta.quicklisp.org/archive/epigraph/2016-06-28/epigraph-20160628-git.tgz 17490 6666b31324773f5aa275660da4cdedcc 9b971c5aabbd4b3b3ec2753766c37114ccd634a8 epigraph-20160628-git epigraph.asd +equals http://beta.quicklisp.org/archive/equals/2014-08-26/equals-20140826-git.tgz 2963 5acfaaebd7e1a683b3a84f85b7413340 a3321de358488a827d8535e9b947a316b914f5f5 equals-20140826-git equals.asd +ernestine http://beta.quicklisp.org/archive/ernestine/2016-12-04/ernestine-20161204-git.tgz 305333 1f254cb1f061e846181360fe059ca20d 170f5f6b5622462afa2f8b5d266aaa1b61e7e083 ernestine-20161204-git ernestine-tests.asd ernestine.asd +erudite http://beta.quicklisp.org/archive/erudite/2019-10-07/erudite-20191007-git.tgz 376268 d6de2a638ed93f2f87647be695e7e85f 9cad42dc1203dab78f12799ec4bd3c9bc62c9801 erudite-20191007-git erudite-test.asd erudite.asd +escalator http://beta.quicklisp.org/archive/escalator/2019-03-07/escalator-20190307-hg.tgz 4906 fff63c0a1de90711325f5952ae344e2e 935dbda8a5a4539db23d7555ed47060b2e882204 escalator-20190307-hg escalator-bench.asd escalator.asd +esrap http://beta.quicklisp.org/archive/esrap/2019-12-27/esrap-20191227-git.tgz 69274 8dd58ffc605bba6eec614bdea573978b 7ab73af2e8a3346142280622dd4a6d09936a8159 esrap-20191227-git esrap.asd +esrap-liquid http://beta.quicklisp.org/archive/esrap-liquid/2016-10-31/esrap-liquid-20161031-git.tgz 35689 7bc12d040919cb5b5da641334a1f23a1 9c8b389cc2c147922bbbc9be7a21c31c06a1b888 esrap-liquid-20161031-git esrap-liquid.asd +esrap-peg http://beta.quicklisp.org/archive/esrap-peg/2019-10-07/esrap-peg-20191007-git.tgz 7824 48d87d3118febeefc23ca3a8dda36fc0 27a86bbcd4eb649ac379c6b9ba0093234f285ff0 esrap-peg-20191007-git esrap-peg.asd +event-emitter http://beta.quicklisp.org/archive/event-emitter/2018-12-10/event-emitter-20181210-git.tgz 3346 1b6cb3e12d074e35da563e7163b47a91 651ad4bc759d2a947fb8ecd72d1f67f4d19c2d08 event-emitter-20181210-git event-emitter-test.asd event-emitter.asd +event-glue http://beta.quicklisp.org/archive/event-glue/2015-06-08/event-glue-20150608-git.tgz 9282 1aa70e889ffd2a2d01e7ee740c057415 faedf03cac4300b60f270a365e11a4dba5a74789 event-glue-20150608-git event-glue-test.asd event-glue.asd +eventbus http://beta.quicklisp.org/archive/eventbus/2019-12-27/eventbus-20191227-git.tgz 15807 99b4ca9efc30825dd56e77ae6cd5afe3 85c30ca68cb565572b5a5595e5d5a34e8f5e16c4 eventbus-20191227-git eventbus.asd +eventfd http://beta.quicklisp.org/archive/eventfd/2017-11-30/eventfd-20171130-git.tgz 2518 6580eb40265070dc8292ed4c2a137ee8 8fdce2b98e2d7d6d437a73a5de85f882c0c60859 eventfd-20171130-git eventfd.asd +everblocking-stream http://beta.quicklisp.org/archive/everblocking-stream/2018-10-18/everblocking-stream-20181018-git.tgz 887 307e7b6ba7ecb8912492497d7025e1cd 5539bdd086bef5526c4487ce9634239ac7f204b9 everblocking-stream-20181018-git everblocking-stream.asd +evol http://beta.quicklisp.org/archive/evol/2010-10-06/evol-20101006-git.tgz 36040 063813e42d598be1073625c38cc0fc76 de2a0507ad9682b4f783d23d8e579859e5283763 evol-20101006-git evol-test.asd evol.asd +exit-hooks http://beta.quicklisp.org/archive/exit-hooks/2017-04-03/exit-hooks-20170403-git.tgz 3070 9a5c96e590462bd417f1940ce9d374d2 2d5fb7624a86f2efec0106def24306beece56d53 exit-hooks-20170403-git exit-hooks.asd +exponential-backoff http://beta.quicklisp.org/archive/exponential-backoff/2015-01-13/exponential-backoff-20150113-git.tgz 2397 d3e5d082518de0e1d03ad6a8dac63f07 06dea928582daa17b07682a2df406de61205c63e exponential-backoff-20150113-git exponential-backoff.asd +exscribe http://beta.quicklisp.org/archive/exscribe/2017-04-03/exscribe-20170403-git.tgz 30757 a7317b96ab623ce1795d0e01c070daff 628b19937fb8477a42792829202dbf9ae9f634b6 exscribe-20170403-git exscribe.asd +ext-blog http://beta.quicklisp.org/archive/ext-blog/2016-08-25/ext-blog-20160825-git.tgz 393481 74fbc8b459a0d074c6fd08bbbd644c31 de4620d23fe78be0a39d8768724c86e074365252 ext-blog-20160825-git ext-blog.asd +extended-reals http://beta.quicklisp.org/archive/extended-reals/2018-03-28/extended-reals-20180328-git.tgz 2979 191bca02ac2c4a55ccc98aa6eda82f66 7d1fba685087c2236a5dd24abdc070f1b2394c4b extended-reals-20180328-git extended-reals.asd +external-program http://beta.quicklisp.org/archive/external-program/2019-03-07/external-program-20190307-git.tgz 10408 b30fe104c34059506fd4c493fa79fe1a f04bc9e1b3a0eb5b4c017a8799b9483fc10ea0ff external-program-20190307-git external-program.asd +external-symbol-not-found http://beta.quicklisp.org/archive/external-symbol-not-found/2018-04-30/external-symbol-not-found-20180430-git.tgz 2882 20cc0679a0de51547810d9f75c04d350 1b7140c2efa0f4b342568c8a34079c478d3c94c7 external-symbol-not-found-20180430-git external-symbol-not-found.asd +f-underscore http://beta.quicklisp.org/archive/f-underscore/2010-10-06/f-underscore-20101006-darcs.tgz 982 45ef9c0ac1c92d9aba76b69b53cc7838 34c192987ab8b11f9b09ba40098fc696250506e6 f-underscore-20101006-darcs f-underscore.asd +f2cl http://beta.quicklisp.org/archive/f2cl/2019-01-07/f2cl-20190107-git.tgz 2132799 3e24767fe26aa1bc1c6da904b8027d68 7de3a8a885f825a233e7523ae97354801ed08fb9 f2cl-20190107-git f2cl-asdf.asd f2cl.asd packages/blas-complex.asd packages/blas-hompack.asd packages/blas-package.asd packages/blas-real.asd packages/blas.asd packages/colnew.asd packages/fishpack.asd packages/hompack.asd packages/lapack.asd packages/minpack.asd packages/odepack.asd packages/quadpack.asd packages/toms419.asd packages/toms715.asd packages/toms717.asd +fact-base http://beta.quicklisp.org/archive/fact-base/2018-03-28/fact-base-20180328-git.tgz 9491 86825a1ba98fe3aa2866ec7e3452a371 26a527bafcf2bd38221c9bd737ca15660d0bed9e fact-base-20180328-git fact-base.asd +fare-csv http://beta.quicklisp.org/archive/fare-csv/2017-12-27/fare-csv-20171227-git.tgz 7223 1d73aaac9fcd86cc5ddb72019722bc2a d7cdb3a2b3ca5b92953201cc8769998fd8ee65de fare-csv-20171227-git fare-csv.asd +fare-memoization http://beta.quicklisp.org/archive/fare-memoization/2018-04-30/fare-memoization-20180430-git.tgz 7571 7446aa643f0e461d960efb673a706dc1 ef47d67c6d76e8e0c829bbd654e27b69e08fef3b fare-memoization-20180430-git fare-memoization.asd +fare-mop http://beta.quicklisp.org/archive/fare-mop/2015-12-18/fare-mop-20151218-git.tgz 2728 4721ff62e2ac2c55079cdd4f2a0f6d4a cd1f7fcd2aa132432f271f43de9cf39aeef37c71 fare-mop-20151218-git fare-mop.asd +fare-quasiquote http://beta.quicklisp.org/archive/fare-quasiquote/2019-05-21/fare-quasiquote-20190521-git.tgz 16060 e08c24d35a485a74642bd0c7c06662d6 b441f6dadd12309bd7cf1cba64f41fc9ca7974d6 fare-quasiquote-20190521-git fare-quasiquote-extras.asd fare-quasiquote-optima.asd fare-quasiquote-readtable.asd fare-quasiquote-test.asd fare-quasiquote.asd +fare-scripts http://beta.quicklisp.org/archive/fare-scripts/2019-10-07/fare-scripts-20191007-git.tgz 41613 be86769065461713423ac98bef91b900 1f2ffe437dbb926c9e728227a9d7c0f6172ad349 fare-scripts-20191007-git fare-scripts.asd +fare-utils http://beta.quicklisp.org/archive/fare-utils/2017-01-24/fare-utils-20170124-git.tgz 32604 6752362d0c7c03df6576ab2dbe807ee2 e0b139600b7693a13eece65ff148464168ae890b fare-utils-20170124-git fare-utils.asd test/fare-utils-test.asd +fast-http http://beta.quicklisp.org/archive/fast-http/2019-10-07/fast-http-20191007-git.tgz 33540 fd43be4dd72fd9bda5a3ecce87104c97 419610a07b0ccf3117378b6fb9b5faa025037d0b fast-http-20191007-git fast-http-test.asd fast-http.asd +fast-io http://beta.quicklisp.org/archive/fast-io/2017-10-23/fast-io-20171023-git.tgz 8067 89105f8277f3bf3709fae1b789e3d5ad c1cb21c5c9100e067b405fece7ee5f22bcc36f9f fast-io-20171023-git fast-io-test.asd fast-io.asd +fast-websocket http://beta.quicklisp.org/archive/fast-websocket/2019-08-13/fast-websocket-20190813-git.tgz 9136 1bfc212b4e196049ab66598b9055c225 ec4ff9ece37aba5d6885cbbf7184ad2032663fa2 fast-websocket-20190813-git fast-websocket-test.asd fast-websocket.asd +femlisp http://beta.quicklisp.org/archive/femlisp/2019-12-27/femlisp-20191227-git.tgz 648961 5ce598c1a5073081ab7621a9fb2eba72 fa87977048b8494b5902a9a4c22b17aaee31b636 femlisp-20191227-git external/cl-cpu-affinity/cl-cpu-affinity.asd external/infix/infix.asd src/applications/courses/dealii-tutorial/dealii-tutorial.asd src/contrib/femlisp-picture.asd src/ddo/ddo.asd src/femlisp-ddo/net.scipolis.graphs.asd systems/femlisp-basic.asd systems/femlisp-dictionary.asd systems/femlisp-matlisp.asd systems/femlisp-parallel.asd systems/femlisp.asd +ffa http://beta.quicklisp.org/archive/ffa/2010-10-06/ffa-20101006-git.tgz 79415 5fe81065a6834b2095373667f5d58426 a3d137edc9af56e3ba853082a2b30f59f7bb79b4 ffa-20101006-git ffa.asd +fft http://beta.quicklisp.org/archive/fft/2018-07-11/fft-20180711-git.tgz 4806 06c2d33d8ddd43332dc25ac4ea7f20cc f77ba0a8d9ccf55d8daaebe31a7053e78a2c29c2 fft-20180711-git fft.asd pfft.asd +fiasco http://beta.quicklisp.org/archive/fiasco/2019-11-30/fiasco-20191130-git.tgz 18955 235809b661c89fed1c4ca4ba3e4f3606 71ac8b6cc0d93752c76872d329818cc692ed32a9 fiasco-20191130-git fiasco.asd +file-local-variable http://beta.quicklisp.org/archive/file-local-variable/2016-03-18/file-local-variable-20160318-git.tgz 3725 8c486b517f733978fa3224ae225a5829 ab4f69526c059b17f5262006217f43b17f217358 file-local-variable-20160318-git file-local-variable.asd file-local-variable.test.asd +file-select http://beta.quicklisp.org/archive/file-select/2019-12-27/file-select-20191227-git.tgz 16660 792889047c3f0713c4ecd014f592b380 7f59269e56af417095f4027f6c52adbc10bbb246 file-select-20191227-git file-select.asd +file-types http://beta.quicklisp.org/archive/file-types/2016-09-29/file-types-20160929-git.tgz 16146 4fd40465a8bde55c444c65bdcb238a95 ef2a666fadb709340caf6340043fc21c157b4ec6 file-types-20160929-git file-types.asd +filtered-functions http://beta.quicklisp.org/archive/filtered-functions/2016-03-18/filtered-functions-20160318-git.tgz 5624 1a30c0712c4750954a9b645bdc6362cc 76f362ebb3655223f646d4be53dcc85572b307a8 filtered-functions-20160318-git filtered-functions.asd +find-port http://beta.quicklisp.org/archive/find-port/2019-07-10/find-port-20190710-git.tgz 2053 50b5558caf3cc39cc6b55142b6630404 2f18aa155913ec653ae88804cab4422e0e05fb23 find-port-20190710-git find-port-test.asd find-port.asd +firephp http://beta.quicklisp.org/archive/firephp/2016-05-31/firephp-20160531-git.tgz 3101 776c31d2d1d29e0f8ddf916d66f57416 354083daca9bc6e502792af81300ebdaf7fbfd1a firephp-20160531-git firephp-tests.asd firephp.asd +first-time-value http://beta.quicklisp.org/archive/first-time-value/2018-12-10/first-time-value-1.0.1.tgz 4590 ad1d225958063396e5260d963ffbb6e3 20c732c8a5b0b32c80b5d23eb1f70e4c98614d0c first-time-value-1.0.1 first-time-value.asd tests/first-time-value_tests.asd +fiveam http://beta.quicklisp.org/archive/fiveam/2018-02-28/fiveam-v1.4.1.tgz 24014 7f182f8a4c12b98671e1707ae0f140b7 42e5b2e54ef6cda091ce116963d2eea30bb48f6b fiveam-v1.4.1 fiveam.asd +fiveam-asdf http://beta.quicklisp.org/archive/fiveam-asdf/2019-07-10/fiveam-asdf-20190710-git.tgz 3484 951689cab836f8cefafcf75dd324eb23 b870df02fbca25d3f4adf4aa843081324669e353 fiveam-asdf-20190710-git fiveam-asdf.asd +fixed http://beta.quicklisp.org/archive/fixed/2017-01-24/fixed-20170124-git.tgz 12070 738197e9e3f84c000df9f7c270f49401 58f9ec849945c966fa5f539fc7fd3d1ff8178d3d fixed-20170124-git fixed.asd +flac-metadata http://beta.quicklisp.org/archive/flac-metadata/2019-07-10/flac-metadata-20190710-git.tgz 6580 a3cef395abd5beae99ba60f394f8e7b6 d7d0d842ece10d903bfcbc9ecaccca84ecd7fcd8 flac-metadata-20190710-git flac-metadata.asd +flac-parser http://beta.quicklisp.org/archive/flac-parser/2019-07-10/flac-parser-20190710-git.tgz 11365 26b6e66cc7d2c0a886d615f7a581b0e9 c70a38376cb8d55eb03d53c546f39c52155d2697 flac-parser-20190710-git flac-parser.asd +flare http://beta.quicklisp.org/archive/flare/2019-07-10/flare-20190710-git.tgz 58017 a15c9be05e27bfc9c3986fca21fda893 82f93831b5a49164bd9646edfcfd05462deb7c37 flare-20190710-git flare.asd viewer/flare-viewer.asd +flexi-streams http://beta.quicklisp.org/archive/flexi-streams/2019-01-07/flexi-streams-20190107-git.tgz 132948 b59014f9f9f0d1b94f161e36e64a35c2 d3d3a0dcedf92fccce96fcfb47561487b5bdde73 flexi-streams-20190107-git flexi-streams.asd +flexichain http://beta.quicklisp.org/archive/flexichain/2010-10-06/flexichain_1.5.1.tgz 19919 e63247e4e3f61ec768c5ceff0a5e1293 7eb528e31fea545467c6b629094a335dadbebe3f flexichain_1.5.1 flexichain-doc.asd flexichain.asd +float-features http://beta.quicklisp.org/archive/float-features/2019-10-07/float-features-20191007-git.tgz 6721 21215bd53d6c23908b92a4afd47a2880 91d3fe44e93a2f430d83496fadce7f6b16981fce float-features-20191007-git float-features.asd +floating-point http://beta.quicklisp.org/archive/floating-point/2014-11-06/floating-point-20141106-git.tgz 473538 2ebe55f78c56d8ca5af9d1e0914b6402 b894b79a5fb145795d45488395056efa86277310 floating-point-20141106-git lisp/floating-point.asd test/floating-point-test.asd +floating-point-contractions http://beta.quicklisp.org/archive/floating-point-contractions/2016-06-28/floating-point-contractions-20160628-git.tgz 1925 0250c90f09a3b6970560da61a22c3f67 503f4aff7528ba6302a22b953a14af263ff8e020 floating-point-contractions-20160628-git floating-point-contractions.asd +flow http://beta.quicklisp.org/archive/flow/2019-08-13/flow-20190813-git.tgz 29847 b74593ef1f3bd9838693b8595ae5e5c0 642af5ba117c129373f3c7d4e95a78f937e9f9c8 flow-20190813-git flow.asd visualizer/flow-visualizer.asd +flute http://beta.quicklisp.org/archive/flute/2018-08-31/flute-20180831-git.tgz 13138 8c312b0e18c10e7f03b81fc19587b786 632821535927afe4fe360af6ffcd6e1f2f6780bc flute-20180831-git flute-test.asd flute.asd +fmt http://beta.quicklisp.org/archive/fmt/2016-03-18/fmt-20160318-git.tgz 15539 94092c9cff6b2b24cddd779a0e059b6e 844964ccdb739dc6b569cd7627779600a4269661 fmt-20160318-git fmt-test.asd fmt-time.asd fmt.asd +fn http://beta.quicklisp.org/archive/fn/2017-10-19/fn-20171019-git.tgz 6936 0e1cfe5f19ceec8966baa3037772d31e 64871b26712de944ff79e1f58b0e7f4952044810 fn-20171019-git fn.asd +focus http://beta.quicklisp.org/archive/focus/2017-04-03/focus-20170403-git.tgz 47354 2be0459474ffdf328f5139164531a46e 84ef144a2ae449c507a5eaa37ef7c4274b15c36d focus-20170403-git core/net.didierverna.focus.core.asd demos/quotation/net.didierverna.focus.demos.quotation.asd flv/net.didierverna.focus.flv.asd net.didierverna.focus.asd setup/net.didierverna.focus.setup.asd +folio http://beta.quicklisp.org/archive/folio/2013-01-28/folio-20130128-git.tgz 21241 6f675b7346e8fcd492d4fde527eaa5ac bf20129ce9e18991bb60d1e20dc6c489c9529819 folio-20130128-git as/folio.as.asd boxes/folio.boxes.asd collections/folio.collections.asd folio.asd functions/folio.functions.asd +folio2 http://beta.quicklisp.org/archive/folio2/2019-10-07/folio2-20191007-git.tgz 55271 df04ee7b930f3eec45293a26523c2f42 539dca8db49ca54e344e0f6ba902ea3301ecd745 folio2-20191007-git folio2-as-syntax.asd folio2-as-tests.asd folio2-as.asd folio2-boxes-tests.asd folio2-boxes.asd folio2-functions-syntax.asd folio2-functions-tests.asd folio2-functions.asd folio2-make-tests.asd folio2-make.asd folio2-maps-syntax.asd folio2-maps-tests.asd folio2-maps.asd folio2-pairs-tests.asd folio2-pairs.asd folio2-sequences-syntax.asd folio2-sequences-tests.asd folio2-sequences.asd folio2-series-tests.asd folio2-series.asd folio2-taps-tests.asd folio2-taps.asd folio2-tests.asd folio2.asd +fomus http://beta.quicklisp.org/archive/fomus/2012-09-09/fomus-20120909-svn.tgz 1142093 f23d94ff232efc377e331114e62c508f ca319a5373898758cccfa40c4a37feef523d2a1a fomus-20120909-svn fomus.asd +font-discovery http://beta.quicklisp.org/archive/font-discovery/2019-10-07/font-discovery-20191007-git.tgz 14711 625c16ab54bee0f441482fcd535f3cfa 5b9db7476c19d53c6863f09bc95297da27c891db font-discovery-20191007-git font-discovery.asd +for http://beta.quicklisp.org/archive/for/2019-07-10/for-20190710-git.tgz 37031 69b66819a3e64c77fa9832d9d4d188a1 cb94c7ab09f15d6a75e95013d620163c728a197a for-20190710-git for.asd +form-fiddle http://beta.quicklisp.org/archive/form-fiddle/2019-07-10/form-fiddle-20190710-git.tgz 5635 2576065de1e3c95751285fb155f5bcf6 a6a057c05e5512f2f8a0a05e336d422646d76b2c form-fiddle-20190710-git form-fiddle.asd +format-string-builder http://beta.quicklisp.org/archive/format-string-builder/2017-01-24/format-string-builder-20170124-git.tgz 5303 4997e60ed7af0f32d1c5b06f19247288 89a375a3ed8fb7c2cb8f1805403ebd1824594138 format-string-builder-20170124-git format-string-builder.asd +formlets http://beta.quicklisp.org/archive/formlets/2016-12-04/formlets-20161204-git.tgz 10598 b630d094fbbb2fe157f7e3a4bd93b648 a034c03549a46f751d65473b2312e55782ecb4d5 formlets-20161204-git formlets-test.asd formlets.asd +fred http://beta.quicklisp.org/archive/fred/2015-09-23/fred-20150923-git.tgz 34873 dbd3a53435f31cd78f4ddc3e74e9b33b 4abfe6150cb271db84a4094e4d7cef1c50a13472 fred-20150923-git fred.asd +freebsd-sysctl http://beta.quicklisp.org/archive/freebsd-sysctl/2018-07-11/freebsd-sysctl-20180711-git.tgz 3640 e8b12534d89d5c8bcd9a5f6e73907372 028b66742f9f1b0bbdf40c1857fa03afd86bb53b freebsd-sysctl-20180711-git freebsd-sysctl.asd +froute http://beta.quicklisp.org/archive/froute/2018-07-11/froute-20180711-git.tgz 6514 fc27a158d568985e863460c9ac816ecf a22f3a153e2c9314db0e08e625e75909687b0347 froute-20180711-git froute.asd +frpc http://beta.quicklisp.org/archive/frpc/2015-10-31/frpc-20151031-git.tgz 140181 c13346249483dd290b8cf22221df05f7 dafa923a87ffc6bc0b0cdbc4f9d81ee2fd140e48 frpc-20151031-git frpc.asd frpcgen.asd +fs-watcher http://beta.quicklisp.org/archive/fs-watcher/2017-11-30/fs-watcher-20171130-git.tgz 2293 98f697c99206be8e728e98414d56c28f fb546e596be903ecec976563d09982a5b3894885 fs-watcher-20171130-git fs-watcher.asd +fset http://beta.quicklisp.org/archive/fset/2017-10-19/fset-20171019-git.tgz 107932 dc8de5917c513302dd0e135e6c133978 d53c56499c817bce4d486b1fc9611fe32b2c2eb1 fset-20171019-git fset.asd +fsvd http://beta.quicklisp.org/archive/fsvd/2013-12-11/fsvd-20131211-git.tgz 8009 b6459ca9296f6e331cef49ab5580c766 392c65723a931eb2e8a4bd752d7abf95fc818b5a fsvd-20131211-git fsvd.asd +fucc http://beta.quicklisp.org/archive/fucc/2011-01-10/fucc_0.2.1.tgz 33293 b822259462e1cba9329845709c5f607e 245cc4e542d10eff1bffb70ecc552f2f0247a53a fucc_0.2.1 fucc-generator.asd fucc-parser.asd +function-cache http://beta.quicklisp.org/archive/function-cache/2018-12-10/function-cache-20181210-git.tgz 12754 c9ed7dd8f103273bd9daa06b5a720944 98e3470ccaccbd88c7dbfe5e77f19cc742446fc1 function-cache-20181210-git function-cache-clsql.asd function-cache.asd +fxml http://beta.quicklisp.org/archive/fxml/2019-12-27/fxml-20191227-git.tgz 840266 232e2106b230f05dac277a8e34a19a4c a95b680748d598c58f8b84ff1337bb6cc0d3c8d9 fxml-20191227-git fxml.asd +gamebox-dgen http://beta.quicklisp.org/archive/gamebox-dgen/2019-03-07/gamebox-dgen-20190307-git.tgz 9378 6f107b87923081e68a76a00ba1c81766 a57f60f17c8dd30731bce3eaac6879c095332a34 gamebox-dgen-20190307-git gamebox-dgen.asd +gamebox-ecs http://beta.quicklisp.org/archive/gamebox-ecs/2018-02-28/gamebox-ecs-20180228-git.tgz 7070 a4fef9181021f72168844ba1dfa57871 50080fc42ace635ad1f5b58c53023bcdcd0e5cf7 gamebox-ecs-20180228-git gamebox-ecs.asd +gamebox-frame-manager http://beta.quicklisp.org/archive/gamebox-frame-manager/2018-07-11/gamebox-frame-manager-20180711-git.tgz 3717 f8461ce7dbcfc0597df45375d43174ab 0e989400611cd95d5cb9f117631099ee8bf45b17 gamebox-frame-manager-20180711-git gamebox-frame-manager.asd +garbage-pools http://beta.quicklisp.org/archive/garbage-pools/2013-07-20/garbage-pools-20130720-git.tgz 44210 f691e2ddf6ba22b3451c24b61d4ee8b6 cd82cc2ecf1de06bc18bd4c578736448ad3c088a garbage-pools-20130720-git garbage-pools-test.asd garbage-pools.asd +gcm http://beta.quicklisp.org/archive/gcm/2014-12-17/gcm-20141217-git.tgz 2461 6836ca1144f86e181cc4684a4be58c10 fddbfbef63cfa8f9301405fc5d5ace4a495b6fe5 gcm-20141217-git gcm.asd +gendl http://beta.quicklisp.org/archive/gendl/2019-12-27/gendl-devo-b6bd4ce1-git.tgz 69422705 b56261c7b6d9b554e198380f70b25696 90542cb830e48d5dd8050a55fbc017d7f4838fea gendl-devo-b6bd4ce1-git apps/dom/dom.asd apps/gorg/gorg.asd apps/graphs/graphs.asd apps/ta2/ta2.asd apps/tasty/tasty.asd apps/timer/timer.asd apps/translators/translators.asd apps/tree/tree.asd apps/yadd/yadd.asd base/base.asd cl-lite/cl-lite.asd demos/bus/bus.asd demos/ledger/ledger.asd demos/robot/robot.asd demos/wire-world/wire-world.asd gendl-asdf.asd gendl.asd geom-base/geom-base.asd glisp/glisp.asd gwl-graphics/gwl-graphics.asd gwl/gwl.asd regression/regression.asd setup-cffi/setup-cffi.asd surf/surf.asd +generators http://beta.quicklisp.org/archive/generators/2013-06-15/generators-20130615-git.tgz 4999 e0de3d2f81b7d5802403186012bc37b6 f9df68f27c422f6dcce84f0635a42500ca2d6e39 generators-20130615-git generators.asd +generic-cl http://beta.quicklisp.org/archive/generic-cl/2019-11-30/generic-cl-20191130-git.tgz 66629 4993917d297113bf47002d2f5afa24b4 c307f7ee08d74fdd7417c30208b43b6de50fd127 generic-cl-20191130-git generic-cl.asd +generic-comparability http://beta.quicklisp.org/archive/generic-comparability/2018-01-31/generic-comparability-20180131-git.tgz 5622 9cc021f7f580a6e4951066f629bc56f3 7ef5b496c236d42f4fdf529ae257a2e99a9e4417 generic-comparability-20180131-git generic-comparability.asd +generic-sequences http://beta.quicklisp.org/archive/generic-sequences/2015-07-09/generic-sequences-20150709-git.tgz 106323 be208c2f1e6ea5ecd39355d24676312c 330178da719e73413c84f11e42170e76cf60b657 generic-sequences-20150709-git generic-sequences-cont.asd generic-sequences-iterate.asd generic-sequences-stream.asd generic-sequences-test.asd generic-sequences.asd +geneva http://beta.quicklisp.org/archive/geneva/2016-12-04/geneva-20161204-git.tgz 28218 6539a3fb3b4d8e6c2f4c8b1193ded5b3 80144517cb11bd17dd0c6e04470faa450855292e geneva-20161204-git geneva-cl.asd geneva-html.asd geneva-latex.asd geneva-mk2.asd geneva-plain-text.asd geneva-tex.asd geneva.asd open-geneva.asd +genhash http://beta.quicklisp.org/archive/genhash/2018-12-10/genhash-20181210-git.tgz 4210 373e52616aa9563899004e5f017cff6b 36a71477e3ddb2de935ff044dbb9bbe38cc48c76 genhash-20181210-git genhash.asd +genie http://beta.quicklisp.org/archive/genie/2019-03-07/genie-20190307-git.tgz 2991 a330d90823d8b14bf935f7a78bfb47f7 de9fff083c39e125cda4e3c0bf479d9484e4621f genie-20190307-git genie.asd +geowkt http://beta.quicklisp.org/archive/geowkt/2018-10-18/geowkt-20181018-git.tgz 127442 a3827d633b77241dbe0a18d7df672f6e a75474f5cec2bda247c423004147faa68e8d9492 geowkt-20181018-git geowkt-update.asd geowkt.asd +getopt http://beta.quicklisp.org/archive/getopt/2015-09-23/getopt-20150923-git.tgz 5108 adc97a0ae99d65edff231b35862d67dd 001d521ec954ddd8222f708316c04c6e522e2b16 getopt-20150923-git getopt.asd +gettext http://beta.quicklisp.org/archive/gettext/2017-11-30/gettext-20171130-git.tgz 23766 d162cb5310db5011c82ef6343fd280ed 896479742580c8abecf8f47b77c48d56988b3089 gettext-20171130-git gettext-example/gettext-example.asd gettext-tests/gettext-tests.asd gettext.asd +git-file-history http://beta.quicklisp.org/archive/git-file-history/2016-08-25/git-file-history-20160825-git.tgz 2640 a642d433a7fd6c73b1c81ad21ab5223e 7522386a8d66527f352d2b63c66feab5814769df git-file-history-20160825-git git-file-history-test.asd git-file-history.asd +glad-blob http://beta.quicklisp.org/archive/glad-blob/2018-02-28/glad-blob-stable-e6dd7fef-git.tgz 325980 fe67fc6d40b544b404b43879467cf054 226a4be77594fec3dc1ee8205b5e8d6c67c8576e glad-blob-stable-e6dd7fef-git glad-blob.asd +glass http://beta.quicklisp.org/archive/glass/2015-07-09/glass-20150709-git.tgz 70206 45acf599d8810960366575efe9e6dae4 49a0edeb8c25222add274d8ec7aebb8416fda42d glass-20150709-git glass.asd +glaw http://beta.quicklisp.org/archive/glaw/2018-02-28/glaw-20180228-git.tgz 1427712 aa341fdc184de0a4be21654af6b95d5a 361ba78fe7b6456b03bf8ab9c49d6330c2e3b52a glaw-20180228-git glaw-examples.asd glaw-imago.asd glaw-sdl.asd glaw.asd +glfw-blob http://beta.quicklisp.org/archive/glfw-blob/2018-02-28/glfw-blob-stable-5af92db3-git.tgz 488790 5567c3a03fa4b5cb6557f84e49c2240d 44905ce7d667322a522783c24bbe3cd6d36f4a37 glfw-blob-stable-5af92db3-git glfw-blob.asd +glisph http://beta.quicklisp.org/archive/glisph/2017-04-03/glisph-20170403-git.tgz 2341692 8fbfbd69a4b60b1cf7456b1a05332d37 9316f601eb05d9db8eebc61a3f0746227ccf1062 glisph-20170403-git glisph-test.asd glisph.asd +glkit http://beta.quicklisp.org/archive/glkit/2017-12-27/glkit-20171227-git.tgz 15068 96045c730e405bff1729f56ef79ac65b 87b6502dc08a45f997b942c088677bd32189ce20 glkit-20171227-git glkit-examples.asd glkit.asd +global-vars http://beta.quicklisp.org/archive/global-vars/2014-11-06/global-vars-20141106-git.tgz 3581 dd3153ee75c972a80450aa00644b2200 06ef315e35eaf447159303a16827e05cc28af887 global-vars-20141106-git global-vars-test.asd global-vars.asd +glop http://beta.quicklisp.org/archive/glop/2017-10-19/glop-20171019-git.tgz 85964 329610c0ffc7a862ce454d1901895bca 7d196144d503e8bba5a1ea8b4afe1a19927f8ac6 glop-20171019-git glop-test.asd glop.asd +glsl-packing http://beta.quicklisp.org/archive/glsl-packing/2018-01-31/glsl-packing-20180131-git.tgz 11241 32b129a2f045f76689c253d13aa8c8bc 3d93bc0affd8a6db19ed7397ed211e4499de0eae glsl-packing-20180131-git glsl-packing.asd +glsl-spec http://beta.quicklisp.org/archive/glsl-spec/2019-10-07/glsl-spec-release-quicklisp-f04476f7-git.tgz 133677 52760939a269acce6b2cba8dbde81ef7 4427cd544f8db5028d5acf54c85f55f398d8a8e7 glsl-spec-release-quicklisp-f04476f7-git glsl-docs.asd glsl-spec.asd glsl-symbols.asd +glsl-toolkit http://beta.quicklisp.org/archive/glsl-toolkit/2019-12-27/glsl-toolkit-20191227-git.tgz 35623 69c04729b2bf81cd399e3c71577849fa 676d61ea181160e6276afd2d571e872467dfd167 glsl-toolkit-20191227-git glsl-toolkit.asd +glu-tessellate http://beta.quicklisp.org/archive/glu-tessellate/2015-06-08/glu-tessellate-20150608-git.tgz 4736 bebb4d2d5c471ecd0c542ea01b7c48ab 38ef8ee019ff2e082ecb7b582ab86ba245fc9b74 glu-tessellate-20150608-git glu-tessellate.asd +glyphs http://beta.quicklisp.org/archive/glyphs/2018-07-11/glyphs-20180711-git.tgz 16354 1b7cd4d3cda79fa8a35148fedf991e11 a14199085a75163efefd17cfce15fb0a6f3bc9ee glyphs-20180711-git glyphs-test.asd glyphs.asd +golden-utils http://beta.quicklisp.org/archive/golden-utils/2019-08-13/golden-utils-20190813-git.tgz 8881 f66ce89ef840df51d4576964e1bdf393 9ece6b4ea846177cc830248f062b214b4309c75f golden-utils-20190813-git golden-utils.asd +gordon http://beta.quicklisp.org/archive/gordon/2014-07-13/gordon-20140713-git.tgz 91027 aeb5459e295855ce205af6f3fa15621a 4d3952782099079c6f6f3070ed6c964f997fb83a gordon-20140713-git gordon.asd +graph http://beta.quicklisp.org/archive/graph/2019-11-30/graph-20191130-git.tgz 40849 f2ccfbb47e4bcdf39f203dd4eab17524 99b642d96f96d882cf6cd4cd0cdd0a96752adeb1 graph-20191130-git graph.asd +graylex http://beta.quicklisp.org/archive/graylex/2011-05-22/graylex-20110522-git.tgz 26517 ebed20d32a2ed9bb763adac09a28ee7d be6cbbe39543e51eafbd0aa171353905db8f251a graylex-20110522-git graylex-m4-example.asd graylex.asd +green-threads http://beta.quicklisp.org/archive/green-threads/2014-12-17/green-threads-20141217-git.tgz 7895 6f2ac5dde894abb04e9dbb55c70ee658 61959b4f605a546d4fbe07a6c84f6754e54e9563 green-threads-20141217-git green-threads.asd +group-by http://beta.quicklisp.org/archive/group-by/2014-02-11/group-by-20140211-git.tgz 9071 25caa8291d230d98f66bca57a28ee7a5 9f600f78dc04fbfd4a1260427eb3079278ba2932 group-by-20140211-git group-by.asd +grovel-locally http://beta.quicklisp.org/archive/grovel-locally/2018-02-28/grovel-locally-20180228-git.tgz 5896 e99f1dece67838730a8845c7fbbf19c6 c419b568a3d45c9232a2ceae328c099b736472bc grovel-locally-20180228-git grovel-locally.asd +gsll http://beta.quicklisp.org/archive/gsll/2018-08-31/gsll-quicklisp-eeeda841-git.tgz 317981 4b21395e6c4531dc067d00ed10b580e1 de3edd6293d93620c33938c1ca6318ae13b6bdb4 gsll-quicklisp-eeeda841-git gsll.asd +gtk-tagged-streams http://beta.quicklisp.org/archive/gtk-tagged-streams/2018-02-28/gtk-tagged-streams-quicklisp-d1c2b827-git.tgz 73541 952070238f59cf17496556a98f04e8f6 7d4a0f5d5895e8eb0ab4f7d0d37547dc7eb211b3 gtk-tagged-streams-quicklisp-d1c2b827-git gtk-tagged-streams.asd +gtype http://beta.quicklisp.org/archive/gtype/2019-12-27/gtype-20191227-git.tgz 23144 f56dcd60fb6508203deb7cb033a61160 802686958b3d24e9d37c3e72aa0490a29ac594ab gtype-20191227-git gtype.asd gtype.test.asd +gzip-stream http://beta.quicklisp.org/archive/gzip-stream/2010-10-06/gzip-stream_0.2.8.tgz 12149 6f0c06fdf7ca0c3124593a2b99b69935 fbcd75fd3042c6fb7f33bcd4d7f065e2248a6a38 gzip-stream_0.2.8 gzip-stream.asd +halftone http://beta.quicklisp.org/archive/halftone/2019-07-10/halftone-20190710-git.tgz 5664 8b0e8a4411bd73acac297d124dd4d672 6b80181e4f8e8c2e564df62cf751f0c8d7d2667d halftone-20190710-git halftone.asd +harmony http://beta.quicklisp.org/archive/harmony/2019-07-10/harmony-20190710-git.tgz 70775 20addce2884c8206923ed8e02c59cc8a 8036fd327146c97dc9161160323b220df4feeba6 harmony-20190710-git drains/harmony-alsa.asd drains/harmony-coreaudio.asd drains/harmony-openal.asd drains/harmony-out123.asd drains/harmony-pulse.asd drains/harmony-wasapi.asd harmony.asd simple/harmony-simple.asd sources/harmony-flac.asd sources/harmony-mp3.asd sources/harmony-wav.asd +hash-set http://beta.quicklisp.org/archive/hash-set/2016-06-28/hash-set-20160628-git.tgz 6076 254fe9e8496265f078c4151ba3023f1b c1ddb19b474dfb9cc36ed6d5fc1858a15181d8ac hash-set-20160628-git hash-set-tests.asd hash-set.asd +hdf5-cffi http://beta.quicklisp.org/archive/hdf5-cffi/2018-02-28/hdf5-cffi-20180228-git.tgz 54363 dbe93f460641f2be9a9c1a910d4ef315 f6a7edd796abf4c379fe7e954690e6362d342600 hdf5-cffi-20180228-git hdf5-cffi.asd hdf5-cffi.examples.asd hdf5-cffi.test.asd +heap http://beta.quicklisp.org/archive/heap/2018-10-18/heap-20181018-git.tgz 2871 a2355ef9c113a3335919a45195083951 3c94679187d9a855a343647f8503812c0925f4f9 heap-20181018-git heap.asd +helambdap http://beta.quicklisp.org/archive/helambdap/2019-10-07/helambdap-20191007-git.tgz 101499 29f86c6e34ec5c7b09a7425e78c4bf17 76ea5c8f4026daa236e3f0b4af990e1450f83ffb helambdap-20191007-git helambdap.asd +hemlock http://beta.quicklisp.org/archive/hemlock/2016-12-08/hemlock-20161208-git.tgz 1283394 743d6fab15c5eed78c259f7afb5cd748 dd3196e78efee2f55be6e08adfe2d5dafc308d2f hemlock-20161208-git hemlock.base.asd hemlock.clx.asd hemlock.qt.asd hemlock.tty.asd +hermetic http://beta.quicklisp.org/archive/hermetic/2019-10-07/hermetic-20191007-git.tgz 4564 72d6a7322c98bf3040e88bb17b2f8b27 532f1f055d8e3a277a123d6c7304588457c712ec hermetic-20191007-git hermetic.asd +hh-aws http://beta.quicklisp.org/archive/hh-aws/2015-08-04/hh-aws-20150804-git.tgz 16762 3d1f15d366f2c0b161f5c8b7759f868a 91faf1b47a18eeb129f608a594a43f230a0c10b4 hh-aws-20150804-git hh-aws.asd +hh-redblack http://beta.quicklisp.org/archive/hh-redblack/2015-10-31/hh-redblack-20151031-git.tgz 13091 4c61afc0406a8eacffebc494a1230beb b4f520f58d13ba5fddb22f042944db2dc02cd960 hh-redblack-20151031-git hh-redblack.asd +hh-web http://beta.quicklisp.org/archive/hh-web/2014-11-06/hh-web-20141106-git.tgz 49100 f18080fa53654dac8d77e5ed5d9953ff d40315c8346f3d101c6c3acecb2e3ae24100484a hh-web-20141106-git hh-web.asd +hl7-client http://beta.quicklisp.org/archive/hl7-client/2015-04-07/hl7-client-20150407-git.tgz 3149 ee18a7ef718e2fb389ad27e6dd628d6d ab1915436f9377f698785eacbafbb8615441956e hl7-client-20150407-git hl7-client.asd +hl7-parser http://beta.quicklisp.org/archive/hl7-parser/2016-05-31/hl7-parser-20160531-git.tgz 5154 92fc8f793d674bb661b0363e1721b3d0 388f1e64bb4d2b76818ac0c02299fcab906b5538 hl7-parser-20160531-git hl7-parser.asd +horner http://beta.quicklisp.org/archive/horner/2019-11-30/horner-20191130-git.tgz 4644 8b4eabb5b0d56ba098ac4a21ae82ff60 aee72c11f78279ad81a01703e3110f1fc0b8aff7 horner-20191130-git horner.asd +horse-html http://beta.quicklisp.org/archive/horse-html/2019-10-07/horse-html-20191007-git.tgz 6518 c5ecbddc6a5e3c40d8329d13a2683763 e5ca014c5a7ca7db9e1f24e27d33c0ee016a53fb horse-html-20191007-git horse-html.asd +house http://beta.quicklisp.org/archive/house/2018-04-30/house-20180430-git.tgz 13014 6f39b6666d880b2be9cf8ed12222b626 17bc8a62f6cca820ed1b89ffbb2249b46b2c4a57 house-20180430-git house.asd +hspell http://beta.quicklisp.org/archive/hspell/2014-12-17/hspell-20141217-git.tgz 2205 a2bce23a0e37215f8302d1092c60c35e 19c8bb3f33d3f7df3a6fbec8a798c1c1f358ab38 hspell-20141217-git hspell.asd +ht-simple-ajax http://beta.quicklisp.org/archive/ht-simple-ajax/2013-04-21/ht-simple-ajax-20130421-git.tgz 10059 2787aebfc9c4d458206d50461f9443ab e1871d0755dbd48151d54c0c0e512f84798b3d4c ht-simple-ajax-20130421-git ht-simple-ajax.asd +html-encode http://beta.quicklisp.org/archive/html-encode/2010-10-06/html-encode-1.2.tgz 3132 67f22483fe6d270b8830f78f285a1016 ce347529dbb02f008c079427bcb1050372cc24e4 html-encode-1.2 html-encode.asd +html-entities http://beta.quicklisp.org/archive/html-entities/2017-10-19/html-entities-20171019-git.tgz 39697 7a71bcd138f1f367f26e26e9c8e3a390 95458f97469288061d505756bc1f1518b37462d7 html-entities-20171019-git html-entities.asd +html-template http://beta.quicklisp.org/archive/html-template/2017-12-27/html-template-20171227-git.tgz 32376 fb77c495914641f5e67e51a370b2d5a3 946ce5d402bb54c60f84acd6c6d7f6590ede40f1 html-template-20171227-git html-template.asd +http-body http://beta.quicklisp.org/archive/http-body/2019-08-13/http-body-20190813-git.tgz 15739 d46ac52643ae7dc148438f84a8107a79 1da29c1f6f6a06a5ab784acad8ebf702ba6c6216 http-body-20190813-git http-body-test.asd http-body.asd +http-get-cache http://beta.quicklisp.org/archive/http-get-cache/2018-02-28/http-get-cache-20180228-git.tgz 3610 807a9feefeed19159ff46c5733e13da6 2c4623119391c1403fd86f5c19e4865839e62e71 http-get-cache-20180228-git http-get-cache.asd +http-parse http://beta.quicklisp.org/archive/http-parse/2015-06-08/http-parse-20150608-git.tgz 30047 89b5449d33d1ad027606259f84b4c282 65a5aa04e2f6761fc87e6f2c7e7182462ebdaf3f http-parse-20150608-git http-parse-test.asd http-parse.asd +hu.dwim.asdf http://beta.quicklisp.org/archive/hu.dwim.asdf/2019-05-21/hu.dwim.asdf-20190521-darcs.tgz 6579 b359bf05f587196eba172803b5594318 435c3581852106065ba0d6978a23ac3e896d3a64 hu.dwim.asdf-20190521-darcs hu.dwim.asdf.asd hu.dwim.asdf.documentation.asd +hu.dwim.bluez http://beta.quicklisp.org/archive/hu.dwim.bluez/2016-09-29/hu.dwim.bluez-quicklisp-f3ebd960-git.tgz 126596 f751576de9d66818115f4db9f448644e 7ffaa82b75608d347efe799d50665b30b5dc07d0 hu.dwim.bluez-quicklisp-f3ebd960-git hu.dwim.bluez.asd +hu.dwim.common http://beta.quicklisp.org/archive/hu.dwim.common/2015-07-09/hu.dwim.common-20150709-darcs.tgz 3083 fff7f05c24e71a0270021909ca86a9ef 6ff0a62c94fee95b1440b59230f4a9c174d95093 hu.dwim.common-20150709-darcs hu.dwim.common.asd hu.dwim.common.documentation.asd +hu.dwim.common-lisp http://beta.quicklisp.org/archive/hu.dwim.common-lisp/2015-07-09/hu.dwim.common-lisp-20150709-darcs.tgz 2107 d3319cf3d963bff64ff90847af79251f b49f86c70a89ef52bb6b8da5b981d4ff51de48f9 hu.dwim.common-lisp-20150709-darcs hu.dwim.common-lisp.asd hu.dwim.common-lisp.documentation.asd +hu.dwim.computed-class http://beta.quicklisp.org/archive/hu.dwim.computed-class/2016-12-04/hu.dwim.computed-class-20161204-darcs.tgz 18769 f644ad7dd48737020a814319c934d23a ddb5126e5d2ff305ad5701106875710c8ac9c833 hu.dwim.computed-class-20161204-darcs hu.dwim.computed-class+hu.dwim.logger.asd hu.dwim.computed-class+swank.asd hu.dwim.computed-class.asd hu.dwim.computed-class.documentation.asd hu.dwim.computed-class.test.asd +hu.dwim.debug http://beta.quicklisp.org/archive/hu.dwim.debug/2019-01-07/hu.dwim.debug-20190107-darcs.tgz 6637 18d7d06110fdbd454e350d92cf5f17cc 3ba6fdf418010b6d7dc03d3dc95ec7c4171d6933 hu.dwim.debug-20190107-darcs hu.dwim.debug.asd hu.dwim.debug.documentation.asd hu.dwim.debug.test.asd +hu.dwim.def http://beta.quicklisp.org/archive/hu.dwim.def/2017-10-19/hu.dwim.def-20171019-darcs.tgz 19966 b0b6adc89b6aeb22fc6bb0caa9253712 c7f0abc95067fafa8764cea694dfe69a852dee61 hu.dwim.def-20171019-darcs hu.dwim.def+cl-l10n.asd hu.dwim.def+contextl.asd hu.dwim.def+hu.dwim.common.asd hu.dwim.def+hu.dwim.delico.asd hu.dwim.def+swank.asd hu.dwim.def.asd hu.dwim.def.documentation.asd hu.dwim.def.namespace.asd hu.dwim.def.test.asd +hu.dwim.defclass-star http://beta.quicklisp.org/archive/hu.dwim.defclass-star/2015-07-09/hu.dwim.defclass-star-20150709-darcs.tgz 7655 e37f386dca8f789fb2e303a1914f0415 ef556505bb91ff2d2f87bd327815e0f8bc4bde49 hu.dwim.defclass-star-20150709-darcs hu.dwim.defclass-star+contextl.asd hu.dwim.defclass-star+hu.dwim.def+contextl.asd hu.dwim.defclass-star+hu.dwim.def.asd hu.dwim.defclass-star+swank.asd hu.dwim.defclass-star.asd hu.dwim.defclass-star.documentation.asd hu.dwim.defclass-star.test.asd +hu.dwim.delico http://beta.quicklisp.org/archive/hu.dwim.delico/2018-04-30/hu.dwim.delico-20180430-darcs.tgz 19912 8fed0622f682d1de701d343159a43c7f adb94372a21da4e5c6d01908331fabd4a8cbeead hu.dwim.delico-20180430-darcs hu.dwim.delico.asd hu.dwim.delico.documentation.asd hu.dwim.delico.test.asd +hu.dwim.graphviz http://beta.quicklisp.org/archive/hu.dwim.graphviz/2017-08-30/hu.dwim.graphviz-20170830-darcs.tgz 11239 421c6dacc287bbc76443cc0e657ccaec 187e541dfe4add0b4ce0e9d111c15a5cd30070fd hu.dwim.graphviz-20170830-darcs hu.dwim.graphviz.asd hu.dwim.graphviz.documentation.asd hu.dwim.graphviz.test.asd +hu.dwim.logger http://beta.quicklisp.org/archive/hu.dwim.logger/2015-12-18/hu.dwim.logger-20151218-darcs.tgz 11456 4e180dbb379266d0cd29f5c238e1da5a 4e014f4993835235ac53a47fb900ea44b0652cc8 hu.dwim.logger-20151218-darcs hu.dwim.logger+iolib.asd hu.dwim.logger+swank.asd hu.dwim.logger.asd hu.dwim.logger.documentation.asd hu.dwim.logger.test.asd +hu.dwim.partial-eval http://beta.quicklisp.org/archive/hu.dwim.partial-eval/2017-11-30/hu.dwim.partial-eval-20171130-darcs.tgz 24393 78c498a3ba353e0a62e15df49a459078 9acbc3ab6c50c1104c94047ef747456a7cffd854 hu.dwim.partial-eval-20171130-darcs hu.dwim.partial-eval.asd hu.dwim.partial-eval.documentation.asd hu.dwim.partial-eval.test.asd +hu.dwim.perec http://beta.quicklisp.org/archive/hu.dwim.perec/2018-01-31/hu.dwim.perec-20180131-darcs.tgz 183286 d83b7b553244d10d7ce1dfc163a5d7ff 4eecec9468212801e4574db2c0cdcf4eb662575f hu.dwim.perec-20180131-darcs hu.dwim.perec+hu.dwim.quasi-quote.xml.asd hu.dwim.perec+iolib.asd hu.dwim.perec+swank.asd hu.dwim.perec.all.asd hu.dwim.perec.all.test.asd hu.dwim.perec.asd hu.dwim.perec.documentation.asd hu.dwim.perec.oracle.asd hu.dwim.perec.oracle.test.asd hu.dwim.perec.postgresql.asd hu.dwim.perec.postgresql.test.asd hu.dwim.perec.sqlite.asd hu.dwim.perec.sqlite.test.asd hu.dwim.perec.test.asd +hu.dwim.presentation http://beta.quicklisp.org/archive/hu.dwim.presentation/2017-10-19/hu.dwim.presentation-20171019-darcs.tgz 1729653 428ab20690f3513d974448d0097e6de1 66e02a2cf33ed07c918bc81c48237a3a268baca9 hu.dwim.presentation-20171019-darcs hu.dwim.presentation+cl-graph+cl-typesetting.asd hu.dwim.presentation+cl-typesetting.asd hu.dwim.presentation+hu.dwim.stefil.asd hu.dwim.presentation+hu.dwim.web-server.asd hu.dwim.presentation.asd +hu.dwim.quasi-quote http://beta.quicklisp.org/archive/hu.dwim.quasi-quote/2017-11-30/hu.dwim.quasi-quote-20171130-darcs.tgz 72072 314b7f577e7aec4e0ad0fafea22664b3 a6cfe34f6d330f543155a40b1324a70c94272fa5 hu.dwim.quasi-quote-20171130-darcs hu.dwim.quasi-quote.asd hu.dwim.quasi-quote.css.asd hu.dwim.quasi-quote.documentation.asd hu.dwim.quasi-quote.js.asd hu.dwim.quasi-quote.pdf.asd hu.dwim.quasi-quote.test.asd hu.dwim.quasi-quote.xml+cxml.asd hu.dwim.quasi-quote.xml+hu.dwim.quasi-quote.js.asd hu.dwim.quasi-quote.xml.asd +hu.dwim.rdbms http://beta.quicklisp.org/archive/hu.dwim.rdbms/2018-02-28/hu.dwim.rdbms-20180228-darcs.tgz 116724 719880aa6837228d1f87176ab3cd003b cea924b46169e492767618038ea8351d8459eecf hu.dwim.rdbms-20180228-darcs hu.dwim.rdbms.all.asd hu.dwim.rdbms.all.test.asd hu.dwim.rdbms.asd hu.dwim.rdbms.documentation.asd hu.dwim.rdbms.oracle.asd hu.dwim.rdbms.oracle.test.asd hu.dwim.rdbms.postgresql.asd hu.dwim.rdbms.postgresql.test.asd hu.dwim.rdbms.sqlite.asd hu.dwim.rdbms.sqlite.test.asd hu.dwim.rdbms.test.asd +hu.dwim.reiterate http://beta.quicklisp.org/archive/hu.dwim.reiterate/2017-10-19/hu.dwim.reiterate-20171019-darcs.tgz 21412 d6f0210e9e4aaef63dcbf24aeb564dd1 bad2b13f2aedeee69b767e6fc723fea2d40246b3 hu.dwim.reiterate-20171019-darcs hu.dwim.reiterate+hu.dwim.logger.asd hu.dwim.reiterate.asd +hu.dwim.sdl http://beta.quicklisp.org/archive/hu.dwim.sdl/2018-02-28/hu.dwim.sdl-quicklisp-aad47404-git.tgz 1787723 9474a5fda11b03a06706ea11a56b2822 8f030144d97d14ac58dc2b12f4b5cf60bbc360af hu.dwim.sdl-quicklisp-aad47404-git hu.dwim.sdl.asd +hu.dwim.serializer http://beta.quicklisp.org/archive/hu.dwim.serializer/2016-12-04/hu.dwim.serializer-20161204-darcs.tgz 12092 bb15ef778eca814e4f1caa5ae05fb7ad 197e6d4df639b4bbd976e819b3247d20a937bb5e hu.dwim.serializer-20161204-darcs hu.dwim.serializer.asd hu.dwim.serializer.documentation.asd hu.dwim.serializer.test.asd +hu.dwim.stefil http://beta.quicklisp.org/archive/hu.dwim.stefil/2017-04-03/hu.dwim.stefil-20170403-darcs.tgz 24074 ea8be76a360b1df297a8bbd50be0d8a1 d5a5ca36649838b14a270cea28743883672598e3 hu.dwim.stefil-20170403-darcs hu.dwim.stefil+hu.dwim.def+swank.asd hu.dwim.stefil+hu.dwim.def.asd hu.dwim.stefil+swank.asd hu.dwim.stefil.asd +hu.dwim.syntax-sugar http://beta.quicklisp.org/archive/hu.dwim.syntax-sugar/2016-12-04/hu.dwim.syntax-sugar-20161204-darcs.tgz 19274 c155225d3a2b9a329adfcb705b915a91 2f4c5e896d05181efcf0debf1741ac3e0e2fca06 hu.dwim.syntax-sugar-20161204-darcs hu.dwim.syntax-sugar.asd hu.dwim.syntax-sugar.documentation.asd hu.dwim.syntax-sugar.test.asd +hu.dwim.uri http://beta.quicklisp.org/archive/hu.dwim.uri/2018-02-28/hu.dwim.uri-20180228-darcs.tgz 8543 0e3408935a77c74a944f9a34dae3e728 f26121022ce365911e2ab03d8de2af07b8ec2a2d hu.dwim.uri-20180228-darcs hu.dwim.uri.asd hu.dwim.uri.test.asd +hu.dwim.util http://beta.quicklisp.org/archive/hu.dwim.util/2017-10-19/hu.dwim.util-20171019-darcs.tgz 51237 57a824c371c7fc393373218e4c1b543f e43f21213958998e39ab6e6d1c563a019f277ff7 hu.dwim.util-20171019-darcs hu.dwim.util+iolib.asd hu.dwim.util.asd hu.dwim.util.documentation.asd hu.dwim.util.test.asd +hu.dwim.walker http://beta.quicklisp.org/archive/hu.dwim.walker/2015-12-18/hu.dwim.walker-20151218-darcs.tgz 37982 39c1af6715dacb25329cddefac1be792 72b3e954bd87f3834b7b2f7f79509677b6e57b54 hu.dwim.walker-20151218-darcs hu.dwim.walker.asd hu.dwim.walker.documentation.asd hu.dwim.walker.test.asd +hu.dwim.web-server http://beta.quicklisp.org/archive/hu.dwim.web-server/2018-12-10/hu.dwim.web-server-20181210-darcs.tgz 511462 1bc99a6a26cb46ba7a8fa968034376ef c9b3001c740074b12f5d45a787dec1fb373bba28 hu.dwim.web-server-20181210-darcs hu.dwim.web-server+swank.asd hu.dwim.web-server.application+hu.dwim.perec.asd hu.dwim.web-server.application.asd hu.dwim.web-server.application.test.asd hu.dwim.web-server.asd hu.dwim.web-server.documentation.asd hu.dwim.web-server.test.asd hu.dwim.web-server.websocket.asd +hu.dwim.zlib http://beta.quicklisp.org/archive/hu.dwim.zlib/2017-08-30/hu.dwim.zlib-quicklisp-18b8e530-git.tgz 164424 b211be3638ce70b50c87af43e982f46f 39e7e7e389db0189e84d852fb59079b9380110ea hu.dwim.zlib-quicklisp-18b8e530-git hu.dwim.zlib.asd +huffman http://beta.quicklisp.org/archive/huffman/2018-10-18/huffman-20181018-git.tgz 2956 195c5722536473cadd283336008bab57 a458727ba8a5e188ecc18e64544836e83fab9b24 huffman-20181018-git huffman.asd +humbler http://beta.quicklisp.org/archive/humbler/2019-07-10/humbler-20190710-git.tgz 48317 a24a0968292724abb594d0a114e61e73 94ec67e5fe60b158d713497084db49be582d1b3d humbler-20190710-git humbler.asd +hunchensocket http://beta.quicklisp.org/archive/hunchensocket/2018-07-11/hunchensocket-20180711-git.tgz 12634 bf6cd52c13e3b1f464c8a45a8bac85b8 6a24827054f897a200220f416ba63db56ce24887 hunchensocket-20180711-git hunchensocket.asd +hunchentools http://beta.quicklisp.org/archive/hunchentools/2016-12-04/hunchentools-20161204-git.tgz 5310 3e4c00484a54fce107969941aa695e35 81c5f8bed80dd333cbc1be69da3bb2c752d7ebf9 hunchentools-20161204-git hunchentools.asd +hunchentoot http://beta.quicklisp.org/archive/hunchentoot/2017-12-27/hunchentoot-v1.2.38.tgz 218697 878a7833eb34a53231011b78e998e2fa 4fb0bf93d3cf3720e0bf0b222d01df8df1012857 hunchentoot-v1.2.38 hunchentoot.asd +hunchentoot-auth http://beta.quicklisp.org/archive/hunchentoot-auth/2014-01-13/hunchentoot-auth-20140113-git.tgz 5878 f6763dbbfd1f5421e46ff3e9648eeef6 fffbfd821814f8460262143be04c16db0d5f29f7 hunchentoot-auth-20140113-git hunchentoot-auth.asd +hunchentoot-cgi http://beta.quicklisp.org/archive/hunchentoot-cgi/2014-02-11/hunchentoot-cgi-20140211-git.tgz 4322 e300c5959f7100b7e032066239d82541 bf8b301b9f4a99a4ef2237581df81f2d848349a4 hunchentoot-cgi-20140211-git hunchentoot-cgi.asd +hunchentoot-multi-acceptor http://beta.quicklisp.org/archive/hunchentoot-multi-acceptor/2019-11-30/hunchentoot-multi-acceptor-20191130-git.tgz 6408 734aa1624d6d04f26664f4fcff10df9e 1889515bcd205853c813f4d0527330b2077e0d84 hunchentoot-multi-acceptor-20191130-git hunchentoot-multi-acceptor.asd +hunchentoot-single-signon http://beta.quicklisp.org/archive/hunchentoot-single-signon/2013-11-11/hunchentoot-single-signon-20131111-git.tgz 2279 52b6a4438e7c63209f674eadba35168c a67c2e3a07f00cf2738ac14400ebdc44868195dc hunchentoot-single-signon-20131111-git hunchentoot-single-signon.asd +hyperluminal-mem http://beta.quicklisp.org/archive/hyperluminal-mem/2016-12-04/hyperluminal-mem-20161204-git.tgz 88995 da358539317553cbdaef4c219d20b67a 762447423e1be7578ac777b8bc18abd82e258c16 hyperluminal-mem-20161204-git hyperluminal-mem.asd +hyperobject http://beta.quicklisp.org/archive/hyperobject/2013-04-20/hyperobject-20130420-git.tgz 41879 460a3c040b1ef40bdc9290eaa1a86249 da930ff34d7d234a1ae6e7c7596f0f5810106a3f hyperobject-20130420-git hyperobject-tests.asd hyperobject.asd +hyperspec http://beta.quicklisp.org/archive/hyperspec/2018-12-10/hyperspec-20181210-git.tgz 23892 742d80f89020e90234f1b8b6f00a3056 4bafc32c2cfd86b013525385e98ec7fa6a6a32c7 hyperspec-20181210-git hyperspec.asd +ia-hash-table http://beta.quicklisp.org/archive/ia-hash-table/2016-03-18/ia-hash-table-20160318-git.tgz 4491 59a825b5b809aabb5ac5db96728756b7 e23c512d4ab5c06fe31cda3fddad17e88981d2c5 ia-hash-table-20160318-git ia-hash-table.asd ia-hash-table.test.asd +iclendar http://beta.quicklisp.org/archive/iclendar/2019-07-10/iclendar-20190710-git.tgz 88066 4ce57c1359648e497fb25962ec2c0594 0bbc2d371b1f87d4077dff0e978f29dc9ebeca50 iclendar-20190710-git iclendar.asd +id3v2 http://beta.quicklisp.org/archive/id3v2/2016-02-08/id3v2-20160208-git.tgz 3963 427ec2cf9a5f8a8be20a663c336c2288 523e03187ec89b0ce2fe95c9bb9dd1376b6856e4 id3v2-20160208-git id3v2-test.asd id3v2.asd +idna http://beta.quicklisp.org/archive/idna/2012-01-07/idna-20120107-git.tgz 6242 85b91a66efe4381bf116cdb5d2b756b6 a32def3834b2130ace95c31af82c6c8b92365c53 idna-20120107-git idna.asd +ieee-floats http://beta.quicklisp.org/archive/ieee-floats/2017-08-30/ieee-floats-20170830-git.tgz 5325 3434b4d91224ca6a817ced9d83f14bb6 fa9e496f0fcf4ba05754fc32787f728ca6e2d674 ieee-floats-20170830-git ieee-floats.asd +illogical-pathnames http://beta.quicklisp.org/archive/illogical-pathnames/2016-08-25/illogical-pathnames-20160825-git.tgz 6071 386d2b1c0a4f280a52841f4a58ddfad2 dce6a9935768ed7323f4744e9d42752aa52af3d2 illogical-pathnames-20160825-git illogical-pathnames.asd +illusion http://beta.quicklisp.org/archive/illusion/2018-08-31/illusion-20180831-git.tgz 5591 e29adc45f1e630a68b7a2594ce8e1d38 b3edb224814b92f42bdc85f76cfda22fb4a61caf illusion-20180831-git illusion-test.asd illusion.asd +image http://beta.quicklisp.org/archive/image/2012-01-07/image-20120107-git.tgz 12334 f6e1bdabba64a9be1f31602ef87b993c f54562f11b8c6b005a480974bf6742c3dff33864 image-20120107-git image.asd +imago http://beta.quicklisp.org/archive/imago/2015-06-08/imago-20150608-git.tgz 17228 2aadfc8061203e178ef01d1169d70371 7914c440be279c14f7af25456ace26b7cd0a7cf6 imago-20150608-git imago.asd +immutable-struct http://beta.quicklisp.org/archive/immutable-struct/2015-07-09/immutable-struct-20150709-git.tgz 2413 dd68ea45a64bd739e733aa2bcf59955c cca9b233fdb9c441fd02a0015a91b982b34978be immutable-struct-20150709-git immutable-struct.asd +incf-cl http://beta.quicklisp.org/archive/incf-cl/2019-07-10/incf-cl-20190710-git.tgz 14029 d517885c08a3c9ab7ab0f56071660ed4 4c29c854fba0610eb9f8adc42b99a1e15bff8bfe incf-cl-20190710-git incf-cl.asd +incognito-keywords http://beta.quicklisp.org/archive/incognito-keywords/2013-01-28/incognito-keywords-1.1.tgz 3817 4759f96fbe4f7873f52d126cec3d5b51 d01f0962811264cea7a3ae1abcc510fd0b177d07 incognito-keywords-1.1 incognito-keywords.asd +incongruent-methods http://beta.quicklisp.org/archive/incongruent-methods/2013-03-12/incongruent-methods-20130312-git.tgz 7171 9e41e9a0a9f33e4f9a00b7d525d8d9c2 73424d66cec5c544ac1fd30729d4357ee2ede37a incongruent-methods-20130312-git incongruent-methods.asd +inferior-shell http://beta.quicklisp.org/archive/inferior-shell/2016-09-29/inferior-shell-20160929-git.tgz 11709 0a48be6575e42fa47a574cd60596d73f 8e1c0011055880ad74bbf128679977b06cb119cb inferior-shell-20160929-git inferior-shell.asd +infix-dollar-reader http://beta.quicklisp.org/archive/infix-dollar-reader/2012-10-13/infix-dollar-reader-20121013-git.tgz 2671 b94e744bb2cb69b22b8ca1b94711372c 76156fbe2d0f809d57a8fb74355b4cd9a25c1272 infix-dollar-reader-20121013-git infix-dollar-reader-test.asd infix-dollar-reader.asd +infix-math http://beta.quicklisp.org/archive/infix-math/2017-08-30/infix-math-20170830-git.tgz 7244 3a4e1c58636f6126b6ad2a00a1bf0918 ea2bdbb2e223090a3bfa40f4bb120ab4dab730f9 infix-math-20170830-git infix-math.asd +injection http://beta.quicklisp.org/archive/injection/2016-05-31/injection-20160531-git.tgz 16529 fd550866b59e2f852a7457318435cc54 3688d8be08eecc9140e2f6141e94490409227a54 injection-20160531-git injection-test.asd injection.asd +inkwell http://beta.quicklisp.org/archive/inkwell/2019-07-10/inkwell-20190710-git.tgz 19455 80965d4bd6e377146f684c9f55dcdb50 a0e229d7125c2995ae6c28b1e2ce600d59c506da inkwell-20190710-git inkwell.asd +inlined-generic-function http://beta.quicklisp.org/archive/inlined-generic-function/2019-05-21/inlined-generic-function-20190521-git.tgz 13775 e9336f83fe941d4188063d5b8a1daee2 ddb708a3730c99fe766c6f7412119a1c828bd1a3 inlined-generic-function-20190521-git inlined-generic-function.asd inlined-generic-function.test.asd +inner-conditional http://beta.quicklisp.org/archive/inner-conditional/2015-06-08/inner-conditional-20150608-git.tgz 14366 ddb07ddd8d96bff1ccad30a690e48b88 3a3bd7bbff2901db70f79023dff565be75ac1a85 inner-conditional-20150608-git inner-conditional-test.asd inner-conditional.asd +inotify http://beta.quicklisp.org/archive/inotify/2015-06-08/inotify-20150608-git.tgz 3569 185ac26e780c2d0426b261fbbccca12a fce1a600d8dfddb1193e9ee71b0df2d58a2fe288 inotify-20150608-git inotify.asd +inquisitor http://beta.quicklisp.org/archive/inquisitor/2019-05-21/inquisitor-20190521-git.tgz 938309 b3ccd374ca6d78db990605fa34ca9e6f d9c38ed218610dd382652062ca3ddb5787d82906 inquisitor-20190521-git inquisitor-flexi-test.asd inquisitor-flexi.asd inquisitor-test.asd inquisitor.asd +integral http://beta.quicklisp.org/archive/integral/2018-10-18/integral-20181018-git.tgz 24642 d8c8057d590cbc0104f1e8eaf6dbb168 9858da149eac66b6bf18bd2100068da5313c7989 integral-20181018-git integral-test.asd integral.asd +integral-rest http://beta.quicklisp.org/archive/integral-rest/2015-09-23/integral-rest-20150923-git.tgz 5803 335875a5465c16346cd29689873dc643 97379a1ff7b2b586b9f3bc8070f70be0009d7487 integral-rest-20150923-git integral-rest-test.asd integral-rest.asd +intel-hex http://beta.quicklisp.org/archive/intel-hex/2016-03-18/intel-hex-20160318-git.tgz 5977 0558406788710ac04f4493a66deb2ebe 43cece1a8cf9a6d2b3b574e95a94a9f6825f5ce0 intel-hex-20160318-git intel-hex-test.asd intel-hex.asd +intercom http://beta.quicklisp.org/archive/intercom/2013-06-15/intercom-20130615-git.tgz 32404 9188e4147f75529e5d5e24561d5c6c4e 953a7a49ab8700823c352a0a488486bc2a80f392 intercom-20130615-git lisp/intercom-examples.asd lisp/intercom.asd +interface http://beta.quicklisp.org/archive/interface/2019-03-07/interface-20190307-hg.tgz 8186 2171f1127f13b79c82c56302b629c18b cbe7051bcbdb6fda388369eb1b31717a38217751 interface-20190307-hg interface.asd +introspect-environment http://beta.quicklisp.org/archive/introspect-environment/2015-10-31/introspect-environment-20151031-git.tgz 9127 3c61088583f11791530edb2e18f5d6f0 599d21a1de88776bb340d0830e7f3774f061c269 introspect-environment-20151031-git introspect-environment-test.asd introspect-environment.asd +iolib http://beta.quicklisp.org/archive/iolib/2018-02-28/iolib-v0.8.3.tgz 255866 fc28d4cad6f8e43972df3baa6a8ac45c e84165ed45f8746baa282c0e6152460421cb9ed1 iolib-v0.8.3 iolib.asd iolib.asdf.asd iolib.base.asd iolib.common-lisp.asd iolib.conf.asd iolib.examples.asd iolib.grovel.asd iolib.tests.asd +ip-interfaces http://beta.quicklisp.org/archive/ip-interfaces/2018-12-10/ip-interfaces-0.2.1.tgz 14797 c85e479e1eb4139f8996b335e7d0e034 573b6f8413bdfe11863e649f8aa3ec990662c1b8 ip-interfaces-0.2.1 ip-interfaces-test.asd ip-interfaces.asd +irc-logger http://beta.quicklisp.org/archive/irc-logger/2015-09-23/irc-logger-20150923-git.tgz 10393 6d6b60c0d2ac53575ee5c644beb162c3 1b39d7fad92c3ef94747f9be086c567c1dd317bb irc-logger-20150923-git irc-logger.asd +ironclad http://beta.quicklisp.org/archive/ironclad/2019-10-07/ironclad-v0.47.tgz 1452945 b82d370b037422fcaf8953857f03b5f6 07ff0ad14258a81e0ee4ab21abd1a3726a58328d ironclad-v0.47 ironclad-text.asd ironclad.asd +iso-8601-date http://beta.quicklisp.org/archive/iso-8601-date/2019-01-07/iso-8601-date-20190107-git.tgz 4440 b1ab5921a442d86bb2727b4a2bc9e8e0 f927777c79967a5afa2a419b5ef222a8817b9af7 iso-8601-date-20190107-git eclecticse.iso-8601-date.asd +iterate http://beta.quicklisp.org/archive/iterate/2018-02-28/iterate-20180228-git.tgz 333795 ee3b198b0f9674c11e5283e56f57ed78 063f13e39a7a17f8813f1707cab2c17ff3b20dc6 iterate-20180228-git iterate.asd +iterate-clsql http://beta.quicklisp.org/archive/iterate-clsql/2013-03-12/iterate-clsql-20130312-http.tgz 2704 0950d7a9b29b8ddb9d16b45b9096bdae 8f74118d5f989b73db760bcb0a794e23fa185a0a iterate-clsql-20130312-http iterate-clsql.asd +its http://beta.quicklisp.org/archive/its/2018-12-10/its-1.0.tgz 10137 221358638db1a4eedde70b5ff4870eea 69b22964952a5a537646ac0e3877e47101f12cb2 its-1.0 its.asd tests/its_tests.asd +jenkins http://beta.quicklisp.org/archive/jenkins/2013-03-12/jenkins-20130312-git.tgz 15878 53049d3dd8dfe5ea36738005c786f8d0 f3a1fad4ff41d91901a8fe5484bbb2b5df746119 jenkins-20130312-git jenkins.api.asd +jonathan http://beta.quicklisp.org/archive/jonathan/2019-02-02/jonathan-20190202-git.tgz 160340 bf340574fc901706ba2dcdc57e1e78ad 0d332a8f852c735d817c0eb4173f25d9e88f8262 jonathan-20190202-git jonathan-test.asd jonathan.asd +jose http://beta.quicklisp.org/archive/jose/2018-07-11/jose-20180711-git.tgz 14142 92786104f9775ea657c37ae846526ab4 d90b3bc348676117c1639fbdc0553e805daa5861 jose-20180711-git jose.asd +jp-numeral http://beta.quicklisp.org/archive/jp-numeral/2019-05-21/jp-numeral-20190521-git.tgz 41673 1969e0dec2db5270d6e7517ed1d9001b d8d48074786dad5f54b8ef528f575d38c68be6af jp-numeral-20190521-git jp-numeral-test.asd jp-numeral.asd +jpl-queues http://beta.quicklisp.org/archive/jpl-queues/2010-10-06/jpl-queues-0.1.tgz 15113 7c3d14c955db0a5c8ece2b9409333ce0 39497c7cb7292433b5c5a83d7ceb7a6e09cac7b1 jpl-queues-0.1 jpl-queues.asd +js http://beta.quicklisp.org/archive/js/2018-01-31/js-20180131-git.tgz 64836 52f3ec4406ac27a84b65be99ebda51e0 85b589dc6d059502fb56c7b265121ff36712cf19 js-20180131-git cl-js.asd +js-parser http://beta.quicklisp.org/archive/js-parser/2015-04-07/js-parser-20150407-git.tgz 67870 4b86296f7eb3542447528822f7fa2612 4b2e27dfa07c730235c2014740b4d91540d0f656 js-parser-20150407-git js-parser-tests.asd js-parser.asd +json-mop http://beta.quicklisp.org/archive/json-mop/2018-02-28/json-mop-20180228-git.tgz 6214 82d6e487a8410e7f4f95e02fa2615fc7 fd825e88baa5e8e9d7dc100acb1c6a35c60e8d87 json-mop-20180228-git json-mop.asd tests/json-mop-tests.asd +json-responses http://beta.quicklisp.org/archive/json-responses/2019-03-07/json-responses-20190307-hg.tgz 4722 27b0c30fe8df35ecbaa2a7e860191dc1 393cfe5d2254c49fb28ad2ba24a95d3ee5d26c89 json-responses-20190307-hg json-responses.asd +json-streams http://beta.quicklisp.org/archive/json-streams/2017-10-19/json-streams-20171019-git.tgz 45679 b5ab07dce6bfa17782384ecd66bba4bc 8cc35c603b9fdef5e94b82da5dbb72f3551f5530 json-streams-20171019-git json-streams-tests.asd json-streams.asd +jsonrpc http://beta.quicklisp.org/archive/jsonrpc/2019-10-07/jsonrpc-20191007-git.tgz 11608 dbc1e444df10dea1681e8e1a5b4180e8 9ac2f791d611f0be146e50628eeb2e5212d18748 jsonrpc-20191007-git jsonrpc.asd +jsown http://beta.quicklisp.org/archive/jsown/2019-11-30/jsown-20191130-git.tgz 14948 2714529af34123c5d5ea5a6ec401230b 69fa55f69254913584f583ba1aa66fd5f3aad7d6 jsown-20191130-git jsown.asd tests/jsown-tests.asd +jwacs http://beta.quicklisp.org/archive/jwacs/2018-02-28/jwacs-20180228-git.tgz 202732 9f9d92d2e616fddc3ceac0e5be375f8d 4e367cb507f1095f53b90aa52dab4b5ac83451f7 jwacs-20180228-git jwacs-tests.asd jwacs.asd +kebab http://beta.quicklisp.org/archive/kebab/2015-06-08/kebab-20150608-git.tgz 3165 b7136a488e5f7f202fd74c59516cac8e 7ba2ed7c0f2ed1ebc31f7c9776563257a5c12bdb kebab-20150608-git kebab-test.asd kebab.asd +kenzo http://beta.quicklisp.org/archive/kenzo/2019-12-27/kenzo-20191227-git.tgz 5263930 03078b7d09f64f801c45d966ff8a0106 05a19917ca01828e8bd25ab4d8057124c7c7be57 kenzo-20191227-git kenzo-test.asd kenzo.asd +kl-verify http://beta.quicklisp.org/archive/kl-verify/2012-09-09/kl-verify-20120909-git.tgz 1728 fd742a26d44433617cf60ded1b4954ac 573e3cde43bc677f4a5da6e76dc7d53923319c1f kl-verify-20120909-git kl-verify.asd +km http://beta.quicklisp.org/archive/km/2011-05-22/km-2-5-33.tgz 328656 f4ba865c0342c5cf8ebcb507becc5e56 57b80fb82b4ea580882fae61c663c79ba3e864ee km-2-5-33 km.asd +kmrcl http://beta.quicklisp.org/archive/kmrcl/2015-09-23/kmrcl-20150923-git.tgz 57358 0cd15d3ed3e7d56528dd3243d1a5c9b1 4fa994e358e4b454880961a4e0156e29e32f63ba kmrcl-20150923-git kmrcl-tests.asd kmrcl.asd +l-math http://beta.quicklisp.org/archive/l-math/2019-03-07/l-math-20190307-git.tgz 46344 1d72a81ab46e4ebfda1c749ca67a0e90 a5a68998c4bfebdf452c4d4386fab465051c7eb4 l-math-20190307-git l-math.asd +l-system http://beta.quicklisp.org/archive/l-system/2018-02-28/l-system-20180228-git.tgz 13953 d42ca0e95be4d4cb4390e62119ac7934 89f30dbbdbc8a60a242abc5c63f1daf7851691c8 l-system-20180228-git l-system-examples.asd l-system.asd +laap http://beta.quicklisp.org/archive/laap/2017-08-30/laap-20170830-git.tgz 15178 5d86b49f328d314cdf22a5bda9565f1a 8e90156c16ad1a0ff95b9f29bc8828bee5123101 laap-20170830-git laap.asd +lack http://beta.quicklisp.org/archive/lack/2019-10-07/lack-20191007-git.tgz 178459 bce7a6b5aefb5bfd3fbeb782dda7748f 63c157526deff72db55ccea3a93781fe0eb54897 lack-20191007-git lack-component.asd lack-middleware-accesslog.asd lack-middleware-auth-basic.asd lack-middleware-backtrace.asd lack-middleware-csrf.asd lack-middleware-mount.asd lack-middleware-session.asd lack-middleware-static.asd lack-request.asd lack-response.asd lack-session-store-dbi.asd lack-session-store-redis.asd lack-test.asd lack-util-writer-stream.asd lack-util.asd lack.asd t-lack-component.asd t-lack-middleware-accesslog.asd t-lack-middleware-auth-basic.asd t-lack-middleware-backtrace.asd t-lack-middleware-csrf.asd t-lack-middleware-mount.asd t-lack-middleware-session.asd t-lack-middleware-static.asd t-lack-request.asd t-lack-session-store-dbi.asd t-lack-session-store-redis.asd t-lack-util.asd t-lack.asd +lake http://beta.quicklisp.org/archive/lake/2019-12-27/lake-20191227-git.tgz 21133 0d875fa4eeb0618f27c0238b29d8a6fa 0febcaf9d47b37c55d37eeeb21eab7f3f4e72247 lake-20191227-git lake-test.asd lake.asd +lambda-fiddle http://beta.quicklisp.org/archive/lambda-fiddle/2019-07-10/lambda-fiddle-20190710-git.tgz 6230 78f68f144ace9cb8f634ac14b3414e5e fd5c91ae6695e1531502458db52d0410c471fcee lambda-fiddle-20190710-git lambda-fiddle.asd +lambda-reader http://beta.quicklisp.org/archive/lambda-reader/2017-01-24/lambda-reader-20170124-git.tgz 3905 f2d0b70125707b31f1975a58b6c3523e e96b520a862982bb8bb801dca92c7ee744c8588a lambda-reader-20170124-git lambda-reader-8bit.asd lambda-reader.asd +lambdalite http://beta.quicklisp.org/archive/lambdalite/2014-12-17/lambdalite-20141217-git.tgz 6077 77d34562c5527b0b771d923704e74420 b1334d9c1402362a9c3aeb17f0c53f065bbec9bb lambdalite-20141217-git lambdalite.asd +language-codes http://beta.quicklisp.org/archive/language-codes/2019-07-10/language-codes-20190710-git.tgz 68776 9629d0b8fb89f350d00c4aeac316ccc2 be5e14344c850f6c00f7d789fdce5e2b250b3109 language-codes-20190710-git language-codes.asd +lass http://beta.quicklisp.org/archive/lass/2019-07-10/lass-20190710-git.tgz 23036 f2d65dc5aaf652444a3bff08559ec46e e87598a425f5b0687dfb5ccb99c0d590500711cb lass-20190710-git binary-lass.asd lass.asd +lass-flexbox http://beta.quicklisp.org/archive/lass-flexbox/2016-02-08/lass-flexbox-20160208-git.tgz 3151 7307dc8d1b5133e50ebb930d6a754edc a45b8c9e8663e6d99d48dc86a6799c4e50d78466 lass-flexbox-20160208-git lass-flexbox-test.asd lass-flexbox.asd +lassie http://beta.quicklisp.org/archive/lassie/2014-07-13/lassie-20140713-git.tgz 11181 3cd995df3ef888663c6a2237567cac27 f7398a93be3c19ae0e84a9b22d06638f56e6cf95 lassie-20140713-git lassie.asd +lastfm http://beta.quicklisp.org/archive/lastfm/2019-10-07/lastfm-20191007-git.tgz 7538 dc29a7688ade882f2c65396d2086f9b9 9a4b61c1bed6af4fbacbf4ab77207409dbc349b5 lastfm-20191007-git lastfm.asd +latex-table http://beta.quicklisp.org/archive/latex-table/2018-03-28/latex-table-20180328-git.tgz 44576 9f102a30b9f31cda67570fdf37c11401 b7f7e7b83296ca127278daa932dd6b9377393e76 latex-table-20180328-git latex-table.asd +lazy http://beta.quicklisp.org/archive/lazy/2018-10-18/lazy-20181018-git.tgz 1596 7dd62fc17c12846379f7d7be8963bbd6 a991ff232722e78080fcbeab1d3722a2d281b47f lazy-20181018-git lazy.asd +legion http://beta.quicklisp.org/archive/legion/2017-11-30/legion-20171130-git.tgz 6236 5ce607b3df2c82c88ba87681bdeb9acd 36929bd08eaadcc5f2619758409e265e406d27c8 legion-20171130-git legion-test.asd legion.asd +legit http://beta.quicklisp.org/archive/legit/2019-07-10/legit-20190710-git.tgz 28792 9b380fc23d4bab086df8a0e4a598457a 3d87520bbf8d1e153bec0330725572c63b1645c0 legit-20190710-git legit.asd +let-over-lambda http://beta.quicklisp.org/archive/let-over-lambda/2015-09-23/let-over-lambda-20150923-git.tgz 9277 d1089d8f6a1b65629b4a5b560ec09814 83a37659648cfb353a46a01e1e65aaf4743e6639 let-over-lambda-20150923-git let-over-lambda-test.asd let-over-lambda.asd +let-plus http://beta.quicklisp.org/archive/let-plus/2019-11-30/let-plus-20191130-git.tgz 11247 1b8d1660ed67852ea31cad44a6fc15d0 e5ff604e4809908974fafaaf2af49e2cc0f8bcca let-plus-20191130-git let-plus.asd +letrec http://beta.quicklisp.org/archive/letrec/2019-03-07/letrec-20190307-hg.tgz 1899 68eed8ac600a1c2f157a3f6921efdfec ad8fb4a17a629ca025b5d6a8fda50ec84f5c8a8e letrec-20190307-hg letrec.asd +lev http://beta.quicklisp.org/archive/lev/2015-05-05/lev-20150505-git.tgz 9520 10f340f7500beb98b5c0d4a9876131fb e01073c528dbdfdaae90486095172dffc2c5c748 lev-20150505-git lev.asd +leveldb http://beta.quicklisp.org/archive/leveldb/2016-05-31/leveldb-20160531-git.tgz 6169 fa515cf6ba4109ee89db4c23039bff7b 0dc56929759d6562246601b782dc6fd6c1dbadb1 leveldb-20160531-git leveldb.asd +levenshtein http://beta.quicklisp.org/archive/levenshtein/2010-10-06/levenshtein-1.0.tgz 761 6266196d57f78c0dc894af44ecb9d223 bd6dc7c06dcde4ed721d0513cab44ffde6568bea levenshtein-1.0 levenshtein.asd +lfarm http://beta.quicklisp.org/archive/lfarm/2015-06-08/lfarm-20150608-git.tgz 41956 4cc91df44a932b3175a1eabf73d6e42d d0020b44060e11ef149b366645d915fb1cecff06 lfarm-20150608-git lfarm-admin.asd lfarm-client.asd lfarm-common.asd lfarm-gss.asd lfarm-launcher.asd lfarm-server.asd lfarm-ssl.asd lfarm-test.asd +lhstats http://beta.quicklisp.org/archive/lhstats/2012-01-07/lhstats-20120107-git.tgz 42573 828738a13c638d9d090439e57aaaf0ef 655b38385e0cb69d344e58c1dd7331a7f314a0af lhstats-20120107-git lhstats.asd +liblmdb http://beta.quicklisp.org/archive/liblmdb/2017-08-30/liblmdb-20170830-git.tgz 4501 32fbfb193f327493ade3440f5bf9e989 2a355ed6a5a753f2a59c6584979056b5e5dc9bde liblmdb-20170830-git liblmdb.asd +lichat-ldap http://beta.quicklisp.org/archive/lichat-ldap/2019-07-10/lichat-ldap-20190710-git.tgz 3001 6ab1394eaf6d55b04d40e5d229b30a51 811b669faaec5248b59e91f74d85f3aa21aab9b5 lichat-ldap-20190710-git lichat-ldap.asd +lichat-protocol http://beta.quicklisp.org/archive/lichat-protocol/2019-11-30/lichat-protocol-20191130-git.tgz 40126 8371f0b44edd51bd6c590c4d68373c88 d7da75c915cab1c5573ada70a630660dc4c03140 lichat-protocol-20191130-git lichat-protocol.asd +lichat-serverlib http://beta.quicklisp.org/archive/lichat-serverlib/2019-07-10/lichat-serverlib-20190710-git.tgz 15969 f6e93ed83b7b66732646b1178abf8978 7f27418370e6770c537b861586d2854db476b385 lichat-serverlib-20190710-git lichat-serverlib.asd +lichat-tcp-client http://beta.quicklisp.org/archive/lichat-tcp-client/2019-07-10/lichat-tcp-client-20190710-git.tgz 7146 9c22da901c9df97f415797ad79350683 e35ef93ecf768d30bdd13d64e74b2ee184f49056 lichat-tcp-client-20190710-git lichat-tcp-client.asd +lichat-tcp-server http://beta.quicklisp.org/archive/lichat-tcp-server/2019-07-10/lichat-tcp-server-20190710-git.tgz 7684 fa46f205b911e51931ac3573472f2a09 4f3498018d1a44b63c85d2b8144479114c65dce5 lichat-tcp-server-20190710-git lichat-tcp-server.asd +lichat-ws-server http://beta.quicklisp.org/archive/lichat-ws-server/2019-07-10/lichat-ws-server-20190710-git.tgz 7059 e8fa5d952a7ef7744d83875cd08ac8de 960dca9954534c9fc62384787cf4d2a02f4303e0 lichat-ws-server-20190710-git lichat-ws-server.asd +lift http://beta.quicklisp.org/archive/lift/2019-05-21/lift-20190521-git.tgz 1132278 c03d3fa715792440c7b51a852ad581e3 5bf930dadf4900ee6a03066f6d5f2a51c041c19f lift-20190521-git lift-documentation.asd lift-test.asd lift.asd +lila http://beta.quicklisp.org/archive/lila/2019-10-07/lila-20191007-git.tgz 18320 d6b601d97d413abf9f401d5e6c5a0b48 2a13279fa64442360d5b88c2a2bbfda2addb8b3f lila-20191007-git lila.asd +lime http://beta.quicklisp.org/archive/lime/2015-12-18/lime-20151218-git.tgz 14590 1c43d6c9dbd8db49e0e25234477775d1 c60882af85f65f2e0e6cd4bea80112d862848c94 lime-20151218-git lime-example.asd lime-test.asd lime.asd +linear-programming http://beta.quicklisp.org/archive/linear-programming/2019-11-30/linear-programming-20191130-git.tgz 25969 9348b8da3d2dbcbb51cf006525d41f0a c349e18b823684d354541e10df5e7b816f9a5712 linear-programming-20191130-git linear-programming-test.asd linear-programming.asd +linedit http://beta.quicklisp.org/archive/linedit/2018-04-30/linedit-20180430-git.tgz 21140 a9f679411d01ec162eb1ba7c76e25d7a 82f1fab330a425fe3406a8a8a707575590cecf9f linedit-20180430-git linedit.asd +linewise-template http://beta.quicklisp.org/archive/linewise-template/2016-02-08/linewise-template-20160208-git.tgz 14893 396034dd6aab87bfe5db95b0064187b2 1cbddfa14e8620ad6eb87b8041bd5d3bf44abd4d linewise-template-20160208-git linewise-template.asd +lionchat http://beta.quicklisp.org/archive/lionchat/2019-07-10/lionchat-20190710-git.tgz 313345 9cbf24d2fb7f54960d1daa58cd853468 c947b14bf01e7b48cb1d99cecb404b40daaa535e lionchat-20190710-git lionchat.asd +lisa http://beta.quicklisp.org/archive/lisa/2012-04-07/lisa-20120407-git.tgz 165079 6d999f92e2d894a7c4785b044955a49f b8b3350d837c7ea807163213dece93d59db0c725 lisa-20120407-git lisa.asd +lisp-binary http://beta.quicklisp.org/archive/lisp-binary/2019-12-27/lisp-binary-20191227-git.tgz 928451 0e8dab0533d47746b56a16927e75238f ba1a40dff70a00e6cc07a045cb2315c3351047f7 lisp-binary-20191227-git lisp-binary.asd test/lisp-binary-test.asd +lisp-chat http://beta.quicklisp.org/archive/lisp-chat/2019-05-21/lisp-chat-20190521-git.tgz 99269 2e3e425dab2610b63038e6fcced3eed4 212518260f0a1bb4a33332bc867bf625dfec8dc3 lisp-chat-20190521-git lisp-chat.asd +lisp-critic http://beta.quicklisp.org/archive/lisp-critic/2019-05-21/lisp-critic-20190521-git.tgz 20286 998d8aee18cc0265ea7e8b5ca480fd40 aaaa72cc78f46fe5652e318ce1f38dd4c26547f2 lisp-critic-20190521-git ckr-tables.asd lisp-critic.asd +lisp-executable http://beta.quicklisp.org/archive/lisp-executable/2018-08-31/lisp-executable-20180831-git.tgz 23139 63ea5e1673e9b2d90df1a2bbe10fd7b5 ec9d633c4ac367fa2f756e9960a83eb3805d3f71 lisp-executable-20180831-git lisp-executable-example.asd lisp-executable-tests.asd lisp-executable.asd +lisp-gflags http://beta.quicklisp.org/archive/lisp-gflags/2015-10-31/lisp-gflags-20151031-git.tgz 8022 2e96622a1f5e11acf9871c6171bad635 ff6654e50a07142e916d6eaebf9b09b199f4dc52 lisp-gflags-20151031-git com.google.flag-test.asd com.google.flag.asd +lisp-interface-library http://beta.quicklisp.org/archive/lisp-interface-library/2018-04-30/lisp-interface-library-20180430-git.tgz 60414 1d71936f692f30bb000ffbbb69b098e7 e695c2d9e57f1770e5cb6acceb5da9505d29e90a lisp-interface-library-20180430-git lil.asd lisp-interface-library.asd +lisp-invocation http://beta.quicklisp.org/archive/lisp-invocation/2018-02-28/lisp-invocation-20180228-git.tgz 10863 3ed327ad1fc47f27cc1332d9a8b7e20e 49234e20c19ecb65fa0d743684c92965e8978160 lisp-invocation-20180228-git lisp-invocation.asd +lisp-namespace http://beta.quicklisp.org/archive/lisp-namespace/2017-11-30/lisp-namespace-20171130-git.tgz 9762 d3052a13db167c6a53487f31753b7467 e84b47c0b146849eeb5f624cc2c491e36f62be8a lisp-namespace-20171130-git lisp-namespace.asd lisp-namespace.test.asd +lisp-unit http://beta.quicklisp.org/archive/lisp-unit/2017-01-24/lisp-unit-20170124-git.tgz 18163 2c55342cb8af18b290bb6a28c75deac5 234203b4f9903cd82b1698f3a90439fb2bbc3f7e lisp-unit-20170124-git lisp-unit.asd +lisp-unit2 http://beta.quicklisp.org/archive/lisp-unit2/2018-01-31/lisp-unit2-20180131-git.tgz 34698 d061fa640837441a5d2eecbefd8b2e69 dd120bb9dd809fbd3bd0b8ef579e5328719be3d2 lisp-unit2-20180131-git lisp-unit2.asd +lisp-zmq http://beta.quicklisp.org/archive/lisp-zmq/2016-02-08/lisp-zmq-20160208-git.tgz 15281 b1aa6a105b82083f62bc8e149fe840d0 985b9003de4ea3c8d4b26a85d27d31a08cc23785 lisp-zmq-20160208-git zmq-examples.asd zmq-test.asd zmq.asd +lispbuilder http://beta.quicklisp.org/archive/lispbuilder/2019-05-21/lispbuilder-20190521-git.tgz 7509055 7fd1bd4e45d0e35c4ac33c677072cf2a b97ce2b733d247ef2d3cbd718e2b193c1832c6e4 lispbuilder-20190521-git lispbuilder-lexer/lispbuilder-lexer.asd lispbuilder-net/lispbuilder-net-cffi.asd lispbuilder-net/lispbuilder-net.asd lispbuilder-opengl/lispbuilder-opengl-1-1.asd lispbuilder-opengl/lispbuilder-opengl-examples.asd lispbuilder-regex/lispbuilder-regex.asd lispbuilder-sdl-gfx/lispbuilder-sdl-gfx-binaries.asd lispbuilder-sdl-gfx/lispbuilder-sdl-gfx-cffi.asd lispbuilder-sdl-gfx/lispbuilder-sdl-gfx-examples.asd lispbuilder-sdl-gfx/lispbuilder-sdl-gfx.asd lispbuilder-sdl-image/lispbuilder-sdl-image-binaries.asd lispbuilder-sdl-image/lispbuilder-sdl-image-cffi.asd lispbuilder-sdl-image/lispbuilder-sdl-image-examples.asd lispbuilder-sdl-image/lispbuilder-sdl-image.asd lispbuilder-sdl-mixer/lispbuilder-sdl-mixer-binaries.asd lispbuilder-sdl-mixer/lispbuilder-sdl-mixer-cffi.asd lispbuilder-sdl-mixer/lispbuilder-sdl-mixer-examples.asd lispbuilder-sdl-mixer/lispbuilder-sdl-mixer.asd lispbuilder-sdl-ttf/lispbuilder-sdl-ttf-binaries.asd lispbuilder-sdl-ttf/lispbuilder-sdl-ttf-cffi.asd lispbuilder-sdl-ttf/lispbuilder-sdl-ttf-examples.asd lispbuilder-sdl-ttf/lispbuilder-sdl-ttf.asd lispbuilder-sdl/cocoahelper.asd lispbuilder-sdl/lispbuilder-sdl-assets.asd lispbuilder-sdl/lispbuilder-sdl-base.asd lispbuilder-sdl/lispbuilder-sdl-binaries.asd lispbuilder-sdl/lispbuilder-sdl-cffi.asd lispbuilder-sdl/lispbuilder-sdl-cl-vectors-examples.asd lispbuilder-sdl/lispbuilder-sdl-cl-vectors.asd lispbuilder-sdl/lispbuilder-sdl-examples.asd lispbuilder-sdl/lispbuilder-sdl-vecto-examples.asd lispbuilder-sdl/lispbuilder-sdl-vecto.asd lispbuilder-sdl/lispbuilder-sdl.asd lispbuilder-windows/lispbuilder-windows.asd lispbuilder-yacc/lispbuilder-yacc.asd +lispqr http://beta.quicklisp.org/archive/lispqr/2019-12-27/lispqr-20191227-git.tgz 24946 1fb86ba44a041d1b4f22b2f61299c66b ff88cd4d8665c966f478f73b20f664bc1e9310d9 lispqr-20191227-git lispqr.asd +listoflist http://beta.quicklisp.org/archive/listoflist/2014-08-26/listoflist-20140826-git.tgz 12188 598138f6ddf5241eaa283d0adce7878d c4138b36e50717f3e826fbc0d77cd9c00d0c9612 listoflist-20140826-git listoflist.asd +listopia http://beta.quicklisp.org/archive/listopia/2019-07-10/listopia-20190710-git.tgz 10846 54bbe555ec64ec4c63a8ea83738dde17 ccfa999552b2d86a7786825faae0d61c79d98a65 listopia-20190710-git listopia-bench.asd listopia-test.asd listopia.asd +literate-lisp http://beta.quicklisp.org/archive/literate-lisp/2019-12-27/literate-lisp-20191227-git.tgz 145340 5134652204467310acf6379e3b095730 84c8de8f253af7ee2cd24c3e81bffb8d65ca2114 literate-lisp-20191227-git literate-demo.asd literate-lisp.asd +livesupport http://beta.quicklisp.org/archive/livesupport/2019-05-21/livesupport-release-quicklisp-71e6e412-git.tgz 2939 9eb376b26689ac54d2a51f5189587ec5 e2df3d1a994fad4f8149c2795dc5d7de5a10d5ce livesupport-release-quicklisp-71e6e412-git livesupport.asd +lla http://beta.quicklisp.org/archive/lla/2018-03-28/lla-20180328-git.tgz 38969 61d583603d5cacf9d81486a0cfcfaf6a 5c747b960f4ed782de3a11505eb02fef3b7b5d0a lla-20180328-git lla.asd +lmdb http://beta.quicklisp.org/archive/lmdb/2017-04-03/lmdb-20170403-git.tgz 7367 65a7e5f3ddfc9bd1d322ac9e6bf08f09 5178d796ab2eec1c1404e6505f97453c09e95dc7 lmdb-20170403-git lmdb-test.asd lmdb.asd +lml http://beta.quicklisp.org/archive/lml/2015-09-23/lml-20150923-git.tgz 16279 4250f2b2c4d110cc728645e8a1eba963 5e9d7018b7487783aeec69ff4ac283a56bccd1ef lml-20150923-git lml-tests.asd lml.asd +lml2 http://beta.quicklisp.org/archive/lml2/2015-09-23/lml2-20150923-git.tgz 31590 99d76c1971e4fceaa6496291c4ede90b b119542c292e0ff8ed86874cbe6ee64a6c16a9a0 lml2-20150923-git lml2-tests.asd lml2.asd +local-package-aliases http://beta.quicklisp.org/archive/local-package-aliases/2013-03-12/local-package-aliases-20130312-git.tgz 8525 a949c3a09612e3913c798bd4cc67eadf 002c40de319cb0d4cfe4071aa5375a2f5434895f local-package-aliases-20130312-git local-package-aliases.asd +local-time http://beta.quicklisp.org/archive/local-time/2019-07-10/local-time-20190710-git.tgz 282522 ff315f40d1f955210c78aa0804a117f2 77d2629935ebb6b66cebcd121f0b14ee3449b698 local-time-20190710-git cl-postgres+local-time.asd local-time.asd +local-time-duration http://beta.quicklisp.org/archive/local-time-duration/2018-04-30/local-time-duration-20180430-git.tgz 10333 8ad2f86ea33d4c7b3014e2152632b88c 0b443efd31c990ad022e9c16576bf68b2359de0b local-time-duration-20180430-git cl-postgres+local-time-duration.asd local-time-duration.asd +log4cl http://beta.quicklisp.org/archive/log4cl/2019-10-07/log4cl-20191007-git.tgz 917204 11cdcd9da0ede86092886a055b186861 06118f3a37d1038fe1188c621dca7b62886733d3 log4cl-20191007-git log4cl-examples.asd log4cl.asd log4slime.asd +log5 http://beta.quicklisp.org/archive/log5/2011-06-19/log5-20110619-git.tgz 29106 b05a585fbf58b25367c05ec8bb814e8c 07d72b5327c5e8795eac99d235cc1a483a4cbafd log5-20110619-git log5.asd +lorem-ipsum http://beta.quicklisp.org/archive/lorem-ipsum/2018-10-18/lorem-ipsum-20181018-git.tgz 3756 4a89cae2f82951c8cf76348b5f0600ee 6216e403bb0c4da378eb6b16e094926355c13549 lorem-ipsum-20181018-git lorem-ipsum.asd +lowlight http://beta.quicklisp.org/archive/lowlight/2013-12-11/lowlight-20131211-git.tgz 17517 83b71610e5b7de0979ffc9dcff43e129 d90ad3e313ce9d51984519b5512fd892ab513f77 lowlight-20131211-git doc/lowlight.doc.asd lowlight.asd old/lowlight.old.asd tests/lowlight.tests.asd +lparallel http://beta.quicklisp.org/archive/lparallel/2016-08-25/lparallel-20160825-git.tgz 78551 6393e8d0c0cc9ed1c88b6e7cca8de5df 1514c95041efd503f335e2cd96ba5ef1537415cc lparallel-20160825-git lparallel-bench.asd lparallel-test.asd lparallel.asd +lquery http://beta.quicklisp.org/archive/lquery/2019-07-10/lquery-20190710-git.tgz 38615 987e9e505ff230c7bfc425bdf58fb717 e5fa7b08ffc8725db9180f41d1346312927f3bf6 lquery-20190710-git lquery-test.asd lquery.asd +lredis http://beta.quicklisp.org/archive/lredis/2014-11-06/lredis-20141106-git.tgz 8338 c3696a2d2665fd8c31002c3e9e22f6b6 49824a4b3d2730746a19c94536f68971cbb48ea1 lredis-20141106-git lredis.asd +lsx http://beta.quicklisp.org/archive/lsx/2019-10-07/lsx-20191007-git.tgz 6813 6eabb871226e5211632451e4286fdb0c b2d38cfc9642a0136dcb297545e66e6419f3db0b lsx-20191007-git cl-syntax-lsx.asd lsx.asd +ltk http://beta.quicklisp.org/archive/ltk/2019-02-02/ltk-20190202-git.tgz 62309 2560e392031180561698b49386b10c45 7d54dc61d474e2133bfbb0a0aa95484e48b0c4eb ltk-20190202-git ltk/ltk-mw.asd ltk/ltk-remote.asd ltk/ltk.asd +lucerne http://beta.quicklisp.org/archive/lucerne/2019-08-13/lucerne-20190813-git.tgz 155497 2355e311b1adeb91e9cb4582c236bc09 e785246a23c25a148e249cb43a97ba88558f967c lucerne-20190813-git lucerne-auth.asd lucerne-hello-world.asd lucerne-test.asd lucerne-utweet.asd lucerne.asd +lw-compat http://beta.quicklisp.org/archive/lw-compat/2016-03-18/lw-compat-20160318-git.tgz 2165 024b8e63d13fb12dbcccaf18cf4f8dfa 92259792af7830d80a868c5f06b2510ead325110 lw-compat-20160318-git lw-compat.asd +lyrics http://beta.quicklisp.org/archive/lyrics/2019-11-30/lyrics-20191130-git.tgz 4427 a0cd616233120323860aa65d112ba07c 8790d576f491d665894861e61394e5f8136a450d lyrics-20191130-git lyrics.asd +m2cl http://beta.quicklisp.org/archive/m2cl/2013-01-28/m2cl-20130128-git.tgz 47489 4d26b8e7cd1108db4c46070c2211c796 f69330a9442ec7192a433b51921d2a2c650291f8 m2cl-20130128-git m2cl-examples.asd m2cl-test.asd m2cl.asd +macro-html http://beta.quicklisp.org/archive/macro-html/2015-12-18/macro-html-20151218-git.tgz 18865 4c73847f830a8ccacd87e5ea76d44bb3 3b03c5253738adea7d0f7b8a67617356a293c7cc macro-html-20151218-git macro-html.asd +macro-level http://beta.quicklisp.org/archive/macro-level/2012-10-13/macro-level-1.0.1.tgz 1907 486ad598536a7b719f04c0f756d9017f 355a1254441193c1698f2641e84f3dfc356f8591 macro-level-1.0.1 macro-level.asd +macrodynamics http://beta.quicklisp.org/archive/macrodynamics/2018-02-28/macrodynamics-20180228-git.tgz 7668 8f226b02f6442d439edc80da09bd8a72 dcffeeebbb8b5084fd1517cab04abb515fb9a4a6 macrodynamics-20180228-git macrodynamics.asd +macroexpand-dammit http://beta.quicklisp.org/archive/macroexpand-dammit/2013-11-11/macroexpand-dammit-20131111-http.tgz 3604 6290fa304f986ea05e084c6342dd0c0f e0b77f879b8fd5a85120cae0b2a90ae17c93fc9d macroexpand-dammit-20131111-http macroexpand-dammit.asd +madeira-port http://beta.quicklisp.org/archive/madeira-port/2015-07-09/madeira-port-20150709-git.tgz 4844 f3d5a6aea61ecb83c56fb123d6a1ecf8 841f3bac6df3588220adc49c5caccaf495800c03 madeira-port-20150709-git madeira-port.asd +magicl http://beta.quicklisp.org/archive/magicl/2019-11-30/magicl-v0.6.5.tgz 510348 a7ffdb8d8e0911565de5c01cf0a6dc92 9b4acfd93471e917c26eef4e7bb1104fdd08acd4 magicl-v0.6.5 magicl-examples.asd magicl-gen.asd magicl-tests.asd magicl-transcendental.asd magicl.asd +maiden http://beta.quicklisp.org/archive/maiden/2019-12-27/maiden-20191227-git.tgz 234821 a24c727285b2693e197ce86231e9c5ab 538c7fadb21f7d8996b331882fc1a1a002f1e02f maiden-20191227-git agents/accounts/maiden-accounts.asd agents/activatable/maiden-activatable.asd agents/blocker/maiden-blocker.asd agents/chatlog/maiden-chatlog.asd agents/commands/maiden-commands.asd agents/core-manager/maiden-core-manager.asd agents/counter/maiden-counter.asd agents/crimes/maiden-crimes.asd agents/dictionary/maiden-dictionary.asd agents/emoticon/maiden-emoticon.asd agents/help/maiden-help.asd agents/lastfm/maiden-lastfm.asd agents/location/maiden-location.asd agents/lookup/maiden-lookup.asd agents/markov/maiden-markov.asd agents/medals/maiden-medals.asd agents/notify/maiden-notify.asd agents/permissions/maiden-permissions.asd agents/silly/maiden-silly.asd agents/talk/maiden-talk.asd agents/throttle/maiden-throttle.asd agents/time/maiden-time.asd agents/trivia/maiden-trivia.asd agents/urlinfo/maiden-urlinfo.asd agents/vote/maiden-vote.asd agents/weather/maiden-weather.asd clients/irc/maiden-irc.asd clients/lichat/maiden-lichat.asd clients/relay/maiden-relay.asd clients/twitter/maiden-twitter.asd maiden.asd modules/api-access/maiden-api-access.asd modules/client-entities/maiden-client-entities.asd modules/networking/maiden-networking.asd modules/serialize/maiden-serialize.asd modules/storage/maiden-storage.asd +mailbox http://beta.quicklisp.org/archive/mailbox/2013-10-03/mailbox-20131003-git.tgz 1907 fd52c2dc8d80c87013a6418b04c4c737 ee9f30c005b768a945c98fc466ec276a662b2b0b mailbox-20131003-git mailbox.asd +make-hash http://beta.quicklisp.org/archive/make-hash/2013-06-15/make-hash-20130615-git.tgz 361160 4f612ef068411284c88e0381fa4a0c7f a0f2260867e32967ef02f316b8d42d9d168c140f make-hash-20130615-git make-hash-tests.asd make-hash.asd +manifest http://beta.quicklisp.org/archive/manifest/2012-02-08/manifest-20120208-git.tgz 98532 16b500a79f0cd4a8f95760cb634cd617 13441aaf0b11a1275a8f72d0ec31908f60307556 manifest-20120208-git manifest.asd +map-bind http://beta.quicklisp.org/archive/map-bind/2012-08-11/map-bind-20120811-git.tgz 2092 a24c5c012e41b87f836b6d8ef318e7cd 047b3ccf3f9d433eb2104bd9da89de7f8e81a2a4 map-bind-20120811-git map-bind.asd +map-set http://beta.quicklisp.org/archive/map-set/2019-03-07/map-set-20190307-hg.tgz 2389 866dba36cdf060c943267cb79ccc0532 9b7c74de8b801583539807e28c676c5ed630bec3 map-set-20190307-hg map-set.asd +marching-cubes http://beta.quicklisp.org/archive/marching-cubes/2015-07-09/marching-cubes-20150709-git.tgz 97306 a44282b741e9dc43d40cb1979a6c7afe b8002c6a01dc8579d3f109c6ecd36dce88e9075f marching-cubes-20150709-git marching-cubes-example.asd marching-cubes-test.asd marching-cubes.asd +markdown.cl http://beta.quicklisp.org/archive/markdown.cl/2019-05-21/markdown.cl-20190521-git.tgz 21656 7de74021c21229dc5e8c94ff2d935b39 72d7124ff85b0ffcca09242f30dcb5837724ac0f markdown.cl-20190521-git markdown.cl-test.asd markdown.cl.asd +markup http://beta.quicklisp.org/archive/markup/2019-11-30/markup-20191130-git.tgz 12091 25727e4bc516291ea9265ef53c0a2629 53e8cbd2bf32b50b464ab9e84f784f0fa7679b60 markup-20191130-git markup.asd markup.test.asd +marshal http://beta.quicklisp.org/archive/marshal/2013-07-20/marshal-20130720-git.tgz 2921 7b2f8d0cb6c95f2418eca133a2e299b6 2c3d9e2c3b04cb581eb8f1f0dc94055176328029 marshal-20130720-git fmarshal-test.asd fmarshal.asd +mathkit http://beta.quicklisp.org/archive/mathkit/2016-02-08/mathkit-20160208-git.tgz 5451 f00124bdf2eea4d18154a4497bf414f7 f5323f595ca08be75b394d1baa82380982dd2f4e mathkit-20160208-git mathkit.asd +maxpc http://beta.quicklisp.org/archive/maxpc/2017-11-30/maxpc-20171130-git.tgz 26151 db7288e066a31f7080e1c7a71531a4d3 5d5aff90fe687119100e149abd22d4c8b19b6d56 maxpc-20171130-git maxpc-test.asd maxpc.asd +mcclim http://beta.quicklisp.org/archive/mcclim/2019-12-27/mcclim-20191227-git.tgz 2331764 7ebf5e9590689c238446b908fd78af49 5c3ea30aa513d6a22548ab0b00ca33d80f992e44 mcclim-20191227-git Apps/Clouseau/clouseau.asd Apps/Debugger/clim-debugger.asd Apps/Functional-Geometry/functional-geometry.asd Apps/Listener/clim-listener.asd Apps/Scigraph/scigraph.asd Backends/CLX-fb/mcclim-clx-fb.asd Backends/CLX/mcclim-clx.asd Backends/Null/mcclim-null.asd Backends/PDF/clim-pdf.asd Backends/PostScript/clim-postscript-font.asd Backends/PostScript/clim-postscript.asd Backends/RasterImage/mcclim-raster-image.asd Backends/common/mcclim-backend-common.asd Core/clim-basic/clim-basic.asd Core/clim-core/clim-core.asd Core/clim/clim.asd Examples/clim-examples.asd Experimental/tree-with-cross-edges/mcclim-tree-with-cross-edges.asd Extensions/Franz/mcclim-franz.asd Extensions/bezier/mcclim-bezier.asd Extensions/bitmap-formats/mcclim-bitmaps.asd Extensions/conditional-commands/conditional-commands.asd Extensions/fonts/mcclim-fonts.asd Extensions/image/mcclim-image.asd Extensions/layouts/mcclim-layouts.asd Extensions/render/mcclim-render.asd Libraries/Drei/Persistent/persistent.asd Libraries/Drei/cl-automaton/automaton.asd Libraries/Drei/drei-mcclim.asd Libraries/ESA/esa-mcclim.asd Libraries/Slim/slim.asd clim-lisp.asd mcclim.asd +md5 http://beta.quicklisp.org/archive/md5/2018-02-28/md5-20180228-git.tgz 15847 7f250f8a2487e4e0aac1ed9c50b79b4d 6539b395ec2b9513464f03e66f396a4c9c8b6da2 md5-20180228-git md5.asd +media-types http://beta.quicklisp.org/archive/media-types/2018-07-11/media-types-20180711-git.tgz 20767 ed16ed33fc38f0279e943d547377f3d6 e1b2d2564e260e9c78ce4eef58006a95a612259f media-types-20180711-git media-types.asd +mel-base http://beta.quicklisp.org/archive/mel-base/2018-02-28/mel-base-20180228-git.tgz 67969 17931e0cbfec8fafb7b825a0af0c897d 447445ec593bc3191d06233e505c9a55247f8be0 mel-base-20180228-git mel-base.asd +memoize http://beta.quicklisp.org/archive/memoize/2014-08-26/memoize-20140826-http.tgz 3547 bdf9cf51fb95293e42553045b7faea2f 1c29c09b7f60686ac929688b842db4c6bcb8f021 memoize-20140826-http memoize.asd +message-oo http://beta.quicklisp.org/archive/message-oo/2013-06-15/message-oo-20130615-git.tgz 2426 44631ce806432e2a55fdfdca7de414ac 95d35b35cfb93d1a19760a6291e5f756e05be25e message-oo-20130615-git message-oo.asd +meta http://beta.quicklisp.org/archive/meta/2015-06-08/meta-20150608-git.tgz 3371 3322d6d54783269122e087b1349e3171 1dfa5cc33d7d1840bfc0d5626758e3bce3e57914 meta-20150608-git meta.asd +meta-sexp http://beta.quicklisp.org/archive/meta-sexp/2010-10-06/meta-sexp-0.1.6.tgz 155693 1d8b6e9b6431340af88269fbd6bdaab3 c427e3744000b6b3275ce3c061e3b23241ba8d3b meta-sexp-0.1.6 meta-sexp.asd +metabang-bind http://beta.quicklisp.org/archive/metabang-bind/2019-11-30/metabang-bind-20191130-git.tgz 22549 b0845abb1eadb83e33e91c8d4ad88d2f 7e1cc7f04728acd7d6e9d322d5665bd9f2533171 metabang-bind-20191130-git metabang-bind-test.asd metabang-bind.asd +metacopy http://beta.quicklisp.org/archive/metacopy/2017-04-03/metacopy-20170403-darcs.tgz 9186 caa5ac0a1f5e3741e7f789589ff537fe 559f0201e9fe8708b9211ef856ed35eefd0167f9 metacopy-20170403-darcs metacopy-with-contextl.asd metacopy.asd +metap http://beta.quicklisp.org/archive/metap/2015-05-05/metap-20150505-git.tgz 3176 1de5d80b35b75fa3c8f668adb2fb891e bc6cb669fe93462ad434fd620eeeac1b17b59aa5 metap-20150505-git metap-test.asd metap.asd +metatilities http://beta.quicklisp.org/archive/metatilities/2018-02-28/metatilities-20180228-git.tgz 194405 bb75a7979528d08ec9c27ee154b9317e 531048725a416caea22d5996edd570f7cd25947a metatilities-20180228-git metatilities-test.asd metatilities.asd +metatilities-base http://beta.quicklisp.org/archive/metatilities-base/2019-12-27/metatilities-base-20191227-git.tgz 70648 7968829ca353c4a42784a151317029f1 e2abddb20c1a29455fc761c4c7716d9fdbebf0e9 metatilities-base-20191227-git metatilities-base-test.asd metatilities-base.asd +metering http://beta.quicklisp.org/archive/metering/2016-12-08/metering-20161208-git.tgz 17248 45dea763d90e5c9ddbdc31a8ccc5b6d7 e916a69c0148ea0ac6cbbab30f1e737b12b067cd metering-20161208-git metering.asd +method-combination-utilities http://beta.quicklisp.org/archive/method-combination-utilities/2014-11-06/method-combination-utilities-20141106-git.tgz 7311 881048d7bed117b8d7b4547a5111812d cb5a6ab010f6981e27c83f2ba22d33649a4db46a method-combination-utilities-20141106-git method-combination-utilities.asd +method-hooks http://beta.quicklisp.org/archive/method-hooks/2019-12-27/method-hooks-20191227-git.tgz 14332 f12af466f0dce69c3c50c8f5bd1ce61f 66ced022506a2eefbd65286cf7dd2af235bca45b method-hooks-20191227-git method-hooks-test.asd method-hooks.asd +method-versions http://beta.quicklisp.org/archive/method-versions/2011-05-22/method-versions_0.1.2011.05.18.tgz 4709 3e64215eeae18b8c830653e4ca22fe26 96476b31ff0c747c58477b2dc6227e1bfff611c8 method-versions_0.1.2011.05.18 method-versions.asd +mexpr http://beta.quicklisp.org/archive/mexpr/2015-07-09/mexpr-20150709-git.tgz 5385 7660c46156c0f98adc208451f64ff62f 9f9be5508184cc8dd23ed2e04812e1b71fdd1b5e mexpr-20150709-git mexpr-tests.asd mexpr.asd +mgl-pax http://beta.quicklisp.org/archive/mgl-pax/2018-01-31/mgl-pax-20180131-git.tgz 175872 05d6a95c330a661d0fe4ea8861dc86ea 07608475421ae501bf2a4857d31ac4b70a079233 mgl-pax-20180131-git mgl-pax-test.asd mgl-pax.asd +micmac http://beta.quicklisp.org/archive/micmac/2015-06-08/micmac-20150608-git.tgz 24509 fbe086e1ee3b4f4cb65a34872b6942b0 1dd7fb7a9c35a0f00f3a988ab35022a2db568c09 micmac-20150608-git micmac-test.asd micmac.asd +midi http://beta.quicklisp.org/archive/midi/2010-10-06/midi-20070618.tgz 6886 78d494c8d2fbc9a6af1b2d3e1b3c25d7 73a273cd33bccfa2bcd8ff93b38de5b1523e9993 midi-20070618 midi.asd +minheap http://beta.quicklisp.org/archive/minheap/2016-06-28/minheap-20160628-git.tgz 17015 27a57cdd27e91eb767f1377fcbfe2af3 0fe362afcf54c58c43ac9c36d8384d0be4782e02 minheap-20160628-git minheap-tests.asd minheap.asd +mini-cas http://beta.quicklisp.org/archive/mini-cas/2015-09-23/mini-cas-20150923-git.tgz 7018 5b29524320ea446c59ee913d6787faf0 7361170e6ebafe271aaf8b32962214bb2e860b5f mini-cas-20150923-git mini-cas.asd +misc-extensions http://beta.quicklisp.org/archive/misc-extensions/2015-06-08/misc-extensions-20150608-git.tgz 25456 ef8a05dd4382bb9d1e3960aeb77e332e 3f22977672a040f72b46d49fa680757deeff6a12 misc-extensions-20150608-git misc-extensions.asd +mito http://beta.quicklisp.org/archive/mito/2019-10-07/mito-20191007-git.tgz 38773 970032b767f3181967c179c7bc9bd0d3 07a8b4a3f24744dddeab1f7a6da068879c21998a mito-20191007-git lack-middleware-mito.asd mito-core.asd mito-migration.asd mito-test.asd mito.asd +mito-attachment http://beta.quicklisp.org/archive/mito-attachment/2019-05-21/mito-attachment-20190521-git.tgz 5159 00ff19e5e15a7bf9b2f159102d7b9f59 9e9d3a40b0ccc1b701ca9c76b1225a3bf909923e mito-attachment-20190521-git mito-attachment.asd +mito-auth http://beta.quicklisp.org/archive/mito-auth/2017-10-19/mito-auth-20171019-git.tgz 2014 f2ef144e4012a1ecac9420a64ac6ab16 f5c7ed9c9a43f739d1afddfb3616322b58b33746 mito-auth-20171019-git mito-auth.asd +mixalot http://beta.quicklisp.org/archive/mixalot/2015-12-18/mixalot-20151218-git.tgz 49886 c2132e94690a03a39343fff3a12cff1f 22856864b7a35fb44f52547cc6387e31f4db42e1 mixalot-20151218-git flac.asd mixalot-flac.asd mixalot-mp3.asd mixalot-vorbis.asd mixalot.asd mpg123-ffi.asd vorbisfile-ffi.asd +mk-string-metrics http://beta.quicklisp.org/archive/mk-string-metrics/2018-01-31/mk-string-metrics-20180131-git.tgz 5395 40f23794a7d841cb178f5951d3992886 e869de7baf6a85580ae92dd30e2ddffd9ce35400 mk-string-metrics-20180131-git mk-string-metrics-tests.asd mk-string-metrics.asd +mmap http://beta.quicklisp.org/archive/mmap/2019-11-30/mmap-20191130-git.tgz 13222 c465c1ec1dbbb17a227bc3c17d40bed4 983e80b42600cf539f8298716bfa9a0259ec309b mmap-20191130-git mmap-test.asd mmap.asd +mockingbird http://beta.quicklisp.org/archive/mockingbird/2017-11-30/mockingbird-20171130-git.tgz 8277 b5a2f5d401ba6ca7e2fab668bfa22cad 90ce36a82f42bf47eb9c87fd8f4694e4753673f5 mockingbird-20171130-git mockingbird-test.asd mockingbird.asd +modest-config http://beta.quicklisp.org/archive/modest-config/2018-02-28/modest-config-20180228-git.tgz 4144 25b0ea7d813ee8b806fd8ac434252ffd b899245e88298eb9bc042cd07237a6f1e6925af0 modest-config-20180228-git modest-config-test.asd modest-config.asd +modf http://beta.quicklisp.org/archive/modf/2019-05-21/modf-20190521-git.tgz 14168 42d31418ef8529e5e6be5c73c06eecb2 0e97b61de29d7ddd6d57d42627a385222e6fdc11 modf-20190521-git modf-test.asd modf.asd +modf-fset http://beta.quicklisp.org/archive/modf-fset/2015-06-08/modf-fset-20150608-git.tgz 2115 aec2b57d064522f5065597cd6619f851 0fb42b40b822fc95b98dacf7dcc86a0781f581cd modf-fset-20150608-git modf-fset-test.asd modf-fset.asd +modularize http://beta.quicklisp.org/archive/modularize/2019-07-10/modularize-20190710-git.tgz 10984 8a161c237e330eacdaae78a61b98bbdc 24d32656523252a1d0c367ba581ca98063b9ed50 modularize-20190710-git modularize-test-module.asd modularize.asd +modularize-hooks http://beta.quicklisp.org/archive/modularize-hooks/2019-07-10/modularize-hooks-20190710-git.tgz 6119 86d8ed59bb2e6231b3c651372920128a 164b8063183939b2b42aa744e4280bca1a626f35 modularize-hooks-20190710-git modularize-hooks.asd +modularize-interfaces http://beta.quicklisp.org/archive/modularize-interfaces/2019-07-10/modularize-interfaces-20190710-git.tgz 11193 c9730aafa93b237ffe0a5415a45e4c73 e37e1f7754385f011a46a0b0f7112f8ac3c10dc4 modularize-interfaces-20190710-git interfaces-test-implementation.asd modularize-interfaces.asd +moira http://beta.quicklisp.org/archive/moira/2017-11-30/moira-20171130-git.tgz 2823 a1cfcd5ab13cc5dda524d0f5e26e90ce 6e26e71c89b4ecdef7218d572ebcf342a26052bb moira-20171130-git moira.asd +monkeylib-binary-data http://beta.quicklisp.org/archive/monkeylib-binary-data/2011-12-03/monkeylib-binary-data-20111203-git.tgz 4927 ef6b8e9c30e6b8efa915ca35ed962cf3 77232f96c8600789af74f006a7af9eb1fc6e698d monkeylib-binary-data-20111203-git com.gigamonkeys.binary-data.asd +monkeylib-html http://beta.quicklisp.org/archive/monkeylib-html/2018-02-28/monkeylib-html-20180228-git.tgz 7951 2b2b680f1eb02d4392135cebc33825fe 464b87c31dcfde60e5e350c7f2b5bab63bd3eb32 monkeylib-html-20180228-git monkeylib-html.asd +monkeylib-json http://beta.quicklisp.org/archive/monkeylib-json/2018-02-28/monkeylib-json-20180228-git.tgz 4329 253e4e5aa8fd634fc76c97e8b9be0862 56e485b956487256210d5eb76a3031f95d54335d monkeylib-json-20180228-git com.gigamonkeys.json.asd +monkeylib-macro-utilities http://beta.quicklisp.org/archive/monkeylib-macro-utilities/2011-12-03/monkeylib-macro-utilities-20111203-git.tgz 1968 b03c3644ff328ded7e7e0a39741a69ba 4bc771174bdb9bb52952356408d7a617e6b4ce2c monkeylib-macro-utilities-20111203-git com.gigamonkeys.macro-utilities.asd +monkeylib-markup http://beta.quicklisp.org/archive/monkeylib-markup/2012-09-09/monkeylib-markup-20120909-git.tgz 51056 e2f052930d4ed6cbd97b802b20a83646 fcf29d2e6a193626a8c5eb3d2498caf192735479 monkeylib-markup-20120909-git com.gigamonkeys.markup.asd +monkeylib-markup-html http://beta.quicklisp.org/archive/monkeylib-markup-html/2012-02-08/monkeylib-markup-html-20120208-git.tgz 4582 f70d4f0c511f36d6fc4a10a6912b51e0 d1fb1db716fdb7fe0fa845e223d0da5e76629b69 monkeylib-markup-html-20120208-git monkeylib-markup-html.asd +monkeylib-parser http://beta.quicklisp.org/archive/monkeylib-parser/2012-02-08/monkeylib-parser-20120208-git.tgz 22347 3e4327f25a31e78f93fd50de71b41065 48d5b2a1b8072d27c7601124a166fbadb2bc1bb4 monkeylib-parser-20120208-git com.gigamonkeys.parser.asd +monkeylib-pathnames http://beta.quicklisp.org/archive/monkeylib-pathnames/2012-02-08/monkeylib-pathnames-20120208-git.tgz 3689 9f7c261f5a6f3e594c8b63f3a81fd87e 8d3750393675bcd26b42b59cf20ca4e9127d55f2 monkeylib-pathnames-20120208-git com.gigamonkeys.pathnames.asd +monkeylib-prose-diff http://beta.quicklisp.org/archive/monkeylib-prose-diff/2014-07-13/monkeylib-prose-diff-20140713-git.tgz 68305 6c656fe2d6bcb7eaba029b23da783a53 d70a0717980660fb19691b8f40c02fb430187a67 monkeylib-prose-diff-20140713-git com.gigamonkeys.prose-diff.asd +monkeylib-test-framework http://beta.quicklisp.org/archive/monkeylib-test-framework/2010-12-07/monkeylib-test-framework-20101207-git.tgz 7237 cebe94d4ac359f39cf0eef63cf0e8de5 52d736e23f6a71c8ea987186c1f4c1b460c5a356 monkeylib-test-framework-20101207-git com.gigamonkeys.test-framework.asd +monkeylib-text-languages http://beta.quicklisp.org/archive/monkeylib-text-languages/2011-12-03/monkeylib-text-languages-20111203-git.tgz 5234 a5ff209ee992b4fe4685cabd3616bc49 9e02022e60dfbcfa4e2c7399dec3d4e579721383 monkeylib-text-languages-20111203-git monkeylib-text-languages.asd +monkeylib-text-output http://beta.quicklisp.org/archive/monkeylib-text-output/2011-12-03/monkeylib-text-output-20111203-git.tgz 3919 1d0623eadd80d9b0bbfa71b5a6d08d31 12de87a35e9dd6169d0201c3d17f07ab7d9bcd16 monkeylib-text-output-20111203-git monkeylib-text-output.asd +monkeylib-utilities http://beta.quicklisp.org/archive/monkeylib-utilities/2017-04-03/monkeylib-utilities-20170403-git.tgz 12151 323d5400fe092b0aff4be8d39c8bef33 9c55b7c6192c126ff49da725fdadeaf4e90a5d3c monkeylib-utilities-20170403-git com.gigamonkeys.utilities.asd +montezuma http://beta.quicklisp.org/archive/montezuma/2018-02-28/montezuma-20180228-git.tgz 1264435 db964cddda9b92877259d7db67c2aac3 37dd0718f7823760da2d72d050b39a38c56b4758 montezuma-20180228-git contrib/montezuma-indexfiles/montezuma-indexfiles.asd lucene-in-action/lucene-in-action-tests.asd montezuma.asd +mop-utils http://beta.quicklisp.org/archive/mop-utils/2012-08-11/mop-utils-20120811-http.tgz 5309 f320b8601e9d921305b1fd5b405479b6 7ba77dc06ef07c5ff2ef756552a6016d4ba48071 mop-utils-20120811-http mop-utils.asd +moptilities http://beta.quicklisp.org/archive/moptilities/2017-04-03/moptilities-20170403-git.tgz 15618 b118397be325e60a772ea3631c4f19a4 a2b4eb6acad43773290ed22ee7698367476b01f5 moptilities-20170403-git moptilities-test.asd moptilities.asd +more-conditions http://beta.quicklisp.org/archive/more-conditions/2018-08-31/more-conditions-20180831-git.tgz 20791 c4797bd3c6c50fba02a6e8164ddafe28 d81093734a1f68b0ce022eaa1577334d22987390 more-conditions-20180831-git more-conditions.asd +mp3-duration http://beta.quicklisp.org/archive/mp3-duration/2016-02-08/mp3-duration-20160208-git.tgz 2763 fe74eb23d4016d798f4c7ab39fae1991 edeab1547d760345c92b49dbb707adf69c4e16a8 mp3-duration-20160208-git mp3-duration-test.asd mp3-duration.asd +mpc http://beta.quicklisp.org/archive/mpc/2016-09-29/mpc-20160929-git.tgz 22507 7a4be8c7f3c1a896d2fa06c6aff4accf fc09c11b6e330eee4d0435e1fe5a9d09c3d1c803 mpc-20160929-git mpc.asd +mra-wavelet-plot http://beta.quicklisp.org/archive/mra-wavelet-plot/2018-12-10/mra-wavelet-plot-20181210-git.tgz 2672 6e58c7f058b996710f89095bd7d55140 4824e4d538ea298a76d6c69f6df99782ce5e0b41 mra-wavelet-plot-20181210-git mra-wavelet-plot.asd +mt19937 http://beta.quicklisp.org/archive/mt19937/2011-02-19/mt19937-1.1.1.tgz 5551 54c63977b6d77abd66ebe0227b77c143 268d9a0d1dc870bd409bf9a85f80ff39840efd49 mt19937-1.1.1 mt19937.asd +mtif http://beta.quicklisp.org/archive/mtif/2017-11-30/mtif-20171130-git.tgz 36178 a713b90c4790464371cdc469d44a441f 8ee07bbf0c5b5fbfd618054945055ab638c7db57 mtif-20171130-git mtif.asd +mtlisp http://beta.quicklisp.org/archive/mtlisp/2013-06-15/mtlisp-20130615-git.tgz 41092 651cd99d4c77b0d533c1ee94e515b6b7 4d9ce6610ce99f89ddbfaea4d40a4369f8e1c8f8 mtlisp-20130615-git mtlisp.asd +multilang-documentation http://beta.quicklisp.org/archive/multilang-documentation/2019-07-10/multilang-documentation-20190710-git.tgz 7361 ba61cdd7a06d398143c4f18614c2b3a7 fa7caa1284353367149f88f1606465fa4357f49a multilang-documentation-20190710-git multilang-documentation.asd +multiple-value-variants http://beta.quicklisp.org/archive/multiple-value-variants/2014-08-26/multiple-value-variants-1.0.1.tgz 6991 b5676f66549832298262156277a79a52 b149d999e846c682677d7bbfbd3791c1baf73480 multiple-value-variants-1.0.1 multiple-value-variants.asd +multiposter http://beta.quicklisp.org/archive/multiposter/2019-07-10/multiposter-20190710-git.tgz 19032 38c12d3d08ad2b045f1b11e846eb2388 c49a54fb5fe7e314cbcc721677f0162e8b6a295e multiposter-20190710-git multiposter-git.asd multiposter-mastodon.asd multiposter-studio.asd multiposter-tumblr.asd multiposter-twitter.asd multiposter.asd +multival-plist http://beta.quicklisp.org/archive/multival-plist/2012-03-05/multival-plist-20120305-git.tgz 2263 db7767930bc07a150b697a6b63c369db eb4c2b023fccebd18549008ad67aa1ce6d4ace09 multival-plist-20120305-git multival-plist-test.asd multival-plist.asd +mw-equiv http://beta.quicklisp.org/archive/mw-equiv/2010-10-06/mw-equiv-0.1.3.tgz 6115 671497babfd44f6d9c5f0c02bddb457c 4a79edf2ca9f5e65daff7f37323da4f1055d914c mw-equiv-0.1.3 mw-equiv.asd +mystic http://beta.quicklisp.org/archive/mystic/2016-02-08/mystic-20160208-git.tgz 7566 c76b5583defbbc0a921332f496fee7c5 a0ddfaea0aea12b7ce41e05d446626cf02a5d99f mystic-20160208-git mystic-file-mixin.asd mystic-fiveam-mixin.asd mystic-gitignore-mixin.asd mystic-library-template.asd mystic-readme-mixin.asd mystic-test.asd mystic-travis-mixin.asd mystic.asd +myway http://beta.quicklisp.org/archive/myway/2018-10-18/myway-20181018-git.tgz 5345 88adecdaec89ceb262559d443512e545 59f2da1260d448da0d9fc41e6ae2ddde26d5f5bc myway-20181018-git myway-test.asd myway.asd +myweb http://beta.quicklisp.org/archive/myweb/2015-06-08/myweb-20150608-git.tgz 29572 bc91336495ca1421dac79bf14c5e6881 9e6e03663659d582aca58d1bfb7606952e9a7fcf myweb-20150608-git myweb.asd +named-read-macros http://beta.quicklisp.org/archive/named-read-macros/2018-02-28/named-read-macros-20180228-git.tgz 7508 d0d68f2a17654219f1b1aebd16978003 dbe6462ca342c5620b1438265f93785053df5d3a named-read-macros-20180228-git named-read-macros.asd test/named-read-macros-test.asd +named-readtables http://beta.quicklisp.org/archive/named-readtables/2018-01-31/named-readtables-20180131-git.tgz 32869 46db18ba947dc0aba14c76471604448d 6a6509d4c21a89df82098635fe655eb1d156dbbf named-readtables-20180131-git named-readtables.asd +nanovg-blob http://beta.quicklisp.org/archive/nanovg-blob/2018-02-28/nanovg-blob-stable-c9ef601c-git.tgz 805423 1efaa411fe9fcde20207682ec4e965a8 633c8e7c3059eb7269dfed86758b258de3994d05 nanovg-blob-stable-c9ef601c-git nanovg-blob.asd +napa-fft3 http://beta.quicklisp.org/archive/napa-fft3/2015-12-18/napa-fft3-20151218-git.tgz 31959 4930569d5c4092ab11f76d8886779e6e 61afdce14dfe27431acbbd063c9840786b5e5d11 napa-fft3-20151218-git napa-fft3.asd +narrowed-types http://beta.quicklisp.org/archive/narrowed-types/2018-02-28/narrowed-types-20180228-git.tgz 2510 a149f985d2032c17210a3f75a9eca101 130b28978940159ed19df76eed1945738cfd1b05 narrowed-types-20180228-git narrowed-types-test.asd narrowed-types.asd +neo4cl http://beta.quicklisp.org/archive/neo4cl/2018-08-31/neo4cl-20180831-git.tgz 10076 bc94c945ddee04e872ffb3958c1a2577 93efd8fbc1df222b66a3c401344c036b4b83ade6 neo4cl-20180831-git src/neo4cl.asd test/neo4cl-test.asd +net-telent-date http://beta.quicklisp.org/archive/net-telent-date/2010-10-06/net-telent-date_0.42.tgz 12575 6fedf40113b2462f7bd273d07950066b 2a0efdd496136ba7d0d1d7b701ff57f9f0a0929f net-telent-date_0.42 net-telent-date.asd +network-addresses http://beta.quicklisp.org/archive/network-addresses/2016-06-28/network-addresses-20160628-git.tgz 4504 6b48746dc7beff85ed4b81edc4d31732 aa2e821a7e184fa885827db8b111896d641d3f6b network-addresses-20160628-git network-addresses-test.asd network-addresses.asd +new-op http://beta.quicklisp.org/archive/new-op/2019-01-07/new-op-20190107-git.tgz 22260 6c2743ca9eaac48b619d911008f44795 6fb4b2b881e489757f4e4de9604b9f59f10dd8a7 new-op-20190107-git new-op.asd +nibbles http://beta.quicklisp.org/archive/nibbles/2018-08-31/nibbles-20180831-git.tgz 17647 4badf1f066a59c3c270d40be1116ecd5 8aa99c491fb71a18bf8da843556b1df0da368152 nibbles-20180831-git nibbles.asd +nineveh http://beta.quicklisp.org/archive/nineveh/2019-10-07/nineveh-release-quicklisp-0a10a846-git.tgz 47692 c7c3fe5e3a5a3bb9e8e7de3086cf95bb 43962ced034bf55962f61fe06ba75c2dd85a47a6 nineveh-release-quicklisp-0a10a846-git nineveh.asd +ningle http://beta.quicklisp.org/archive/ningle/2019-10-07/ningle-20191007-git.tgz 7069 13c890c05123b77d1d4c0f811490bfb2 f4677ddadcb493627fba8f96b6dd4142694afe57 ningle-20191007-git ningle-test.asd ningle.asd +nodgui http://beta.quicklisp.org/archive/nodgui/2019-12-27/nodgui-20191227-git.tgz 119723 8aefa966cc15e060128411810b3e1776 44069f8dfd09491695d398e8b8da762b6dc97dce nodgui-20191227-git nodgui.asd +north http://beta.quicklisp.org/archive/north/2019-07-10/north-20190710-git.tgz 53727 911fa6dff0ba34301ab3b7ed26194a69 0e36470bba12f4bc9e533a8efab20f452f42d793 north-20190710-git example/north-example.asd north-core.asd north-dexador.asd north-drakma.asd north.asd +nsort http://beta.quicklisp.org/archive/nsort/2015-05-05/nsort-20150505-git.tgz 1785 71e01656a21f61447e0298f89d3af456 912766fd5765889a4ce4a6a0b64fc2d14d29f63a nsort-20150505-git nsort.asd +nst http://beta.quicklisp.org/archive/nst/2016-03-18/nst-4.1.0.tgz 635557 4fedd2bed9ead1c50901087ff8b14ef6 037e7bb17db08f52a0286b5d4f2d7388792ede38 nst-4.1.0 asdf-nst.asd nst.asd test/direct/nst-simple-tests.asd test/lisp/comp-set/comp-set.asd test/manual/nst-manual-tests.asd test/meta/mnst-relay.asd test/meta/nst-meta-tests.asd test/nst-test-jenkins.asd test/nst-test.asd test/util/nst-selftest-utils.asd utils/mop/nst-mop-utils.asd +nuclblog http://beta.quicklisp.org/archive/nuclblog/2014-08-26/nuclblog-20140826-git.tgz 20053 fb80583640212d0bfc452f9156917eac ffded3e808a703fdda65f3b3ab7c677c9be60946 nuclblog-20140826-git nuclblog.asd +nuklear-blob http://beta.quicklisp.org/archive/nuklear-blob/2018-02-28/nuklear-blob-stable-6c297dc2-git.tgz 1144021 ff3ca427d01ca1b40a4793aae8ff5669 3aa2e0c8484bead4269be706f87593cf9c8b30d0 nuklear-blob-stable-6c297dc2-git nuklear-blob.asd +num-utils http://beta.quicklisp.org/archive/num-utils/2019-11-30/num-utils-20191130-git.tgz 69549 d48ab213d48378c1ed16506d43472c63 3c8458aea70de41f285c5bd93ee84eab036d39af num-utils-20191130-git num-utils.asd +numcl http://beta.quicklisp.org/archive/numcl/2019-12-27/numcl-20191227-git.tgz 252024 8832fb53f6839b4713d39972d8c01849 99f19f64e445e3e8b517c3ff7f5a9ed01fcbcd1f numcl-20191227-git numcl.asd numcl.test.asd +numpy-file-format http://beta.quicklisp.org/archive/numpy-file-format/2019-07-10/numpy-file-format-20190710-git.tgz 4675 06d473abeb72c1ff6d8905dfe2fc19ef 1c134c560b2e98b3f39f6ded3c0b4a37b8e2383b numpy-file-format-20190710-git code/numpy-file-format.asd +oclcl http://beta.quicklisp.org/archive/oclcl/2019-05-21/oclcl-20190521-git.tgz 171806 3e1768e4d9c1412aabd19fc23457ca8f 2f49a21ab843dc52b012a82c286142994c122e95 oclcl-20190521-git oclcl-examples.asd oclcl-test.asd oclcl.asd +ode-blob http://beta.quicklisp.org/archive/ode-blob/2018-02-28/ode-blob-stable-bf2a5e4e-git.tgz 3757262 0aab7098d5e984763feb298da1c041fb cd711fe77374c6065f16821af4e86eac156dab9a ode-blob-stable-bf2a5e4e-git ode-blob.asd +oe-encode http://beta.quicklisp.org/archive/oe-encode/2015-08-04/oe-encode-20150804-git.tgz 49756 317e7cb5295306a3b64a7b5cfe673093 1d2ad0214c58b88ddff8c2f66e8ef1d89b6de0ba oe-encode-20150804-git oe-encode.asd +omer-count http://beta.quicklisp.org/archive/omer-count/2019-01-07/omer-count-20190107-git.tgz 15545 286a7a336643883ab687d59e45411fd0 87d0a5cf584feec73ae0d49f0450d4281358562f omer-count-20190107-git eclecticse.omer.asd +oneliner http://beta.quicklisp.org/archive/oneliner/2013-10-03/oneliner-20131003-git.tgz 3129 8709f2596797542709d9fc02e557d8c2 b2c7d3ee581dc13e43cf14a85b1f3e0bca093625 oneliner-20131003-git cl-oneliner.asd +ook http://beta.quicklisp.org/archive/ook/2019-01-07/ook-20190107-git.tgz 12018 2d97c0df14bbeb217c3f040debad16c8 ee5b43757da4eec24f07ed7ae92af92823633603 ook-20190107-git ook.asd +oook http://beta.quicklisp.org/archive/oook/2017-11-30/oook-20171130-git.tgz 12023 eb6ee68a5f48b3720d7285fae7336485 b368840c0547253cb2c82e9ef9c48ffd27fed565 oook-20171130-git oook.asd +open-location-code http://beta.quicklisp.org/archive/open-location-code/2019-05-21/open-location-code-20190521-git.tgz 16291 b4284a6d6e2cc69ed83c55cda0b12e42 3026ae7a678f5cee8ee82cad27c742d604605ff7 open-location-code-20190521-git open-location-code.asd +open-vrp http://beta.quicklisp.org/archive/open-vrp/2014-09-14/open-vrp-20140914-git.tgz 925579 718ad8132bb06eb5a66b1c1a814b7e66 066d3adb2be495e1a76dadf9e55ec2e66519715c open-vrp-20140914-git open-vrp-lib.asd open-vrp.asd +openal-blob http://beta.quicklisp.org/archive/openal-blob/2018-02-28/openal-blob-stable-d414fc89-git.tgz 2266861 d372c27834a955621f3c8e1a3f853908 8a962e86b10de8af75d6b6b9c1f126d3dec759e9 openal-blob-stable-d414fc89-git openal-blob.asd +openid-key http://beta.quicklisp.org/archive/openid-key/2018-12-10/openid-key-20181210-git.tgz 3284 cbe196eef93ee9eec7ef117557c440b2 4cdb875b541259e7bb9bbf8d26244f3dba1078b2 openid-key-20181210-git openid-key-test.asd openid-key.asd +opticl http://beta.quicklisp.org/archive/opticl/2018-12-10/opticl-20181210-git.tgz 193833 4d33d1faff5db29a1ffe65df37555f4f 16a4b01d3a336929a0389211e349e1ea2122d143 opticl-20181210-git opticl-doc.asd opticl.asd +opticl-core http://beta.quicklisp.org/archive/opticl-core/2017-10-19/opticl-core-20171019-git.tgz 4502 612766d24e14244a87d0bf41a789ed5a 90fe1cccff0248626018b5634abdf717f5e8c445 opticl-core-20171019-git opticl-core.asd +optima http://beta.quicklisp.org/archive/optima/2015-07-09/optima-20150709-git.tgz 20345 20523dc3dfc04bb2526008dff0842caa aec56f162a6b34024d0b419ed9dfb35ef9e75be6 optima-20150709-git optima.asd optima.ppcre.asd optima.test.asd +org-davep-dict http://beta.quicklisp.org/archive/org-davep-dict/2019-05-21/org-davep-dict-20190521-git.tgz 6731 a5c307e394ddaf3dc23fd415fb025e04 84ce779221666927b4e07aaa47fcd26fb24f7bf0 org-davep-dict-20190521-git org-davep-dict.asd +org-davep-dictrepl http://beta.quicklisp.org/archive/org-davep-dictrepl/2019-05-21/org-davep-dictrepl-20190521-git.tgz 2983 311107f58978970b214e575690815a62 89eb453c83abfd72dd4c6a821a5b9704794e2fab org-davep-dictrepl-20190521-git org-davep-dictrepl.asd +org-sampler http://beta.quicklisp.org/archive/org-sampler/2016-03-18/org-sampler-0.2.0.tgz 61604 1d367f79a5cb325abce3e1640ce6bc91 e7e572deb75c9bb2f55bdca3a5915bf1fb4440da org-sampler-0.2.0 org-sampler.asd +origin http://beta.quicklisp.org/archive/origin/2019-12-27/origin-20191227-git.tgz 32925 6a1916f3d76c940967dd204be8f9ea1c 6daccc964991755c6dafaaaf40e18ebef136d7f4 origin-20191227-git origin.asd origin.test.asd +orizuru-orm http://beta.quicklisp.org/archive/orizuru-orm/2019-10-07/orizuru-orm-20191007-git.tgz 49639 3ea3d1379b9051835ff209074a67655b 71ccbac81c4d6cdc4c868be10a97d8d76e8b4960 orizuru-orm-20191007-git orizuru-orm.asd +osc http://beta.quicklisp.org/archive/osc/2019-05-21/osc-20190521-git.tgz 17189 3de093d1f99a34544e8555d3e51c7f6e 34689d25a01a1ef71f27de6f3bc4179a0b732e3e osc-20190521-git osc.asd +osicat http://beta.quicklisp.org/archive/osicat/2019-07-10/osicat-20190710-git.tgz 54723 9a062b84fce8979686c17d676ff0c0e5 49bbb5830916a90b306460aa396b6b3cee7db912 osicat-20190710-git osicat-tests.asd osicat.asd +osmpbf http://beta.quicklisp.org/archive/osmpbf/2019-12-27/osmpbf-20191227-git.tgz 18603 444df002a3e438b778531aa2fb8656b1 29c085b73c5dc84a3c14ae2c7d934b81d605e3d4 osmpbf-20191227-git osmpbf.asd +overlord http://beta.quicklisp.org/archive/overlord/2019-11-30/overlord-20191130-git.tgz 59572 1bc805d3c001a1a1416663edd488af1f d647d87e17a8c42e806162b10a2c6c6f13f8146f overlord-20191130-git overlord.asd +oxenfurt http://beta.quicklisp.org/archive/oxenfurt/2019-07-10/oxenfurt-20190710-git.tgz 23362 d3399266edf13969b0031f972a15477f 146d6718296832a33ebd25076d743677b4a74a95 oxenfurt-20190710-git oxenfurt-core.asd oxenfurt-dexador.asd oxenfurt-drakma.asd oxenfurt.asd +pack http://beta.quicklisp.org/archive/pack/2011-06-19/pack-20110619-git.tgz 3684 f769fa83d8487575facf6fe5adf9b245 e33f75deac5ab3a1facc24fc378c9184b6be6d04 pack-20110619-git pack.asd +package-renaming http://beta.quicklisp.org/archive/package-renaming/2012-04-07/package-renaming-20120407-git.tgz 4522 b9d7b446196fba632edd088bf9ad23ae bcba6923289ab9cf2f539dec333853ff7d9e0a65 package-renaming-20120407-git package-renaming-test.asd package-renaming.asd +packet http://beta.quicklisp.org/archive/packet/2015-03-02/packet-20150302-git.tgz 10533 71312a40fa6abb7027b94c8a57a90d00 5c459eb3feebdfed53359a7b021cba522ae6df71 packet-20150302-git packet.asd +paiprolog http://beta.quicklisp.org/archive/paiprolog/2018-02-28/paiprolog-20180228-git.tgz 172150 1f04f011c9f09d7fe854b98e845d21bd e5505fd5ff9fb77bf6e3374ab0d5e9e37cc7186a paiprolog-20180228-git paiprolog.asd unifgram.asd +pal http://beta.quicklisp.org/archive/pal/2015-06-08/pal-20150608-git.tgz 3707918 ce7afd79040188475efc67ae87287949 795d4e4f69cb4132ee35b641e564ee01ab6365d9 pal-20150608-git examples/bermuda/bermuda.asd pal.asd +pandocl http://beta.quicklisp.org/archive/pandocl/2015-09-23/pandocl-20150923-git.tgz 2581 ee9450a491206f3c606c05bb63268c08 613046a725fc6925372f484d1771c6acf4b74b0d pandocl-20150923-git pandocl.asd +pango-markup http://beta.quicklisp.org/archive/pango-markup/2019-07-10/pango-markup-20190710-git.tgz 9296 811d7fb0d9d3744030c5ff63873d9a8c 67ac0851ed2b9f01ca5a59c18c3a9c95e4f122c8 pango-markup-20190710-git pango-markup.asd +papyrus http://beta.quicklisp.org/archive/papyrus/2018-01-31/papyrus-20180131-git.tgz 75141 21f9ff35cb1dc7e0b908747c99bbfa63 6720de69bc909d07e0f4b9818b751361a1e16925 papyrus-20180131-git papyrus.asd +parachute http://beta.quicklisp.org/archive/parachute/2019-11-30/parachute-20191130-git.tgz 52496 ab5ee5589a6db1dbe0d6dbc1671022c6 3e30731da18f6ebf73c2e4ad5ea7ad3fe629917f parachute-20191130-git compat/parachute-fiveam.asd compat/parachute-lisp-unit.asd compat/parachute-prove.asd parachute.asd +parameterized-function http://beta.quicklisp.org/archive/parameterized-function/2019-03-07/parameterized-function-20190307-hg.tgz 3178 13de98b8381cd84c9cad3dde122e919a d0ee504ad9a10a393ff6326f1885ebfd16981149 parameterized-function-20190307-hg parameterized-function.asd +paren-files http://beta.quicklisp.org/archive/paren-files/2011-04-18/paren-files-20110418-git.tgz 11665 cf10bbcfa01d65e1487b2764d3967aeb 136c1ec5faace0cb6642fde48c9c8c317e0a3b91 paren-files-20110418-git paren-files.asd +paren-test http://beta.quicklisp.org/archive/paren-test/2017-08-30/paren-test-20170830-git.tgz 2796 1699edb46292e81cc416a717d42eb13a 8337b21fd440117d26c77f1ce1c6c3d81ec49265 paren-test-20170830-git examples/arith.asd paren-test.asd +paren-util http://beta.quicklisp.org/archive/paren-util/2011-04-18/paren-util-20110418-git.tgz 9583 ce8212375a6586235774baa4f7cfc4c5 1928ce6c595d307357e01e49fd47c32993b8562e paren-util-20110418-git paren-util.asd +paren6 http://beta.quicklisp.org/archive/paren6/2019-11-30/paren6-20191130-git.tgz 11611 0a7af3a318e176871cd0f5f54f701329 1fe467be360247f27cb410c5f19989cb9a002d00 paren6-20191130-git paren6.asd test-paren6.asd +parenml http://beta.quicklisp.org/archive/parenml/2015-09-23/parenml-20150923-git.tgz 2084 e02a5cb32d6ceda30744c90589b854cb 87db838f002b09178393e5162ebf681b43d23be6 parenml-20150923-git parenml-test.asd parenml.asd +parenscript http://beta.quicklisp.org/archive/parenscript/2018-12-10/Parenscript-2.7.1.tgz 103952 047c9a72bd36f1b4a5ec67af9453a0b9 2532046ecb26bcbc808bf8ed2d14d140a9a33fba Parenscript-2.7.1 parenscript.asd parenscript.tests.asd +parenscript-classic http://beta.quicklisp.org/archive/parenscript-classic/2011-12-03/parenscript-classic-20111203-darcs.tgz 185472 9d355c65babf238bdce498ff628e187b 3ea1563d8e21583c48b31677797e99b74fd31492 parenscript-classic-20111203-darcs parenscript-classic.asd +parse http://beta.quicklisp.org/archive/parse/2019-10-07/parse-20191007-git.tgz 7392 9b12a61e279f5cf969b45feff6946efa ab4b3da76e74abf9f5ca8a76c877c9d303caf79d parse-20191007-git parse.asd +parse-declarations http://beta.quicklisp.org/archive/parse-declarations/2010-10-06/parse-declarations-20101006-darcs.tgz 36664 e49222003e5b59c5c2a0cf58b86cfdcd f2ed7dbb076058e4aef57553469759b13a0a618c parse-declarations-20101006-darcs parse-declarations-1.0.asd +parse-float http://beta.quicklisp.org/archive/parse-float/2017-10-19/parse-float-20171019-git.tgz 4696 182135a8478013dbd52b87a9f378adc0 c280e2e4f7fd153d0ddec5de03f56b0891f33e24 parse-float-20171019-git parse-float.asd +parse-front-matter http://beta.quicklisp.org/archive/parse-front-matter/2016-08-25/parse-front-matter-20160825-git.tgz 1378 478c27505370135f5d8859fe5c755431 2da48a358580ac203b5762acdce7eb3e6516f39b parse-front-matter-20160825-git parse-front-matter-test.asd parse-front-matter.asd +parse-js http://beta.quicklisp.org/archive/parse-js/2016-04-21/parse-js-20160421-git.tgz 10664 14049fdc5f55bf48d7e3d54a9549a97e c6baef888b9383b2d437d31426f231de8a31b064 parse-js-20160421-git parse-js.asd +parse-number http://beta.quicklisp.org/archive/parse-number/2018-02-28/parse-number-v1.7.tgz 5715 b9ec925018b8f10193d73403873dde8f 472816dd6ad673d3be65ae33495c5378ba6b6588 parse-number-v1.7 parse-number.asd +parse-number-range http://beta.quicklisp.org/archive/parse-number-range/2012-11-25/parse-number-range-1.0.tgz 5733 a1a173bffeafcdca9320473f14103f80 c79d229ba4d3a0c5267b21b3560026b78a8c2300 parse-number-range-1.0 parse-number-range.asd +parseltongue http://beta.quicklisp.org/archive/parseltongue/2013-03-12/parseltongue-20130312-git.tgz 27941 4519905cf797085c6063c33bf0107b9c 3f9099ad7ee505fe0b8abaaca1e32d03bf6892b0 parseltongue-20130312-git parseltongue.asd +parseq http://beta.quicklisp.org/archive/parseq/2018-07-11/parseq-20180711-git.tgz 40220 850be8911e7bda4c0fa70da9891ab348 2e6f48a219623b5221774a3bc8f11fe999aafe75 parseq-20180711-git parseq.asd +parser.common-rules http://beta.quicklisp.org/archive/parser.common-rules/2019-08-13/parser.common-rules-20190813-git.tgz 18693 ac4b894c728378c016a4ab71eb00503f b768c951247e8f9596abcd52b67a9869d8c9e98e parser.common-rules-20190813-git parser.common-rules.asd parser.common-rules.operators.asd +parser.ini http://beta.quicklisp.org/archive/parser.ini/2018-10-18/parser.ini-20181018-git.tgz 11142 83943b433684f7bef2ad113adef8e4fd 60010609b62b382abbdda31e8824ab3026a42ffe parser.ini-20181018-git parser.ini.asd +parsley http://beta.quicklisp.org/archive/parsley/2019-07-10/parsley-20190710-git.tgz 2598 5e7ad4fb112607379dd20e2ad52ee766 d32698da74e3fadf88145220be4cd0c2d828addc parsley-20190710-git parsley.asd +patchwork http://beta.quicklisp.org/archive/patchwork/2019-10-08/patchwork-20191008-git.tgz 5446 0b6ec00c7d0cd7b60ee98bfc71fc9acc 2f96d153b0439cfbcf0b121771f6a11275ec2cac patchwork-20191008-git patchwork.asd +path-parse http://beta.quicklisp.org/archive/path-parse/2016-04-21/path-parse-20160421-git.tgz 2115 83ace94d06e0759f717bf11be698602e 331bfeef1557fa4133220cac48bf4afb4f62a8da path-parse-20160421-git path-parse-test.asd path-parse.asd +path-string http://beta.quicklisp.org/archive/path-string/2016-08-25/path-string-20160825-git.tgz 4983 bc3d1e818a793d955eb6877f67bd4d52 833c85edc0fffcfcef2a9b5cfd111910c648293a path-string-20160825-git path-string-test.asd path-string.asd +pathname-utils http://beta.quicklisp.org/archive/pathname-utils/2019-07-10/pathname-utils-20190710-git.tgz 11927 b9a4eca84ddaa0e4daa6f2a66f788d3e 1f11bb91ee40ef38fc9de2a3f1af40a58b135e81 pathname-utils-20190710-git pathname-utils-test.asd pathname-utils.asd +patron http://beta.quicklisp.org/archive/patron/2013-04-20/patron-20130420-git.tgz 12195 dd08fa2247852002f9884ccc842aeae4 6d2f8130f0ab4eab47b9aba79e3cc060ef6da096 patron-20130420-git patron.asd +pcall http://beta.quicklisp.org/archive/pcall/2010-10-06/pcall-0.3.tgz 14561 019d85dfd1d5d0ee8d4ee475411caf6b 65626582e38d7a8b3180382a694a96290fde4b2c pcall-0.3 pcall-queue.asd pcall.asd +percent-encoding http://beta.quicklisp.org/archive/percent-encoding/2012-10-13/percent-encoding-20121013-git.tgz 5240 de4b28564907c12b598630d27135d80f c945ddb56afaf0244019242f77e396edfe870e1f percent-encoding-20121013-git percent-encoding.asd +periodic-table http://beta.quicklisp.org/archive/periodic-table/2011-10-01/periodic-table-1.0.tgz 5100 1fe8e203b8b622857fe1af4ade13e7ce 1f118c131789908e9108b84e72c2e1325f1ee22e periodic-table-1.0 periodic-table.asd +periods http://beta.quicklisp.org/archive/periods/2019-03-07/periods-20190307-git.tgz 32775 2c6e7fb7b1bd2ce68fa8b4a465bbf1b8 8d5404ba512157b680285dbe51a8c5f0ed8d445e periods-20190307-git periods-series.asd periods.asd +perlre http://beta.quicklisp.org/archive/perlre/2018-10-18/perlre-20181018-git.tgz 7321 48d78039676ff6d2373bf194132e87d1 84d7222acf11fb1ef2cbe59a7a911e16a761913e perlre-20181018-git perlre.asd +persistent-tables http://beta.quicklisp.org/archive/persistent-tables/2012-02-08/persistent-tables-20120208-git.tgz 2585 08f6feb0c4716102d9f4c0ebe817a7be d53ebc25f643ca4ff4f4dda34421ddd1f6a2137c persistent-tables-20120208-git persistent-tables.asd +persistent-variables http://beta.quicklisp.org/archive/persistent-variables/2013-03-12/persistent-variables-20130312-git.tgz 117127 ba06997b04bdbeee85fc8861e0cdf687 ac9009d2637c21140d015c84b88200659808a7e1 persistent-variables-20130312-git persistent-variables.asd +petalisp http://beta.quicklisp.org/archive/petalisp/2019-12-27/petalisp-20191227-git.tgz 110026 e386843163c9b7be44df67aa3f1f4024 b158a44b6bb9dc21a985488f8c654f809aeecd48 petalisp-20191227-git code/api/petalisp.api.asd code/core/petalisp.core.asd code/graphviz/petalisp.graphviz.asd code/ir-backend/petalisp.ir-backend.asd code/ir/petalisp.ir.asd code/native-backend/petalisp.native-backend.asd code/native-compiler/petalisp.blueprint-compiler.asd code/petalisp.asd code/reference-backend/petalisp.reference-backend.asd code/scheduler/petalisp.scheduler.asd code/test-suite/petalisp.test-suite.asd code/type-inference/petalisp.type-inference.asd code/utilities/petalisp.utilities.asd examples/petalisp.examples.asd +petit.package-utils http://beta.quicklisp.org/archive/petit.package-utils/2014-08-26/petit.package-utils-20140826-git.tgz 2290 58e6dceab797eec3cea779e5fb366486 f8a4735180f1d47481349ed8801433a4a6a5a8df petit.package-utils-20140826-git petit.package-utils.asd +petit.string-utils http://beta.quicklisp.org/archive/petit.string-utils/2014-11-06/petit.string-utils-20141106-git.tgz 4262 dea2dea0ac8045a1930a81231a1ac39b 8169426736e26e55f30171560c3b0e17c0175eea petit.string-utils-20141106-git petit.string-utils-test.asd petit.string-utils.asd +petri http://beta.quicklisp.org/archive/petri/2019-02-02/petri-20190202-git.tgz 139161 9de1c080844a2430c69b41b9be625c3c 14be4e87ea4efea0e254459ec1ca3c094c9fe038 petri-20190202-git petri.asd +pettomato-deque http://beta.quicklisp.org/archive/pettomato-deque/2012-01-07/pettomato-deque-20120107-git.tgz 5573 f4aebae99019f5ca7c82fec60540bbd9 7f132a9c5c15aac2d555bc1c19570973d32eb5c3 pettomato-deque-20120107-git pettomato-deque-tests.asd pettomato-deque.asd +pettomato-indexed-priority-queue http://beta.quicklisp.org/archive/pettomato-indexed-priority-queue/2012-09-09/pettomato-indexed-priority-queue-20120909-git.tgz 7555 f734b68ce8cdb911562cdd62eed1d5aa fdeebe7c9c560e4c559c18ba9ee833310685a1eb pettomato-indexed-priority-queue-20120909-git pettomato-indexed-priority-queue-tests.asd pettomato-indexed-priority-queue.asd +pg http://beta.quicklisp.org/archive/pg/2015-06-08/pg-20150608-git.tgz 48921 11a6ddac157a7443155158e255a2452b 6e5a808a1b08d0049450724574058280cf3a8a2d pg-20150608-git pg.asd +pgloader http://beta.quicklisp.org/archive/pgloader/2019-02-02/pgloader-v3.6.1.tgz 3677520 9cba0e3afa1706a20cfdeced7ad1fce2 ca692deb0d4adecad7d351beb8180c775f09b78b pgloader-v3.6.1 pgloader.asd +phoe-toolbox http://beta.quicklisp.org/archive/phoe-toolbox/2019-11-30/phoe-toolbox-20191130-git.tgz 9300 051096aa7c921ca6179ae76e7d85675c 2f7e572ede4b16fc572518980bed8d2b74cb9b4f phoe-toolbox-20191130-git phoe-toolbox.asd +physical-quantities http://beta.quicklisp.org/archive/physical-quantities/2018-07-11/physical-quantities-20180711-git.tgz 30191 3e8e842b0e68b2ca2d446bead7ca0a1d 3ff468dd80a6f49475c13eff113eb3ab7b87cb9e physical-quantities-20180711-git physical-quantities.asd +piggyback-parameters http://beta.quicklisp.org/archive/piggyback-parameters/2019-10-07/piggyback-parameters-20191007-git.tgz 6763 65d36af31df9beeec878cc4d7ce0ba85 50544fdcb667c6a092e2a48dabcc3c44a5f6fcf1 piggyback-parameters-20191007-git piggyback-parameters.asd +pileup http://beta.quicklisp.org/archive/pileup/2015-07-09/pileup-20150709-git.tgz 20217 230aeb8bbb0993c5fecd4ef47052623f 045fe18800b0e56283617fa5b032c483f38be280 pileup-20150709-git pileup.asd +pipes http://beta.quicklisp.org/archive/pipes/2015-09-23/pipes-20150923-git.tgz 5603 77717361af87e7a83d38e84d08ad29f5 e7ce78dc510136ebd0b8b6a7495fac662233a363 pipes-20150923-git pipes.asd +piping http://beta.quicklisp.org/archive/piping/2019-07-10/piping-20190710-git.tgz 8533 852246a0c773a047dfb023638198387a 0f0fd020438d640c211736f0e572d11e4388edeb piping-20190710-git piping.asd +pithy-xml http://beta.quicklisp.org/archive/pithy-xml/2010-10-06/pithy-xml-20101006-git.tgz 10188 5401547ac31ab9c502d3409a9200a0dc 9445d371b1e0801e3e75ff112f8ba551bb372276 pithy-xml-20101006-git pithy-xml.asd +pjlink http://beta.quicklisp.org/archive/pjlink/2019-10-07/pjlink-20191007-git.tgz 14963 6d48f93695a792dbc2fb5c702596642a 04bcc61e1d3cdd6f11dfae46759542e906168159 pjlink-20191007-git src/pjlink.asd +place-modifiers http://beta.quicklisp.org/archive/place-modifiers/2012-11-25/place-modifiers-2.1.tgz 10202 8c209e6ee7e376b20b447a4e75fb12e3 3a15cc3cd06e587cb81222057b99efa0a27a1545 place-modifiers-2.1 place-modifiers.asd +place-utils http://beta.quicklisp.org/archive/place-utils/2018-10-18/place-utils-0.2.tgz 14315 5462562949ab3a8b5a9f40e9e6d2a628 164c95f8afeab6e8ddf256f1f845108665035fa0 place-utils-0.2 place-utils.asd +plain-odbc http://beta.quicklisp.org/archive/plain-odbc/2019-11-30/plain-odbc-20191130-git.tgz 60040 cfa0da32a083a406344e6f6504d962de 9a7a0ce75ac9e1ef7c2fddc0705a1b2429196400 plain-odbc-20191130-git plain-odbc.asd +planks http://beta.quicklisp.org/archive/planks/2011-05-22/planks-20110522-git.tgz 13152 b0881e48b242ea36e95a815ba6118950 6fd7b423ace8306647696ae42d465683bec59e1a planks-20110522-git planks.asd +plexippus-xpath http://beta.quicklisp.org/archive/plexippus-xpath/2019-05-21/plexippus-xpath-20190521-git.tgz 56479 eb9a4c39a7c37aa0338c401713b3f944 6acb71007298138bb494e04abe39a79fff54af86 plexippus-xpath-20190521-git xpath.asd +plokami http://beta.quicklisp.org/archive/plokami/2019-07-10/plokami-20190710-git.tgz 20055 2ec548790adf34ae9d0ffa3b3ba2549c 5b5c0dc3f9bbe2570e54aa4400b221a20cef9232 plokami-20190710-git plokami.asd +pludeck http://beta.quicklisp.org/archive/pludeck/2018-08-31/pludeck-20180831-git.tgz 5125 7cc744ed744245026604347abf01a539 3bed71c98b172d330579aaa8833575f9f7b5b7f3 pludeck-20180831-git pludeck.asd +plump http://beta.quicklisp.org/archive/plump/2019-07-10/plump-20190710-git.tgz 50917 e3276779e368758274156c9477f0b22a a2d8f464c4303e047d5b1bb982311ab11e82f09d plump-20190710-git plump-dom.asd plump-lexer.asd plump-parser.asd plump.asd +plump-bundle http://beta.quicklisp.org/archive/plump-bundle/2019-07-10/plump-bundle-20190710-git.tgz 7705 a89ccc2557c1657fa080302d5c929a6d 7a4b27d045b483bfc99ecfd43e5084bc6b985e60 plump-bundle-20190710-git plump-bundle.asd +plump-sexp http://beta.quicklisp.org/archive/plump-sexp/2019-07-10/plump-sexp-20190710-git.tgz 6669 d5dd63dd63cff2095b5f38211f684fd4 0dcbf5533db0fa9212ba9169bdcb14513885ae45 plump-sexp-20190710-git plump-sexp.asd +plump-tex http://beta.quicklisp.org/archive/plump-tex/2019-07-10/plump-tex-20190710-git.tgz 6490 ecef24ab6111712b5d0da63cc5e86a92 7badffb575c1b39a1f25886990f9b9ec48b848fe plump-tex-20190710-git plump-tex-test.asd plump-tex.asd +png-read http://beta.quicklisp.org/archive/png-read/2017-08-30/png-read-20170830-git.tgz 8677 40354aa5f3f3321a4d42629c15c6f9f7 d36071bb47abcda177284afddd83cf518d579b19 png-read-20170830-git png-read.asd +pngload http://beta.quicklisp.org/archive/pngload/2019-10-07/pngload-20191007-git.tgz 94912 3f2e9dbc56cefbc480cac2faaa97b49a 0b79824eebdb1644283ab767b2387f9824b00ae9 pngload-20191007-git pngload.asd pngload.test.asd +pngload-fast http://beta.quicklisp.org/archive/pngload-fast/2019-10-07/pngload-fast-20191007-git.tgz 94919 8f9f1aaeabea83e8b3c75f348a123606 1009b43c9e4cd2428e00518e843dfebd1db771d0 pngload-fast-20191007-git pngload-fast.asd pngload-fast.test.asd +poler http://beta.quicklisp.org/archive/poler/2018-12-10/poler-20181210-git.tgz 6505 9f7588fcb283ff5c56bab084304fc4a3 fbf7235432d08b6d488bd1282ba19dddd9e0db36 poler-20181210-git poler-test.asd poler.asd +policy-cond http://beta.quicklisp.org/archive/policy-cond/2019-03-07/policy-cond-20190307-hg.tgz 6132 1773f5aa332484e6742adf38e9fd4b15 51f227d249080950afa1d16fa3fefaa4e0967fab policy-cond-20190307-hg policy-cond.asd +polisher http://beta.quicklisp.org/archive/polisher/2019-12-27/polisher-20191227-git.tgz 6538 b6d069250705e6a07378beeaab5eb002 c7e88975635c889520c274d44a6a2d2d6b8e72dc polisher-20191227-git polisher.asd polisher.test.asd +pooler http://beta.quicklisp.org/archive/pooler/2015-06-08/pooler-20150608-git.tgz 4985 75efc3d397c6962954ec3c37b0f45c5f b118bb296d55bcd7d783a4b52b293a970b46728c pooler-20150608-git pooler.asd +portable-threads http://beta.quicklisp.org/archive/portable-threads/2019-03-07/portable-threads-20190307-git.tgz 31127 f5f5baa0847cce4910b0394e4157797a 0c062c9c6213d2566b7ebbdf9b09a6cd1448b473 portable-threads-20190307-git portable-threads.asd +portableaserve http://beta.quicklisp.org/archive/portableaserve/2019-08-13/portableaserve-20190813-git.tgz 586259 4cd7af3fbd45693800a823aff55fa442 dfd074e79bfd1d98385f2066a82dacf8b3f98bea portableaserve-20190813-git acl-compat/acl-compat.asd aserve/aserve.asd aserve/htmlgen/htmlgen.asd aserve/webactions/webactions.asd +positional-lambda http://beta.quicklisp.org/archive/positional-lambda/2012-10-13/positional-lambda-2.0.tgz 7250 1099a5457455b7c570132556073aa21f 7433ee7798c5bdbd6c2edd9869f5173d93178727 positional-lambda-2.0 positional-lambda.asd +postmodern http://beta.quicklisp.org/archive/postmodern/2019-12-27/postmodern-20191227-git.tgz 313862 67b909de432e6414e7832eed18f9ad18 6e54d9d2661bc600ff83abe2ea4ca8023bbbd6b5 postmodern-20191227-git cl-postgres.asd postmodern.asd s-sql.asd simple-date.asd +postmodernity http://beta.quicklisp.org/archive/postmodernity/2017-01-24/postmodernity-20170124-git.tgz 3251 9109aace9c9a906732eb0259a15274e0 380ce87aaceedd6aa00a2d94da9b4dfaa16ddd6a postmodernity-20170124-git postmodernity.asd +postoffice http://beta.quicklisp.org/archive/postoffice/2012-09-09/postoffice-20120909-git.tgz 36931 d09dd023aac099aba49bd3a485179a26 0e6aa7efb53da555f44a8b7caefff3dce1e7eaf3 postoffice-20120909-git postoffice.asd +pounds http://beta.quicklisp.org/archive/pounds/2016-02-08/pounds-20160208-git.tgz 22888 7690a4a5aaca79a60bbb5c49ac9ef1b2 b60ec9318d7017a982e95eae42a2a5c6844da2b7 pounds-20160208-git pounds.asd +pp-toml http://beta.quicklisp.org/archive/pp-toml/2018-02-28/pp-toml-20180228-git.tgz 10851 28f316d8f8309b0a56372e49dc0e7022 ea6b34bacc0556f7a67416f22b6bb9751461d16c pp-toml-20180228-git pp-toml-tests.asd pp-toml.asd +ppath http://beta.quicklisp.org/archive/ppath/2018-07-11/ppath-20180711-git.tgz 26911 bcfdda2ff1161721b98c2c1233434429 b93079de943fb4f9cf8ef0a3c2517ce4292b8cdc ppath-20180711-git ppath-test.asd ppath.asd +practical-cl http://beta.quicklisp.org/archive/practical-cl/2018-04-30/practical-cl-20180430-git.tgz 241556 6d0d20024a11897b190d9680fb067d79 462ef8018d44d307ae58197ff03d049ad9a0eff1 practical-cl-20180430-git practicals/Chapter03/pcl-simple-database.asd practicals/Chapter08/pcl-macro-utilities.asd practicals/Chapter09/pcl-test-framework.asd practicals/Chapter15/pcl-pathnames.asd practicals/Chapter23/pcl-spam.asd practicals/Chapter24/pcl-binary-data.asd practicals/Chapter25/pcl-id3v2.asd practicals/Chapter26/pcl-url-function.asd practicals/Chapter27/pcl-mp3-database.asd practicals/Chapter28/pcl-shoutcast.asd practicals/Chapter29/pcl-mp3-browser.asd practicals/Chapter31/pcl-html.asd practicals/practical-cl.asd +prbs http://beta.quicklisp.org/archive/prbs/2018-02-28/prbs-20180228-git.tgz 16327 6baec1bb244961320d1a034a30fdb89a c09a9e8fe05cea4dcc3b4573b33c5f517e4c566b prbs-20180228-git doc/prbs-docs.asd prbs.asd +prepl http://beta.quicklisp.org/archive/prepl/2018-10-18/prepl-20181018-git.tgz 24716 1da918018645e9ea8c291d66f55b9907 47ca4168a7d798f8369c037012bcc88befa094df prepl-20181018-git prepl.asd +pretty-function http://beta.quicklisp.org/archive/pretty-function/2013-06-15/pretty-function-20130615-git.tgz 6248 7b6ad93307bc8c8ec585a8199e5e9cb6 3eaf9baa4d31922b3adf8b04005393e7d054b4aa pretty-function-20130615-git pretty-function.asd +print-html http://beta.quicklisp.org/archive/print-html/2018-10-18/print-html-20181018-git.tgz 2917 c9f8962deb792e5dd82c3971bfdf3daa ec23887721f684f8cd6170676d7141df9c3b381b print-html-20181018-git print-html.asd +print-licenses http://beta.quicklisp.org/archive/print-licenses/2018-10-18/print-licenses-20181018-git.tgz 3079 fc2c8770ec8bc28f154f31fc247d47cd 8f76b7b3c94c29d916a1b31e07cc90f70c4a3737 print-licenses-20181018-git print-licenses.asd +printv http://beta.quicklisp.org/archive/printv/2014-07-14/printv-20140714-git.tgz 16113 049108fb64993d704fba006a1b7ce300 36b5b3188f22a39dafaa030219ccaa21c3b35e41 printv-20140714-git printv.asd +priority-queue http://beta.quicklisp.org/archive/priority-queue/2015-07-09/priority-queue-20150709-git.tgz 2535 5196d0b355b72215228de49eeb0df745 65644f0e3eb8bd23af1ffe64f856bbd9c4d1ac15 priority-queue-20150709-git priority-queue.asd +proc-parse http://beta.quicklisp.org/archive/proc-parse/2019-08-13/proc-parse-20190813-git.tgz 8695 99bdce79943071267c6a877d8de246c5 18fff39d2a228aeb60547154bb09745d2a8769e1 proc-parse-20190813-git proc-parse-test.asd proc-parse.asd +projectured http://beta.quicklisp.org/archive/projectured/2017-12-27/projectured-quicklisp-c3a60e76-git.tgz 3573436 501022101c0211a267b608c4615fdce0 3e002e0bc323ffa8a6495bdd42883027516f69c6 projectured-quicklisp-c3a60e76-git projectured.document.asd projectured.editor.asd projectured.executable.asd projectured.projection.asd projectured.sdl.asd projectured.sdl.test.asd projectured.swank.asd projectured.test.asd +prometheus.cl http://beta.quicklisp.org/archive/prometheus.cl/2019-10-07/prometheus.cl-20191007-git.tgz 26087 29af5bcaefc2787441403352a99f560c deba5912ebde30c75ba9bf35a0d8a3f808a3bda5 prometheus.cl-20191007-git prometheus.asd prometheus.collectors.process.asd prometheus.collectors.process.test.asd prometheus.collectors.sbcl.asd prometheus.collectors.sbcl.test.asd prometheus.examples.asd prometheus.exposers.hunchentoot.asd prometheus.exposers.hunchentoot.test.asd prometheus.formats.text.asd prometheus.formats.text.test.asd prometheus.pushgateway.asd prometheus.pushgateway.test.asd prometheus.test.all.asd prometheus.test.asd prometheus.test.support.asd +protest http://beta.quicklisp.org/archive/protest/2019-05-21/protest-20190521-git.tgz 68083 5ec1333564b4e27e54ea26efe2ed24f5 79619cbaac2f4dd3001536f5a32568718ad8b86e protest-20190521-git protest.asd +protobuf http://beta.quicklisp.org/archive/protobuf/2018-12-10/protobuf-20181210-git.tgz 64058 cdb5d92efc02b32f45febe83a1406490 db202763305822fc9736c145bcf869501b942520 protobuf-20181210-git protobuf.asd varint/varint-test.asd varint/varint.asd +prove http://beta.quicklisp.org/archive/prove/2017-11-30/prove-20171130-git.tgz 878875 630df4367537f799570be40242f8ed52 67eba1cb93bce0eb45d6ff02396eec04a3f439a6 prove-20171130-git cl-test-more.asd prove-asdf.asd prove-test.asd prove.asd +pseudonyms http://beta.quicklisp.org/archive/pseudonyms/2016-08-25/pseudonyms-20160825-git.tgz 4072 bbbea2ee21987734173b3ccf9db62015 3e255b706b3ae8d812a1d245eebfbae97d3c0a1e pseudonyms-20160825-git pseudonyms.asd +psgraph http://beta.quicklisp.org/archive/psgraph/2010-10-06/psgraph-1.2.tgz 8448 df735b2f6c45e14ea18c16650ad8e90d 1cb75fe9886dd39bc7dbdd92c5e4a0b7e229218a psgraph-1.2 psgraph.asd +psychiq http://beta.quicklisp.org/archive/psychiq/2018-02-28/psychiq-20180228-git.tgz 17573 d07eb5632c0c15ddeff1fde9ae860fa8 40d40d7d1c06fc1c5add607cf4d12af0e89e54a6 psychiq-20180228-git psychiq-test.asd psychiq.asd +ptester http://beta.quicklisp.org/archive/ptester/2016-09-29/ptester-20160929-git.tgz 12713 938a4366b6608ae5c4a0be9da11a61d4 c32afa4c3f143967eddf4ace14f3e15429610f7f ptester-20160929-git ptester.asd +puri http://beta.quicklisp.org/archive/puri/2018-02-28/puri-20180228-git.tgz 30002 0c43ad5d862ed0d18ef84d8e2a42f67f 79053c86ebabe7ec8aab7ef175e13c9f3a9f0960 puri-20180228-git puri.asd +purl http://beta.quicklisp.org/archive/purl/2016-09-29/purl-20160929-git.tgz 32297 ab5d05fcdd2b09d143ebc4e332b4058b 7ce1d37badf30b8386747f26d330b0432d2be4a1 purl-20160929-git purl.asd +py-configparser http://beta.quicklisp.org/archive/py-configparser/2017-08-30/py-configparser-20170830-svn.tgz 8452 b6a9fc2a9c70760d6683cafe656f9e90 256cf7e56d08aa7021f8c0739f0f6a2912780c1c py-configparser-20170830-svn py-configparser.asd +py4cl http://beta.quicklisp.org/archive/py4cl/2019-11-30/py4cl-20191130-git.tgz 615487 9d06ef58a7c9dc8ea406f57cdc07fb57 e2d470b9e7b80f447aa298550d99e68da16bed8d py4cl-20191130-git py4cl.asd +pythonic-string-reader http://beta.quicklisp.org/archive/pythonic-string-reader/2018-07-11/pythonic-string-reader-20180711-git.tgz 3594 8156636895b1148fad6e7bcedeb6b556 084f20b11e986f7f186f5f8744ce0e77c2065129 pythonic-string-reader-20180711-git pythonic-string-reader.asd +pzmq http://beta.quicklisp.org/archive/pzmq/2019-07-10/pzmq-20190710-git.tgz 20467 89e152691e331d660cd8861f8fee643d d617f4420e5c3f81c388786fbc4253cf10a9c8cd pzmq-20190710-git pzmq.asd +qbase64 http://beta.quicklisp.org/archive/qbase64/2019-11-30/qbase64-20191130-git.tgz 15721 32b03aa1b3c5ca4c49f586b4028cae5e 310210d449dd016d0b141a2f36ee68fa4c3d3979 qbase64-20191130-git qbase64.asd +qbook http://beta.quicklisp.org/archive/qbook/2013-03-12/qbook-20130312-darcs.tgz 12971 6e1cc023c21340d4884da27ce1a1df39 872d11a845287195e88e3fd1d3045a0c471e5698 qbook-20130312-darcs qbook.asd +ql-checkout http://beta.quicklisp.org/archive/ql-checkout/2019-05-21/ql-checkout-20190521-git.tgz 4290 e2b0b29b3829a67a6f88aab932b68e5f c3cf51de9f3c2a6155d838e5645363be4c596dd4 ql-checkout-20190521-git ql-checkout.asd +qlot http://beta.quicklisp.org/archive/qlot/2019-12-27/qlot-20191227-git.tgz 32386 20e2f6505eae2ccf98fc80f8624828e5 dbf0702831311a6ccb28975e1b64bba820e9e06b qlot-20191227-git qlot.asd +qmynd http://beta.quicklisp.org/archive/qmynd/2019-07-10/qmynd-20190710-git.tgz 48872 c4a230ca44c5c037664979dfd48985a9 2a43db7117073bc830ad419da96a5e60cb1d2a89 qmynd-20190710-git qmynd.asd tests/qmynd-test.asd +qt-libs http://beta.quicklisp.org/archive/qt-libs/2019-11-30/qt-libs-20191130-git.tgz 52709 8f92957d0b15b9a594924e3900c83c84 5dd81781a20ddf0ec0420308a2a8739def91ab62 qt-libs-20191130-git qt-lib-generator.asd qt-libs.asd systems/commonqt.asd systems/phonon.asd systems/qimageblitz.asd systems/qsci.asd systems/qt3support.asd systems/qtcore.asd systems/qtdbus.asd systems/qtdeclarative.asd systems/qtgui.asd systems/qthelp.asd systems/qtnetwork.asd systems/qtopengl.asd systems/qtscript.asd systems/qtsql.asd systems/qtsvg.asd systems/qttest.asd systems/qtuitools.asd systems/qtwebkit.asd systems/qtxml.asd systems/qtxmlpatterns.asd systems/qwt.asd systems/smokebase.asd +qtools http://beta.quicklisp.org/archive/qtools/2019-11-30/qtools-20191130-git.tgz 196923 450ea3932742e538d88583e51183d4f3 3bfae2c01582df632f6c3698af7f7ceeae27c0bf qtools-20191130-git examples/evaluator/qtools-evaluator.asd examples/game/qtools-game.asd examples/helloworld/qtools-helloworld.asd examples/melody/qtools-melody.asd examples/opengl/qtools-opengl.asd examples/titter/qtools-titter.asd q+.asd qtools.asd +qtools-ui http://beta.quicklisp.org/archive/qtools-ui/2019-07-10/qtools-ui-20190710-git.tgz 65416 e01a0e6a18e80b5fdd7ce862021f39c7 051d22af68720a01751d34a65caf6f12b5a30bf8 qtools-ui-20190710-git qtools-ui-base.asd qtools-ui-bytearray.asd qtools-ui-cell.asd qtools-ui-color-history.asd qtools-ui-color-picker.asd qtools-ui-color-sliders.asd qtools-ui-color-triangle.asd qtools-ui-compass.asd qtools-ui-container.asd qtools-ui-debugger.asd qtools-ui-dialog.asd qtools-ui-dictionary.asd qtools-ui-drag-and-drop.asd qtools-ui-executable.asd qtools-ui-fixed-qtextedit.asd qtools-ui-flow-layout.asd qtools-ui-helpers.asd qtools-ui-imagetools.asd qtools-ui-keychord-editor.asd qtools-ui-layout.asd qtools-ui-listing.asd qtools-ui-notification.asd qtools-ui-options.asd qtools-ui-panels.asd qtools-ui-placeholder-text-edit.asd qtools-ui-plot.asd qtools-ui-progress-bar.asd qtools-ui-repl.asd qtools-ui-slider.asd qtools-ui-spellchecked-text-edit.asd qtools-ui-splitter.asd qtools-ui-svgtools.asd qtools-ui.asd +quadtree http://beta.quicklisp.org/archive/quadtree/2015-07-09/quadtree-20150709-git.tgz 3869 50ff5dc28ea35f3073946739537f039d 7961bb58a4a4e50008d5398fbb1ae71380e36248 quadtree-20150709-git quadtree-test.asd quadtree.asd +quantile-estimator.cl http://beta.quicklisp.org/archive/quantile-estimator.cl/2016-08-25/quantile-estimator.cl-20160825-git.tgz 3510 3a28f05e4466c714f712d31cc190992c 30796c8194de9b436e022a35aa5973db986fbd05 quantile-estimator.cl-20160825-git quantile-estimator.asd quantile-estimator.test.asd +quasiquote-2.0 http://beta.quicklisp.org/archive/quasiquote-2.0/2015-05-05/quasiquote-2.0-20150505-git.tgz 8956 7c557e0c10cf7608afa5a20e4a83c778 5f61d74c96a9a863f38ab56c08b5287187bd9ef7 quasiquote-2.0-20150505-git quasiquote-2.0.asd +queen.lisp http://beta.quicklisp.org/archive/queen.lisp/2016-09-29/queen.lisp-20160929-git.tgz 22553 2e7c68441e99d826cfb2c7cb9aa83766 f7988f650dfc560c49226e848de326b9d69da068 queen.lisp-20160929-git queen.asd +query-fs http://beta.quicklisp.org/archive/query-fs/2019-05-21/query-fs-20190521-git.tgz 270327 1108c91b69007c6ab35b42d70d4dd7a2 97649ef86497ee0f029b8e5522769937f86b75fe query-fs-20190521-git query-fs.asd +queues http://beta.quicklisp.org/archive/queues/2017-01-24/queues-20170124-git.tgz 8748 9b291db09b7385e12515697f1f918e27 3835c55c8a7010b35d4b2ef2e9ce54845ca564bc queues-20170124-git queues.asd queues.priority-cqueue.asd queues.priority-queue.asd queues.simple-cqueue.asd queues.simple-queue.asd +quickapp http://beta.quicklisp.org/archive/quickapp/2016-08-25/quickapp-20160825-git.tgz 7116 f7c00d1217d7b58f6f1f023668580891 2f4eff6c45eca224463eb0a32eacfd5e34513f0f quickapp-20160825-git quickapp.asd +quicklisp-slime-helper http://beta.quicklisp.org/archive/quicklisp-slime-helper/2015-07-09/quicklisp-slime-helper-20150709-git.tgz 2211 08a86772cfee1a9dc7b1d4a9bb7d371e 6abe815efe3a1b03cb485d4d95329188b1100fe5 quicklisp-slime-helper-20150709-git quicklisp-slime-helper.asd +quickproject http://beta.quicklisp.org/archive/quickproject/2019-12-27/quickproject-1.4.1.tgz 6777 1d582d9dc066e0904f716166e448ccb7 eefaabe524fb4113b7b785f623899e417bed7d72 quickproject-1.4.1 quickproject.asd +quicksearch http://beta.quicklisp.org/archive/quicksearch/2017-10-19/quicksearch-20171019-git.tgz 13482 b64e3f756d4edafe270499058b087c26 8984719946dc05f5ad03063265e1fbc1e9986516 quicksearch-20171019-git quicksearch.asd +quickutil http://beta.quicklisp.org/archive/quickutil/2019-07-10/quickutil-20190710-git.tgz 1508394 fe9b44ce90e259c90c346f4005c1d9da 34629c942ff3f21b3746c0e6573077538bc0884f quickutil-20190710-git quickutil-client/quickutil-client-management.asd quickutil-client/quickutil-client.asd quickutil-client/quickutil.asd quickutil-server/quickutil-server.asd quickutil-utilities/quickutil-utilities-test.asd quickutil-utilities/quickutil-utilities.asd +quilc http://beta.quicklisp.org/archive/quilc/2019-12-27/quilc-v1.15.2.tgz 1184464 0ed9400a58a1c6b489a16f0269977311 7df7aa30ceb984a9d40807fb9e90d4271b327f78 quilc-v1.15.2 boondoggle/boondoggle-tests.asd boondoggle/boondoggle.asd cl-quil-benchmarking.asd cl-quil-tests.asd cl-quil.asd quilc-tests.asd quilc.asd +quri http://beta.quicklisp.org/archive/quri/2019-11-30/quri-20191130-git.tgz 69725 4a3e8d2ebe459ea731738650c2c5bf56 58c4d571f700fceb9a67ea6dc52ae739a26aaacd quri-20191130-git quri-test.asd quri.asd +quux-hunchentoot http://beta.quicklisp.org/archive/quux-hunchentoot/2018-04-30/quux-hunchentoot-20180430-git.tgz 4627 e767f34d08e5da1a98cf99ce6cacc99a 852c396d028964a975034ecf372454edb86a7f7d quux-hunchentoot-20180430-git quux-hunchentoot.asd +quux-time http://beta.quicklisp.org/archive/quux-time/2015-04-07/quux-time-20150407-git.tgz 34282 f89bd972e19dd2fd5abae2a9e8b143e2 51b24561e194e32110bbb5a6e6be5d98c6daac8c quux-time-20150407-git quux-time.asd +qvm http://beta.quicklisp.org/archive/qvm/2019-12-27/qvm-v1.15.2.tgz 355327 3dba4c207c58efd91b2d4662f1b7500a d24bb7ab705921df3b81f9f15c5f93addeac9fab qvm-v1.15.2 qvm-app-ng-tests.asd qvm-app-ng.asd qvm-app-tests.asd qvm-app.asd qvm-benchmarks.asd qvm-examples.asd qvm-tests.asd qvm.asd +racer http://beta.quicklisp.org/archive/racer/2019-07-10/racer-20190710-git.tgz 28462787 ecc163e4033836e93aaeb3990052fe3a f27637cb6f310019ad45377016535f15b1cbffdf racer-20190710-git clients/lracer/lracer.asd racer.asd +random http://beta.quicklisp.org/archive/random/2019-10-07/random-20191007-git.tgz 4620 13a609118dd74e217fafd018875b8366 9c3214946a660c5edc558c2f592ff70994c3df65 random-20191007-git acm-random-test.asd acm-random.asd random-test.asd random.asd +random-access-lists http://beta.quicklisp.org/archive/random-access-lists/2012-02-08/random-access-lists-20120208-git.tgz 4903 36e5b00c2556ffda4cc2d6297471d053 7f2fe5a0f6497a98b538bfed7fa0dea7c3c3d8cc random-access-lists-20120208-git random-access-lists.asd +random-sample http://beta.quicklisp.org/archive/random-sample/2018-07-11/random-sample-20180711-git.tgz 3416 c849823d61c7dc3c8ef9d4cea595391c 177806586fbe0d70144af9ee41144dc63ee687cf random-sample-20180711-git random-sample.asd +random-state http://beta.quicklisp.org/archive/random-state/2019-07-10/random-state-20190710-git.tgz 10759 c958cd6015c6ed0b3cd44283ed68dc08 cadf3310ad0f61167972ccb5b5ce71020a278e5d random-state-20190710-git random-state-viewer.asd random-state.asd +rate-monotonic http://beta.quicklisp.org/archive/rate-monotonic/2017-01-24/rate-monotonic-20170124-git.tgz 16931 40d28ad246c2fa1d84a1fe68fac0c74b c6198a314738cd44a2b9fdcf62037591b6d86d87 rate-monotonic-20170124-git rate-monotonic.asd rate-monotonic.examples.asd +ratify http://beta.quicklisp.org/archive/ratify/2019-10-07/ratify-20191007-git.tgz 30103 bb3371f343c1cfd75b6cc4ea6f2e7cc1 c4e33d368e883efdb66356afd4cffc0c6593bedf ratify-20191007-git ratify.asd +rcl http://beta.quicklisp.org/archive/rcl/2016-08-25/rcl-20160825-http.tgz 32780 c270ce4a4b2dcc12ac7c793c26a583d1 5e7494f2d3ddd826afc6f3211228e8acadecf123 rcl-20160825-http rcl.asd +re http://beta.quicklisp.org/archive/re/2019-10-07/re-20191007-git.tgz 8683 2dd52d733bdbcd7df45350dc0b9b143e babd0e0648cbeeb36f9d956f5fee45af694b9813 re-20191007-git re.asd +read-csv http://beta.quicklisp.org/archive/read-csv/2018-10-18/read-csv-20181018-git.tgz 4924 ef21abc13722ff1ede9f72951bd725af ac27005e51ff658b0b28665fefc260b812032802 read-csv-20181018-git read-csv.asd +read-number http://beta.quicklisp.org/archive/read-number/2019-05-21/read-number-20190521-git.tgz 7986 928e06ed46fb67f216f7299c8c1dfdf5 962d8a2d2f14748ab3e8d28cbd4131c2bcfdaf1d read-number-20190521-git read-number.asd +reader http://beta.quicklisp.org/archive/reader/2019-12-27/reader-20191227-git.tgz 5859 a1317a75a040760375d7ba7b2ab30a90 7335959482977c87f70843a4bd6e65a657299d32 reader-20191227-git reader-test.asd reader.asd +reader-interception http://beta.quicklisp.org/archive/reader-interception/2015-06-08/reader-interception-20150608-git.tgz 5162 8bb17a9cb708c842cb9cac112bd2d7b7 b8319c2a038be121cf1cc5ac493e876880d52ea2 reader-interception-20150608-git reader-interception-test.asd reader-interception.asd +rectangle-packing http://beta.quicklisp.org/archive/rectangle-packing/2013-06-15/rectangle-packing-20130615-git.tgz 16507 98a4a3e3a1daf65b56475e1f850ca0a7 08ed9778cc20bb058a54e1db28fbbdeb75c929ba rectangle-packing-20130615-git rectangle-packing.asd +recur http://beta.quicklisp.org/archive/recur/2019-03-07/recur-20190307-hg.tgz 1485 c29fa990323309c17e98cc7eadd2b31d edc298a910d5c737937aed72f66f7d484a55485a recur-20190307-hg recur.asd +recursive-regex http://beta.quicklisp.org/archive/recursive-regex/2012-04-07/recursive-regex-20120407-git.tgz 11763 fefa07fe68a4a99338900a7be78129b3 4a09f21c6e6daf510dc1570431ed4ddd40716815 recursive-regex-20120407-git recursive-regex.asd +recursive-restart http://beta.quicklisp.org/archive/recursive-restart/2016-10-31/recursive-restart-20161031-git.tgz 3054 39d5c3ca334229dd5f5111a6f993d8a0 cf91a8a01feb4efbf8ce3d7cd74e34b224a90faf recursive-restart-20161031-git recursive-restart.asd +redirect-stream http://beta.quicklisp.org/archive/redirect-stream/2019-07-10/redirect-stream-20190710-git.tgz 3914 3dbcdaad096f9ba1e308a351fce12744 14dcc7ff3bd776e2b391fa7f74a17b089b975c17 redirect-stream-20190710-git redirect-stream.asd +regex http://beta.quicklisp.org/archive/regex/2012-09-09/regex-20120909-git.tgz 30204 545d10011ea7d33cea0dfcb238acf94b 9ab918df7063e4aac22c3cb0a4776529747cf080 regex-20120909-git regex.asd +regular-type-expression http://beta.quicklisp.org/archive/regular-type-expression/2019-07-10/regular-type-expression-export-to-quicklisp-6a781b1f-git.tgz 2650721 c8f2228509c4b6f33df8a528759963a0 1eda28066cf0b186c1dd282376169b833a1e258b regular-type-expression-export-to-quicklisp-6a781b1f-git 2d-array/2d-array-test.asd 2d-array/2d-array.asd adjuvant/adjuvant-test.asd adjuvant/adjuvant.asd cl-robdd/cl-robdd-analysis-test.asd cl-robdd/cl-robdd-analysis.asd cl-robdd/cl-robdd-test.asd cl-robdd/cl-robdd.asd dispatch/dispatch-test.asd dispatch/dispatch.asd lisp-types/lisp-types-analysis.asd lisp-types/lisp-types-test.asd lisp-types/lisp-types.asd ndfa/ndfa-test.asd ndfa/ndfa.asd research.asd rte-regexp/rte-regexp-test.asd rte-regexp/rte-regexp.asd rte/rte-test.asd rte/rte.asd scrutiny/scrutiny-test.asd scrutiny/scrutiny.asd +remote-js http://beta.quicklisp.org/archive/remote-js/2019-07-10/remote-js-20190710-git.tgz 4434 fcc3b2e4201c1ad11ec8575a98bce39e 0a623b75ed970fe8e5f9d5572c4bf1bccbcf3ec5 remote-js-20190710-git remote-js-test.asd remote-js.asd +repl-utilities http://beta.quicklisp.org/archive/repl-utilities/2015-06-08/repl-utilities-20150608-git.tgz 11278 2299800cecc045af21fd3ac692138972 7a3098268b3a68781d537beba29d8cea39b56c9c repl-utilities-20150608-git repl-utilities.asd +replic http://beta.quicklisp.org/archive/replic/2019-11-30/replic-20191130-git.tgz 18002 da5c97326b1ccf7fce0704d2d29093f7 a8a44bea8976745fb2903a1e6deaf933495fdd41 replic-20191130-git replic-test.asd replic.asd +restas http://beta.quicklisp.org/archive/restas/2019-10-08/restas-20191008-git.tgz 182787 ceec9a0482460e2ad32446d43623480b cec4ae81730d0f741cdf3a436750a564de2c9d31 restas-20191008-git docs/restas-doc.asd restas.asd +restas-directory-publisher http://beta.quicklisp.org/archive/restas-directory-publisher/2013-01-28/restas-directory-publisher-20130128-git.tgz 13313 ac714dd7b907eebaa428fc411fce7434 112f0d8f6aa05b4e4a3fbae8131c1dd20f05a1cf restas-directory-publisher-20130128-git restas-directory-publisher.asd +restas.file-publisher http://beta.quicklisp.org/archive/restas.file-publisher/2012-01-07/restas.file-publisher-20120107-git.tgz 1176 74b3636315653b08c83747b8a45796d5 48bd0eb451bc218675ba47a64240d261a8cd5d4f restas.file-publisher-20120107-git restas.file-publisher.asd +restful http://beta.quicklisp.org/archive/restful/2015-06-08/restful-20150608-git.tgz 12311 fb8e34eba9a82fcd8351eb16dd908176 aebeed541ff77427483632265e4f0dda44c62669 restful-20150608-git restful-test.asd restful.asd +restricted-functions http://beta.quicklisp.org/archive/restricted-functions/2019-05-21/restricted-functions-20190521-git.tgz 6700 0ae3b25b8fa92ea9d625cae324ec445f 7e47bc6d54ff68ec0d0e65f34c635a3b6f9d9d10 restricted-functions-20190521-git code/restricted-functions.asd +retrospectiff http://beta.quicklisp.org/archive/retrospectiff/2017-10-19/retrospectiff-20171019-git.tgz 1460413 44c765984cd9dd0ecbb1bec8c78a3301 c9dce8ca0e8f0b738508d592b3c73d75e7ee4558 retrospectiff-20171019-git retrospectiff.asd +reversi http://beta.quicklisp.org/archive/reversi/2015-09-23/reversi-20150923-git.tgz 99958 b67728e66d479acb1a77983793092508 d6e3723c7a48943f49cff79f129812c76304da66 reversi-20150923-git reversi.asd +rfc2109 http://beta.quicklisp.org/archive/rfc2109/2015-12-18/rfc2109-20151218-darcs.tgz 29102 ca039ac430baaed87f08a1a01e4cfe91 8cfa85913f22053a81c691d8eb8309aa6e9eeeb6 rfc2109-20151218-darcs rfc2109.asd +rfc2388 http://beta.quicklisp.org/archive/rfc2388/2018-08-31/rfc2388-20180831-git.tgz 12522 f57e3c588e5e08210516260e67d69226 b9fce4ee84e60426fc9ef11f1847235b13dd256e rfc2388-20180831-git rfc2388.asd +rfc2388-binary http://beta.quicklisp.org/archive/rfc2388-binary/2017-01-24/rfc2388-binary-20170124-darcs.tgz 98374 0f0e4796ce5b4c0d30aee6f87ecf13d5 4ea6b34d653445314332dce88e4792b8332004f0 rfc2388-binary-20170124-darcs rfc2388-binary.asd +rfc3339-timestamp http://beta.quicklisp.org/archive/rfc3339-timestamp/2015-06-08/rfc3339-timestamp-20150608-git.tgz 5146 91a8159c603749a20e58847d0e4e78b2 57056b5fc5efb1d046f18e23eebf52d3b85fc1f0 rfc3339-timestamp-20150608-git rfc3339-timestamp-test.asd rfc3339-timestamp.asd +rlc http://beta.quicklisp.org/archive/rlc/2015-09-23/rlc-20150923-git.tgz 3997 b26fd533287f1033a7a2885a780c2318 e9d56b4078c5672498325308ae2898ab9dd9b797 rlc-20150923-git rlc.asd +roan http://beta.quicklisp.org/archive/roan/2019-11-30/roan-20191130-git.tgz 1135925 83b94f712f002f551ea85247bc11c71f b4f7339ccb26e26b3bea9bbc05634933131b2772 roan-20191130-git roan.asd +rock http://beta.quicklisp.org/archive/rock/2015-06-08/rock-20150608-git.tgz 9855 e54b64ba4d201d559355eb6bdb8e9d34 fcbcdd37d9cf8de9ae4c8b392ab7de632f58bdd9 rock-20150608-git rock-test.asd rock-web.asd rock.asd +romreader http://beta.quicklisp.org/archive/romreader/2014-07-13/romreader-20140713-git.tgz 6533 1e7c5f085d2495bd7a131b479b85ca8b 4133137ffba648f72739f0faa56b79b8bb48ec3a romreader-20140713-git romreader.asd +rove http://beta.quicklisp.org/archive/rove/2019-10-07/rove-20191007-git.tgz 14893 7ce5d3b0b423f8b68665bbcc51cf18a1 543f9a7bbc581ed2403309a944ee3b3fc28a2e1d rove-20191007-git rove.asd +rpc4cl http://beta.quicklisp.org/archive/rpc4cl/2015-06-08/rpc4cl-20150608-git.tgz 13071 75c4f8ed74f2688decbc26eb3c5094c8 a56e162d114af1ee168b08db47fe208db5fc7603 rpc4cl-20150608-git rpc4cl-test.asd rpc4cl.asd +rpcq http://beta.quicklisp.org/archive/rpcq/2019-12-27/rpcq-v3.0.0.tgz 79254 7e7cd7ebfe29c600984b967ad255fdba 1e59f7652c2a6edf42e087784c3577745dce910c rpcq-v3.0.0 rpcq-tests.asd rpcq.asd +rpm http://beta.quicklisp.org/archive/rpm/2016-04-21/rpm-20160421-git.tgz 4835 3c60f17576cb2c22554fff9b0eec2796 15eb5b24e92715d7e25605acd314702178122486 rpm-20160421-git rpm.asd +rt http://beta.quicklisp.org/archive/rt/2010-10-06/rt-20101006-git.tgz 10676 94a56c473399572ca835ac91c77c04e5 80643f045a1ff7313d55db64a3f6787236f68eff rt-20101006-git rt.asd +rt-events http://beta.quicklisp.org/archive/rt-events/2016-03-18/rt-events-20160318-git.tgz 5518 c9c0de2cafffd8319bc6f8a9ee9c4908 86aabf4057d784d88d938890ca0273ff1dba31f6 rt-events-20160318-git rt-events.asd rt-events.examples.asd +rtg-math http://beta.quicklisp.org/archive/rtg-math/2019-10-07/rtg-math-release-quicklisp-29fc5b3d-git.tgz 94423 fefa73c6923964666ecc8a8c382df718 2ce1482195edd95a831dd09c37f959277cb1a2e5 rtg-math-release-quicklisp-29fc5b3d-git rtg-math.asd rtg-math.vari.asd +rucksack http://beta.quicklisp.org/archive/rucksack/2015-06-08/rucksack-20150608-git.tgz 111832 e968c9e90632cbba892dae1e2833efe3 3e3ec1762970a3ad7df8d87afdae2bd80ab27af0 rucksack-20150608-git rucksack.asd tests/rucksack-test.asd +rutils http://beta.quicklisp.org/archive/rutils/2019-11-30/rutils-20191130-git.tgz 170325 11551d0709dbeeee44c4aa377e6471f2 3ce11df6da71853198327e4a0c524d56f8bdea54 rutils-20191130-git rutils-test.asd rutils.asd rutilsx.asd +ryeboy http://beta.quicklisp.org/archive/ryeboy/2015-03-02/ryeboy-20150302-git.tgz 9381 509436a25df82c2408d68db308650957 49bf72d638ae2a5485294e753cae73eadc9a1323 ryeboy-20150302-git ryeboy.asd +s-base64 http://beta.quicklisp.org/archive/s-base64/2013-01-28/s-base64-20130128-git.tgz 7033 9c4220053ea4b18fca7a49f29aae0ee1 70c7fc4ed0762db40bc6e0e71f36f358a2c6cb9a s-base64-20130128-git s-base64.asd +s-dot2 http://beta.quicklisp.org/archive/s-dot2/2018-10-18/s-dot2-20181018-git.tgz 6015 2f0d0948c7ab66c0fb75a761f113b9e9 bb3d07b3bc6c9803b97c65aa3dbc1f69cc187299 s-dot2-20181018-git s-dot2.asd +s-http-client http://beta.quicklisp.org/archive/s-http-client/2015-10-31/s-http-client-20151031-git.tgz 10204 be5c11bdc2c80fcc100230c352476d92 3ce9ade130aaf5b304573d6c73c8f47706030341 s-http-client-20151031-git s-http-client.asd +s-http-server http://beta.quicklisp.org/archive/s-http-server/2013-01-28/s-http-server-20130128-git.tgz 25877 c394b2543bbc48895794fe332adba23d f3ac20bd1203ab639ae397746c9904c722a63f88 s-http-server-20130128-git s-http-server.asd +s-protobuf http://beta.quicklisp.org/archive/s-protobuf/2015-12-18/s-protobuf-20151218-git.tgz 22278 99af6c044952679ad08513f945c59c4f 2835943d57cac223243d9638260fbcc252321481 s-protobuf-20151218-git src/s-protobuf.asd +s-sysdeps http://beta.quicklisp.org/archive/s-sysdeps/2013-01-28/s-sysdeps-20130128-git.tgz 6002 2fe61fadafd62ef9597e17b4783889ef 455bdf64e9ce28f99bda8dc20202cbcdc8015424 s-sysdeps-20130128-git s-sysdeps.asd +s-utils http://beta.quicklisp.org/archive/s-utils/2013-01-28/s-utils-20130128-git.tgz 5511 50d0bada77503606b9ec7dc1b4318a71 0f8314edbd003064faf03c56ee957ed6690927cd s-utils-20130128-git s-utils.asd +s-xml http://beta.quicklisp.org/archive/s-xml/2015-06-08/s-xml-20150608-git.tgz 21248 9c31c80f0661777c493fab683f776716 03cb87aacf1c44877a76572510df60c563727125 s-xml-20150608-git s-xml.asd +s-xml-rpc http://beta.quicklisp.org/archive/s-xml-rpc/2019-05-21/s-xml-rpc-20190521-git.tgz 23981 33c268048222002af4d6232d71ee7222 d8b595ab60be528be3848eaf64d3b9a77fc62319 s-xml-rpc-20190521-git s-xml-rpc.asd +safe-queue http://beta.quicklisp.org/archive/safe-queue/2016-04-21/safe-queue-20160421-git.tgz 3667 211b677bc15a7ac3ce6e88ee7f89d970 13efd7ab3e541ba00a86cfc774fffa702f9ac3d9 safe-queue-20160421-git safe-queue.asd +safe-read http://beta.quicklisp.org/archive/safe-read/2018-10-18/safe-read-20181018-git.tgz 5487 54bd985ab5f3ad1d30a2a53f1da03410 c93d1baf7f8499a0383f8ae38a5a01bb36542801 safe-read-20181018-git safe-read.asd +safety-params http://beta.quicklisp.org/archive/safety-params/2019-02-02/safety-params-20190202-git.tgz 7110 44bdeb52d69878bf67ecf413613538cb 3380fbb899e4130dbc98475d1803f733245e54e5 safety-params-20190202-git safety-params.asd +salza2 http://beta.quicklisp.org/archive/salza2/2013-07-20/salza2-2.0.9.tgz 15525 e62383de435081c0f1f888ec363bb32c 7f2eecaa9582bbedf7278fcf77bf46c9c5474f5b salza2-2.0.9 salza2.asd +sandalphon.lambda-list http://beta.quicklisp.org/archive/sandalphon.lambda-list/2018-07-11/sandalphon.lambda-list-20180711-git.tgz 11120 6b75d6bcd35d610abb1278547266246f 49223fc82d7af2364aba90b495442be3153b4494 sandalphon.lambda-list-20180711-git sandalphon.lambda-list.asd +sanity-clause http://beta.quicklisp.org/archive/sanity-clause/2019-11-30/sanity-clause-20191130-git.tgz 34489 5fadf7e610de59840d1208f80d767efd 1d64f5903d202b95dce700a1d4867e5b48217d2d sanity-clause-20191130-git sanity-clause.asd +sapaclisp http://beta.quicklisp.org/archive/sapaclisp/2012-05-20/sapaclisp-1.0a.tgz 141501 5a9d213d0063de0cc1ef9fd3aea811ca 2f3bbe44b16bc0bdc6c29be6f00312e9372f61cb sapaclisp-1.0a sapaclisp.asd +sb-cga http://beta.quicklisp.org/archive/sb-cga/2017-12-27/sb-cga-20171227-git.tgz 34033 46f69ae11e29b16a8da92965bddeb0e3 e59084d49f3a915c0cde0793f74ab68073ac948e sb-cga-20171227-git sb-cga.asd +sb-fastcgi http://beta.quicklisp.org/archive/sb-fastcgi/2019-12-27/sb-fastcgi-20191227-git.tgz 3835 b2f177181308a88dd65909d60e85d755 bbc4710baadd2d3bf61cac73fbefba83df0e5990 sb-fastcgi-20191227-git sb-fastcgi.asd +sb-vector-io http://beta.quicklisp.org/archive/sb-vector-io/2011-08-29/sb-vector-io-20110829-git.tgz 5263 a57684e11ed481a7c4cf7f2623942e49 15faae433ceb327a16f5bcf29cdcd7728a5c1aca sb-vector-io-20110829-git sb-vector-io.asd +sc-extensions http://beta.quicklisp.org/archive/sc-extensions/2019-11-30/sc-extensions-20191130-git.tgz 8141 b929525a11725794c55b86dfdb6798c7 14a000be3e6b719a491ff9ce2ee376cdb2d33538 sc-extensions-20191130-git sc-extensions.asd +scalpl http://beta.quicklisp.org/archive/scalpl/2019-12-27/scalpl-20191227-git.tgz 50929 0187001e6d53616d588fa0dc385c6e83 eee08d1d92f743f59496f96201c2155bf6c4fd5e scalpl-20191227-git scalpl.asd +screamer http://beta.quicklisp.org/archive/screamer/2019-07-10/screamer-20190710-git.tgz 953872 6eb822a63c82ed6007f2c1f662005f1f 15d7e15f78b9d23db8da9efa3ae260a17a3038e4 screamer-20190710-git screamer-tests.asd screamer.asd +scriba http://beta.quicklisp.org/archive/scriba/2015-12-18/scriba-20151218-git.tgz 33936 867dbaf3a2660a23f29d27e5633abd94 4e79592dfc97bb7997c32696439706dabe16d4d5 scriba-20151218-git scriba-test.asd scriba.asd +scribble http://beta.quicklisp.org/archive/scribble/2016-06-28/scribble-20160628-git.tgz 15810 976a908f6bbe7ac8516a4916dd6cee20 e1e46a668bfda1cb2848b489176ea6d82d5800d7 scribble-20160628-git scribble.asd +scriptl http://beta.quicklisp.org/archive/scriptl/2018-02-28/scriptl-20180228-git.tgz 125271 37927d71784ccef1cdeb309272416d0a 3f940ab4a12dcbb23f78f2a3d8b33f3aaf454793 scriptl-20180228-git scriptl-examples.asd scriptl-util.asd scriptl.asd +sdl2-game-controller-db http://beta.quicklisp.org/archive/sdl2-game-controller-db/2018-02-28/sdl2-game-controller-db-release-quicklisp-335d2b68-git.tgz 7352 ad3ab5458419a5a259313807c8e0b181 770ccc1def893343b1d3ed5ad511b3537b5c7b02 sdl2-game-controller-db-release-quicklisp-335d2b68-git sdl2-game-controller-db.asd +sdl2kit http://beta.quicklisp.org/archive/sdl2kit/2017-11-30/sdl2kit-20171130-git.tgz 11804 906f93a606d1ff2ed8ed613a3fb2d553 0e077fd40e966e93f505a90a9027fe784dc8aaaf sdl2kit-20171130-git sdl2kit-examples.asd sdl2kit.asd +sealable-metaobjects http://beta.quicklisp.org/archive/sealable-metaobjects/2019-12-27/sealable-metaobjects-20191227-git.tgz 11693 89191336d30215431ee3c916974e5127 1acc25792468db5251863b324ac36e22628791ef sealable-metaobjects-20191227-git code/sealable-metaobjects.asd test-suite/sealable-metaobjects-test-suite.asd +secret-values http://beta.quicklisp.org/archive/secret-values/2017-10-19/secret-values-20171019-git.tgz 2590 02ce6929d8923975f7368470730be760 516f54287f35b7c90e82f64cf769502fd47ef8e2 secret-values-20171019-git secret-values.asd +secure-random http://beta.quicklisp.org/archive/secure-random/2016-02-08/secure-random-20160208-git.tgz 2912 ee57beb30d51da8b3969c27ca52fd0d7 5f5b15e224164c1658ed62532759761ba9c26ccc secure-random-20160208-git secure-random.asd +sel http://beta.quicklisp.org/archive/sel/2019-12-27/sel-20191227-git.tgz 1265692 843828381be7aa65b2ae07d9e5e78147 a2ec44c65fd2a5addb6656feb5b059d4568c5934 sel-20191227-git software-evolution-library.asd +select http://beta.quicklisp.org/archive/select/2019-10-07/select-20191007-git.tgz 271138 d5e63be051777d39e0d74791ab88e078 384cb66fd750ce8ae601f19502ab299dac85abbf select-20191007-git select.asd +semantic-spinneret http://beta.quicklisp.org/archive/semantic-spinneret/2017-08-30/semantic-spinneret-20170830-git.tgz 2079 3cdc958d8000f1e26f683aa30f0950cb afeea07a5ef5c41d6d90ba0c7b7dfbb9d9569e15 semantic-spinneret-20170830-git semantic-spinneret.asd +sequence-iterators http://beta.quicklisp.org/archive/sequence-iterators/2013-08-13/sequence-iterators-20130813-darcs.tgz 34899 a6b61a5e9026a03c4978f3721bb17632 7cab8da70f985eb5165aa2145e937a04c605e23c sequence-iterators-20130813-darcs extensible-sequences/extensible-sequences.asd sequence-iterators.asd +serapeum http://beta.quicklisp.org/archive/serapeum/2019-12-27/serapeum-20191227-git.tgz 188510 dabf40eb6c6af7509da66450790cbf4e c5c3041a39533725c8c1b0278dea67dbdddba8e9 serapeum-20191227-git serapeum.asd +serializable-object http://beta.quicklisp.org/archive/serializable-object/2019-12-27/serializable-object-20191227-git.tgz 22152 5035427309018750274ef7767cf2b2e7 bbdcb991e44ad56e18b3fc8e4873539b731a937e serializable-object-20191227-git serializable-object.asd serializable-object.test.asd +series http://beta.quicklisp.org/archive/series/2013-11-11/series-20131111-git.tgz 151865 396c160a736ad38829dce1db13a75bcc 6bf27684cdd5fae7ab739d954a72bfde7154bc67 series-20131111-git series.asd +session-token http://beta.quicklisp.org/archive/session-token/2014-11-06/session-token-20141106-git.tgz 3020 5e7727a5a92a8ca9b70304f47b6b52b6 713d1d511e522fe2bd1732e03b088ff062852e8f session-token-20141106-git session-token.asd +sexml http://beta.quicklisp.org/archive/sexml/2014-07-13/sexml-20140713-git.tgz 27508 f71d4ee8da885671be8b779266cd865a f4f482c546f955b9eb4f8c200cc5947528ae6b7e sexml-20140713-git contrib/sexml-objects/sexml-objects.asd sexml.asd +sha1 http://beta.quicklisp.org/archive/sha1/2018-10-18/sha1-20181018-git.tgz 3198 1e49b3c92abf33a84a4e7a18fafc6ec7 96078e0ee02b1811391c36d46356856606156c0a sha1-20181018-git sha1.asd +sha3 http://beta.quicklisp.org/archive/sha3/2018-02-28/sha3-20180228-git.tgz 17156 26078e9dcb90cc6d6e3174880c4514cb 6ba93591c151ee6b04f0aadfc5f93292ef238527 sha3-20180228-git sha3.asd +shadchen http://beta.quicklisp.org/archive/shadchen/2013-10-03/shadchen-20131003-git.tgz 11298 159f11f77ef2c1c2279e502213a97d43 751e9e27c0d249076ae7a14c275d22f5007c9f69 shadchen-20131003-git shadchen.asd +shadow http://beta.quicklisp.org/archive/shadow/2019-12-27/shadow-20191227-git.tgz 15478 bec5fb5889cfc6d91d0095c61a994457 200b818cf6aae5a86a4a7fe1d3d2e651eca11e63 shadow-20191227-git shadow.asd +sheeple http://beta.quicklisp.org/archive/sheeple/2015-03-02/sheeple-20150302-git.tgz 623383 3077aa64386b96c2aae8b42ea750503d b8c84650eb413b8c6187e5a8d0b8cb0de4217d0e sheeple-20150302-git sheeple.asd +shellpool http://beta.quicklisp.org/archive/shellpool/2015-05-05/shellpool-20150505-git.tgz 26021 5f8713d9dcfd08d3db2bce7ef3f6ed44 1d0065a166713f7e02493d3acdaf735cfcbd09cd shellpool-20150505-git shellpool.asd +shelly http://beta.quicklisp.org/archive/shelly/2014-11-06/shelly-20141106-git.tgz 18127 824938aaaac93602dc927a9734aa1581 2dc9eff9949e91277a0db6376a431b6992681d4b shelly-20141106-git shelly-test.asd shelly.asd +shorty http://beta.quicklisp.org/archive/shorty/2018-02-28/shorty-20180228-git.tgz 4280 4141a8fd8c22806935284b312bdbae6f 38a21fee651b92c319e4d00215d84f01138557fc shorty-20180228-git shorty.asd +should-test http://beta.quicklisp.org/archive/should-test/2019-10-07/should-test-20191007-git.tgz 7618 f27c9a9c25be4f67204f7c3dccde755f 32aeafca31add71fa61077717e5e5e932033f85f should-test-20191007-git should-test.asd +shuffletron http://beta.quicklisp.org/archive/shuffletron/2018-10-18/shuffletron-20181018-git.tgz 125912 ffa1e84964f41af31bbb853d0b0776a9 7a8f2aaf66cd8978094dacd5e92242dc859deca7 shuffletron-20181018-git shuffletron.asd +simple-actors http://beta.quicklisp.org/archive/simple-actors/2019-07-10/simple-actors-20190710-git.tgz 4857 449f12288ea6f0bb441bc93936283bb1 3403542e34ca9033faf5935ce4c894e1d3385775 simple-actors-20190710-git simple-actors.asd +simple-config http://beta.quicklisp.org/archive/simple-config/2019-12-27/simple-config-20191227-git.tgz 2421 581baa322bb5c6924fb37bcb391ca719 ab402780a2ba1ee230bacaf4fa3d0a73127ad2c0 simple-config-20191227-git simple-config-test.asd simple-config.asd +simple-currency http://beta.quicklisp.org/archive/simple-currency/2017-11-30/simple-currency-20171130-git.tgz 12557 71ea0f64c63b4287fc56ece336e08ef9 aa40c0d344e0c9c4b20583d8df86887e55081b2b simple-currency-20171130-git simple-currency.asd +simple-date-time http://beta.quicklisp.org/archive/simple-date-time/2016-04-21/simple-date-time-20160421-git.tgz 5688 a5b1e4af539646723dafacbc8cf732a0 74ea55a0c7d77d7b967b3ad94f9f67137c9cd01e simple-date-time-20160421-git simple-date-time.asd +simple-finalizer http://beta.quicklisp.org/archive/simple-finalizer/2010-10-06/simple-finalizer-20101006-git.tgz 3415 fcc7c3966af77de524e6f24bb9dc1c94 6ac4c1cb19186e78e445885f86da20ba99d868bb simple-finalizer-20101006-git simple-finalizer.asd +simple-flow-dispatcher http://beta.quicklisp.org/archive/simple-flow-dispatcher/2018-07-11/simple-flow-dispatcher-stable-a7b66fbc-git.tgz 2472 04fa311af0ae1be7e1b9c6fc3eaa0630 f398b15e606b6fdb4480b5b010365ba0520da616 simple-flow-dispatcher-stable-a7b66fbc-git simple-flow-dispatcher.asd +simple-inferiors http://beta.quicklisp.org/archive/simple-inferiors/2019-07-10/simple-inferiors-20190710-git.tgz 9654 e3194d746e03dd1dbf8d0f185a7cb457 7f287a3f922a929483e1e03f5273deefd0701603 simple-inferiors-20190710-git simple-inferiors.asd +simple-logger http://beta.quicklisp.org/archive/simple-logger/2018-02-28/simple-logger-20180228-git.tgz 2800 bae2008abb490d9ab93474676dbe944a a00039c9467b7f09977bbe9a0d500a1b8cf5e371 simple-logger-20180228-git simple-logger.asd +simple-parallel-tasks http://beta.quicklisp.org/archive/simple-parallel-tasks/2019-11-30/simple-parallel-tasks-20191130-git.tgz 14217 a7d4af2253c91d4dca663e14c99e918d 18111bf3848866bd1cc5276388526012f3e0995d simple-parallel-tasks-20191130-git simple-parallel-tasks-tests.asd simple-parallel-tasks.asd +simple-rgb http://beta.quicklisp.org/archive/simple-rgb/2019-05-21/simple-rgb-20190521-git.tgz 5464 8afe42c3bb2bec023cfae77a8153c668 2573e45d315e8fe7a0b30f90bd5bb9624044cdb5 simple-rgb-20190521-git simple-rgb.asd +simple-routes http://beta.quicklisp.org/archive/simple-routes/2018-02-28/simple-routes-20180228-git.tgz 6209 95b881171c381674a275da21692442f2 06b1a640d86490ed1e346b2a37306e4a8c7a66f2 simple-routes-20180228-git simple-routes.asd +simple-tasks http://beta.quicklisp.org/archive/simple-tasks/2019-07-10/simple-tasks-20190710-git.tgz 12567 8e88a9a762bc8691f92217d256baa55e 3fdcc5d1debf45d1480f31ce5f7de206ff6aeb87 simple-tasks-20190710-git simple-tasks.asd +simplet http://beta.quicklisp.org/archive/simplet/2019-12-27/simplet-20191227-git.tgz 16303 9fa3343c7a0b9f6f7f43d8b4ed706d98 bf0ee7b1a8770cc028a66ffd6da9770ab6492a3a simplet-20191227-git simplet-asdf.asd simplet.asd +simplified-types http://beta.quicklisp.org/archive/simplified-types/2019-08-13/simplified-types-20190813-git.tgz 6647 c3666e2faf2aed0ec040912db0a91285 c89aa23f3c54e114a3c8de9f3b8254d128bdf7f3 simplified-types-20190813-git code/simplified-types.asd test-suite/simplified-types-test-suite.asd +simpsamp http://beta.quicklisp.org/archive/simpsamp/2010-10-06/simpsamp-0.1.tgz 44485 afd8bdfae4b4f0924839753086bab0bf 38b802cbd0a7855ff101020e71ee2e9fd7927316 simpsamp-0.1 simpsamp.asd +single-threaded-ccl http://beta.quicklisp.org/archive/single-threaded-ccl/2015-06-08/single-threaded-ccl-20150608-git.tgz 2611 fa4c2cf5223e2c57e1b3352edeecca0c 3f7bedd0e7741ac4503bd09a6a84da5921e62b81 single-threaded-ccl-20150608-git single-threaded-ccl.asd +sip-hash http://beta.quicklisp.org/archive/sip-hash/2016-08-25/sip-hash-20160825-git.tgz 5396 a79aea8e4847580308bcc46ac2ddeaa2 89284d247a8403a555731ca5dd8bd135bd22609a sip-hash-20160825-git sip-hash-test.asd sip-hash.asd +skeleton-creator http://beta.quicklisp.org/archive/skeleton-creator/2019-12-27/skeleton-creator-20191227-git.tgz 42572 ca2c99e3eb2951f96db1190da7ed3c15 68ef28b145fe342fbc69df5b67d300f23733fea4 skeleton-creator-20191227-git skeleton-creator.asd +sketch http://beta.quicklisp.org/archive/sketch/2017-11-30/sketch-20171130-git.tgz 1117712 4074bf2418d86d392ce6dcca5e379f31 e4f1d2eccd31d987648b90668a7b33025057d3c4 sketch-20171130-git sketch-examples.asd sketch.asd +skippy http://beta.quicklisp.org/archive/skippy/2015-04-07/skippy-1.3.12.tgz 31965 c64deda635cd8b93768ff837c3b66a72 0a9255fa75a12a7c2f74db9ad584abe68d66a538 skippy-1.3.12 skippy.asd +skippy-renderer http://beta.quicklisp.org/archive/skippy-renderer/2018-01-31/skippy-renderer-20180131-git.tgz 2045 38e6ebfbf61921f6d3d8c3b523d7af45 06d79b76393363b593af29a89ce637d62908b5ba skippy-renderer-20180131-git skippy-renderer.asd +skitter http://beta.quicklisp.org/archive/skitter/2018-02-28/skitter-release-quicklisp-620772ae-git.tgz 21551 d9148bdb15605412b813b955cc9fb46b 984a7e9102c2fc65635cec373b3944f884e65a03 skitter-release-quicklisp-620772ae-git skitter.asd skitter.glop.asd skitter.sdl2.asd +slack-client http://beta.quicklisp.org/archive/slack-client/2016-08-25/slack-client-20160825-git.tgz 7752 245f64f7188363f1eabbb4b8a2e9c572 c500065dbbd1bf63fc37ec82114d0f76ebc9d906 slack-client-20160825-git slack-client-test.asd slack-client.asd +slime http://beta.quicklisp.org/archive/slime/2019-07-10/slime-v2.24.tgz 813432 05f421f7a9dffa4ba206c548524ef1c0 2a03cc43352ffec5d863568af298c54fe36138e7 slime-v2.24 swank.asd +slk-581 http://beta.quicklisp.org/archive/slk-581/2019-01-07/slk-581-20190107-git.tgz 4848 d90326b00b92d657b6424002dee00a56 f367c37a8378bddf0810f8fc91a87cbae39a4097 slk-581-20190107-git eclecticse.slk-581.asd +sly http://beta.quicklisp.org/archive/sly/2019-12-27/sly-20191227-git.tgz 1821100 6c38ce18567734425fff81326b7eda5f 7e735a1f2257de7c00b3043399008d1d6e98b5ae sly-20191227-git slynk/slynk.asd +smackjack http://beta.quicklisp.org/archive/smackjack/2018-02-28/smackjack-20180228-git.tgz 17449 398e790adbd5c3d1c85d211d8e119990 9de59527f4fa97c9c09aaaa448978fdc9d3e4ac7 smackjack-20180228-git demo/smackjack-demo.asd smackjack.asd +smart-buffer http://beta.quicklisp.org/archive/smart-buffer/2016-06-28/smart-buffer-20160628-git.tgz 3176 454d8510618da8111c7ca687549b7035 a4f22d227b6266c70e94597af8adf7dfc67b193a smart-buffer-20160628-git smart-buffer-test.asd smart-buffer.asd +smug http://beta.quicklisp.org/archive/smug/2016-04-21/smug-20160421-git.tgz 77846 8139d7813bb3130497b6da3bb4cb8924 588308bcd788fff31da9b464a0e6df1c2386cf16 smug-20160421-git smug.asd +sn.man http://beta.quicklisp.org/archive/sn.man/2019-02-02/sn.man-20190202-git.tgz 1563 c8398aefe8bc3818fbe9a6994bce7f8b 0b2fac544b0edf64f5b7fc0ee520a3853914ff96 sn.man-20190202-git sn.man.asd +snakes http://beta.quicklisp.org/archive/snakes/2018-12-10/snakes-20181210-git.tgz 16534 0bdb11ea92090dabcdc3509af16f0d2a 26c6e7ac29960d3ede577ecc75aceed7461a688f snakes-20181210-git snakes.asd +snappy http://beta.quicklisp.org/archive/snappy/2015-10-31/snappy-20151031-git.tgz 1319848 a454814a316902731bb6e28d4eadd115 8e8a9c046eab9ad4e5497201d4c1e547d5fbc20e snappy-20151031-git snappy-test.asd snappy.asd +snark http://beta.quicklisp.org/archive/snark/2016-04-21/snark-20160421-git.tgz 275436 b7ee5cb5350f5c675359022c10fc6bb9 b265505c5c331237e1fffbb0aa19fa68ff581cee snark-20160421-git snark-agenda.asd snark-auxiliary-packages.asd snark-deque.asd snark-dpll.asd snark-examples.asd snark-feature.asd snark-implementation.asd snark-infix-reader.asd snark-lisp.asd snark-loads.asd snark-numbering.asd snark-pkg.asd snark-sparse-array.asd snark.asd +sndfile-blob http://beta.quicklisp.org/archive/sndfile-blob/2018-02-28/sndfile-blob-stable-d904a06e-git.tgz 4041275 159b41bc37d6fcd4ef294bfd275c051c 8b39988db1b0581af5bf6509e01cf7b9c81bcaec sndfile-blob-stable-d904a06e-git sndfile-blob.asd +snmp http://beta.quicklisp.org/archive/snmp/2016-10-31/snmp-6.1.tgz 4454924 9ea185bf039906911b5f48b73a43c31f 826501f7973e77cd5e2cb19a7ce79d3cb2ecdf1d snmp-6.1 snmp-server.asd snmp-test.asd snmp-ui.asd snmp.asd +snooze http://beta.quicklisp.org/archive/snooze/2019-07-10/snooze-20190710-git.tgz 36180 9c30dee1f9b15e97f7fcc0509291e6f0 9f95a32ebfa69e910a64e56601ccd6758a88448f snooze-20190710-git snooze.asd +softdrink http://beta.quicklisp.org/archive/softdrink/2019-07-10/softdrink-20190710-git.tgz 5640 3fb4add6efa5aa90b69db11b6a0444f7 cff7e8b2e476a2050f1b39fa93d7193f00c47398 softdrink-20190710-git softdrink.asd +solid-engine http://beta.quicklisp.org/archive/solid-engine/2019-05-21/solid-engine-20190521-git.tgz 6543 f666e1d94dd1a915ce8c680d43ddbf02 a8f3345f2690c751b2df8522c9ad200db016960f solid-engine-20190521-git solid-engine.asd +soundex http://beta.quicklisp.org/archive/soundex/2010-10-06/soundex-1.0.tgz 1652 247f7c15b49b230100d37bbc3964bd10 8515dcfcd3bf21025931ca0837e9fe83c2622012 soundex-1.0 soundex.asd +south http://beta.quicklisp.org/archive/south/2019-07-10/south-20190710-git.tgz 20288 5635201c1fe341b9e75f1c0ea97e4e33 77c9ede6f2025cc776071555e2fc2844fce08650 south-20190710-git south.asd +spatial-trees http://beta.quicklisp.org/archive/spatial-trees/2014-08-26/spatial-trees-20140826-git.tgz 21925 2772b963aae5c4d06fff83c22e5c8aa9 5038860caf1e9687de757b3158f9df3086a4d54e spatial-trees-20140826-git spatial-trees.asd spatial-trees.nns.asd spatial-trees.nns.test.asd spatial-trees.test.asd +specialization-store http://beta.quicklisp.org/archive/specialization-store/2019-01-07/specialization-store-v0.0.4.tgz 64336 0d979c5e42a73aa6c764da38506c95bb 7fc8577146bd23a00a1dfabfdc4719429d743335 specialization-store-v0.0.4 specialization-store-features.asd specialization-store-tests.asd specialization-store.asd +specialized-function http://beta.quicklisp.org/archive/specialized-function/2019-12-27/specialized-function-20191227-git.tgz 101044 63a158875039df164af5c3a9b8c6a82d 245ec60790a804b0d859e579f333ae7ddcd445fc specialized-function-20191227-git specialized-function.asd specialized-function.test.asd +spell http://beta.quicklisp.org/archive/spell/2019-03-07/spell-20190307-git.tgz 3643983 f765650ae77e3aa237817ea9d0edf292 b8280c38fd4e628358ffc445d233b4c2a55c1f36 spell-20190307-git spell.asd +spellcheck http://beta.quicklisp.org/archive/spellcheck/2013-10-03/spellcheck-20131003-git.tgz 2375587 1633f18983bbb368192d1355f3f4f13e f6de93b47beda9d56e14184826bb8b49e10cb789 spellcheck-20131003-git spellcheck.asd +spinneret http://beta.quicklisp.org/archive/spinneret/2019-10-07/spinneret-20191007-git.tgz 26495 64de57957fcc72e90b43e1cb26357e4d 5522c52b347f5fbdfe70b8c62b70997bf7db987a spinneret-20191007-git spinneret.asd +split-sequence http://beta.quicklisp.org/archive/split-sequence/2019-05-21/split-sequence-v2.0.0.tgz 10329 88aadc6c9da23663ebbb39d546991df4 54314a3e7e3cb272f6ceec84acd23309bbdbba0f split-sequence-v2.0.0 split-sequence.asd +sprint-stars http://beta.quicklisp.org/archive/sprint-stars/2018-08-31/sprint-stars-20180831-git.tgz 1517 db7adeef5208184377f65388661f7ed2 a9de0cfd9e556c34cd2807084fc6ad2e2328a54f sprint-stars-20180831-git stars.asd +st-json http://beta.quicklisp.org/archive/st-json/2018-10-18/st-json-20181018-git.tgz 7402 75d772cb5d9367f44b924aa1f5620260 d33eaaaa20c73c2ce2a542e7c087ef0273b0d185 st-json-20181018-git st-json.asd +staple http://beta.quicklisp.org/archive/staple/2019-11-30/staple-20191130-git.tgz 98804 e79eb9df05381d830a30256a37f2b105 b097d9a02e2912e8669b7a295f41c9a0515cacec staple-20191130-git parser/staple-code-parser.asd server/staple-server.asd staple-markdown.asd staple-markless.asd staple-package-recording.asd staple-restructured-text.asd staple.asd +static-dispatch http://beta.quicklisp.org/archive/static-dispatch/2019-12-27/static-dispatch-20191227-git.tgz 13045 d796924e4669809b5a4fe74e55af584a 36280bd7c6cb42de15a30b2cbaf2bc2a92e8fdea static-dispatch-20191227-git static-dispatch.asd +static-vectors http://beta.quicklisp.org/archive/static-vectors/2019-11-30/static-vectors-v1.8.4.tgz 7420 401085c3ec0edc3ab47409e5a4b534c7 f0618189731f3099f2790f5b07f1247d2b59ff18 static-vectors-v1.8.4 static-vectors.asd +stealth-mixin http://beta.quicklisp.org/archive/stealth-mixin/2018-12-10/stealth-mixin-20181210-git.tgz 2180 2b6ba6744ac4c4fcdcf1a8c8b71ce567 f3a18458497c73a2a7b901f6f97eb2ce0133c5d9 stealth-mixin-20181210-git stealth-mixin.asd +stefil http://beta.quicklisp.org/archive/stefil/2018-12-10/stefil-20181210-git.tgz 18041 3418bf358366748593f65e4b6e1bb8cf f974b02c814ebaaa804f2ecf4c86b0a18abfe6b2 stefil-20181210-git stefil.asd +stem http://beta.quicklisp.org/archive/stem/2015-06-08/stem-20150608-git.tgz 116071 0dc7713fb0412a4d116304960410cdd7 2eecde21d5d4c35d095bc83b2dd26b55bf8d461e stem-20150608-git stem.asd +stl http://beta.quicklisp.org/archive/stl/2017-10-19/stl-20171019-git.tgz 3089 01a69ac8892b8f4a4bb97c57cf4a9da7 90d1d6084da63bf66ecf50ebf2f84d28531d10b4 stl-20171019-git stl.asd +stmx http://beta.quicklisp.org/archive/stmx/2018-10-18/stmx-stable-4d915e33-git.tgz 360397 817d021e01c934d21a0edadb726e49d4 dc1b0dfe140635e1f2e2974780112e6bf64dc703 stmx-stable-4d915e33-git stmx.asd +string-case http://beta.quicklisp.org/archive/string-case/2018-07-11/string-case-20180711-git.tgz 9081 145c4e13f1e90a070b0a95ca979a9680 ff3958a84d23a5b9e743fbf30726a1d9b6c0fbfd string-case-20180711-git string-case.asd +string-escape http://beta.quicklisp.org/archive/string-escape/2015-04-07/string-escape-20150407-http.tgz 15485 8e2acbd7ce3914258979b87a0284a4a1 1d9841f3e851d744c21af85156651eba4aa322d6 string-escape-20150407-http string-escape.asd +stripe http://beta.quicklisp.org/archive/stripe/2019-08-13/stripe-20190813-git.tgz 11794 df2fada3fcb94abac84dde39ebfbfaaa 9ff3e4e67910a7418362012df2bd894611af8828 stripe-20190813-git stripe.asd +structy-defclass http://beta.quicklisp.org/archive/structy-defclass/2017-06-30/structy-defclass-20170630-git.tgz 2769 ae666e7951c4137242d95fff9ca6c31e df7f719fa42dc7d3115ed1e0e14cd289eb9f7cce structy-defclass-20170630-git structy-defclass.asd +studio-client http://beta.quicklisp.org/archive/studio-client/2019-11-30/studio-client-20191130-git.tgz 8792 5b8fd01399af33f5244d4ecb1bf9ca4d 1e83a2a60bd8b087412e8824a4fb3fc626c4908b studio-client-20191130-git studio-client.asd +stumpwm http://beta.quicklisp.org/archive/stumpwm/2019-12-27/stumpwm-20191227-git.tgz 217019 247f56ddbdc8bdf4cf087a467ddce6f6 c658a1e8528de2113f6a15d55c6c5db3de81dd83 stumpwm-20191227-git stumpwm-tests.asd stumpwm.asd +submarine http://beta.quicklisp.org/archive/submarine/2012-09-09/submarine-20120909-darcs.tgz 38895 461d3050c80b3bbfa73e0ccddc3c00f3 2695b1d9c135e05e6f8bbcb23f0b663a438961e8 submarine-20120909-darcs submarine.asd +sucle http://beta.quicklisp.org/archive/sucle/2019-05-21/sucle-20190521-git.tgz 1010033 53bfdeeb528acc9be632877ac21625a3 f713be4086345e3b3f3fa201a77b90b59e1369a6 sucle-20190521-git application/app-subsystem/application/application.asd application/app-subsystem/clock/clock.asd application/app-subsystem/control/control.asd application/app-subsystem/deflazy/deflazy.asd application/app-subsystem/fps-independent-timestep/fps-independent-timestep.asd application/app-subsystem/opengl-immediate/opengl-immediate.asd application/app-subsystem/scratch-buffer/scratch-buffer.asd application/app-subsystem/window/window.asd application/application-example-hello-world/application-example-hello-world.asd application/basic0/sucle.asd application/subsystems/cartesian-graphing/cartesian-graphing.asd application/subsystems/fast-text-grid-sprites/fast-text-grid-sprites.asd application/subsystems/sandbox/sandbox.asd application/subsystems/sketch-sucle/sketch-sucle-examples.asd application/subsystems/sketch-sucle/sketch-sucle.asd application/subsystems/text-subsystem/doc/text-subsystem-generate-font.asd application/subsystems/text-subsystem/text-subsystem.asd application/subsystems/vecto-test/vecto-stuff.asd application/sucle2/sucle2.asd application/testbed/testbed.asd src/character-modifier-bits/character-modifier-bits.asd src/data-structures/doubly-linked-list/sucle-doubly-linked-list.asd src/data-structures/matrix/matrix.asd src/data-structures/reverse-array-array/example/reverse-array-array-example.asd src/data-structures/reverse-array-array/reverse-array-array.asd src/data-structures/reverse-array-iterator/reverse-array-iterator.asd src/data-structures/sprite-chain/sprite-chain.asd src/euclidean-geometry/aabbcc/aabbcc.asd src/euclidean-geometry/camera-matrix/camera-matrix.asd src/euclidean-geometry/quads/quads.asd src/image/image-utility/image-utility.asd src/nsb-cga/nsb-cga.asd src/opengl/glhelp.asd src/uncommon-lisp/uncommon-lisp.asd src/window-opengl-glfw3/opengl-glfw3.asd +swank-client http://beta.quicklisp.org/archive/swank-client/2019-10-07/swank-client-20191007-git.tgz 15470 e9956d8033709c673ba16a2d7a7fb43e 07830b6ade8802791510e40241ba38b042a9f06e swank-client-20191007-git swank-client-test.asd swank-client.asd +swank-crew http://beta.quicklisp.org/archive/swank-crew/2015-10-31/swank-crew-20151031-git.tgz 15837 8a792387ad5d695a0d80ab5cd44866d0 b0e5cbbe82a9c95199a67ec21769f3f2167a6b07 swank-crew-20151031-git swank-crew-test.asd swank-crew.asd +swank-protocol http://beta.quicklisp.org/archive/swank-protocol/2015-12-18/swank-protocol-20151218-git.tgz 7391 715d26e8b7d0a2d8e18d2a7dc2b946f1 0d695ac0968fa294475c425b5a3345d76973f692 swank-protocol-20151218-git swank-protocol.asd +swank.live http://beta.quicklisp.org/archive/swank.live/2016-02-08/swank.live-20160208-git.tgz 1754 0cfd0cc920b37a27359244797dfd8817 0e98e9c945773a2f6e8e79688081c942a3327f9d swank.live-20160208-git swank.live.asd +swap-bytes http://beta.quicklisp.org/archive/swap-bytes/2019-11-30/swap-bytes-v1.2.tgz 4342 eea516d7fdbe20bc963a6708c225d719 e1ab274454408933c57dd932be413f0b11f18444 swap-bytes-v1.2 swap-bytes.asd +sxql http://beta.quicklisp.org/archive/sxql/2019-11-30/sxql-20191130-git.tgz 25711 f46e9a33b39f5b069b805e00f80a5410 d2291dc7e569deeb81b2f0d5665d99d46e92c5cd sxql-20191130-git sxql-test.asd sxql.asd +sycamore http://beta.quicklisp.org/archive/sycamore/2018-10-18/sycamore-20181018-git.tgz 55595 ecc982173a52ead05a35454a23e60cc3 dde17ef19ba0c690a9790acaab9344b7f67e7f5c sycamore-20181018-git src/sycamore.asd +symbol-munger http://beta.quicklisp.org/archive/symbol-munger/2015-04-07/symbol-munger-20150407-git.tgz 5298 b1e35b63d7ad1451868d1c40e2fbfab7 a8589c60f470b8b280eacd9c983d96bc5f337341 symbol-munger-20150407-git symbol-munger.asd +symbol-namespaces http://beta.quicklisp.org/archive/symbol-namespaces/2013-01-28/symbol-namespaces-1.0.tgz 4915 0ffbf4f50332e324feb40269ca1848cd 1088d4f5d922d472fc16a77da01c498ec956a9a7 symbol-namespaces-1.0 symbol-namespaces.asd +synonyms http://beta.quicklisp.org/archive/synonyms/2019-03-07/synonyms-20190307-hg.tgz 1628 6f956534aa5f68cd03988303fdc40f30 2a5f07c4a581566a998f4a56048850c9e7f6268b synonyms-20190307-hg synonyms.asd +system-locale http://beta.quicklisp.org/archive/system-locale/2019-07-10/system-locale-20190710-git.tgz 6241 1f2bbaabf7b0c8122666cdd688592c09 e2c3f0c6894a1480f6ab9fb01aac138ef2c75998 system-locale-20190710-git system-locale.asd +tagger http://beta.quicklisp.org/archive/tagger/2019-03-07/tagger-20190307-git.tgz 1107234 8eceb5a9684410e3f4f8471c1e10608b 9b157554e13131da1f942375cb4d647a3717d686 tagger-20190307-git tagger.asd +taglib http://beta.quicklisp.org/archive/taglib/2018-07-11/taglib-20180711-git.tgz 49606 4c8725f03df326ab12ce2b810e79724b 114161a2d82899942d7c36f8f66f5f345cdc2ba1 taglib-20180711-git taglib-tests.asd taglib.asd +talcl http://beta.quicklisp.org/archive/talcl/2018-02-28/talcl-20180228-git.tgz 32272 12f54d47f90bc8385b3fa8bc4ded7530 39bf555e8bcdb9497663597dc6fe0d725d4c9388 talcl-20180228-git talcl.asd +tap-unit-test http://beta.quicklisp.org/archive/tap-unit-test/2017-12-27/tap-unit-test-20171227-git.tgz 6640 999414b562bcad22ad8be263d13cf813 bee7f65ad728387c7496f6ee412711c2982d8d7c tap-unit-test-20171227-git tap-unit-test.asd +targa http://beta.quicklisp.org/archive/targa/2018-10-18/targa-20181018-git.tgz 6717 abdb921075c2f42c314bcaa6af93402a 5d82e49c058ae56f9c586a82424f853476023ee7 targa-20181018-git targa.asd +teepeedee2 http://beta.quicklisp.org/archive/teepeedee2/2016-04-21/teepeedee2-20160421-git.tgz 92218 1685bc037dcaaeba1f5b9224fda7dccb 1d8e266e9e2f6063bfabccd37b55c66fa42ddb49 teepeedee2-20160421-git teepeedee2-test.asd teepeedee2.asd +telnetlib http://beta.quicklisp.org/archive/telnetlib/2014-12-17/telnetlib-20141217-git.tgz 9030 d002d6c2aa8cda700fa7b0e114404197 65dff3a01133aacc554aea10ecfb2d4a95ad6c12 telnetlib-20141217-git telnetlib.asd +template http://beta.quicklisp.org/archive/template/2019-03-07/template-20190307-hg.tgz 3558 f1f963f928879fb2ef6903e5e0466d6d a2a448c28c9b96927ef288929c04f931a86ed63c template-20190307-hg template.asd +template-function http://beta.quicklisp.org/archive/template-function/2017-11-30/template-function-v0.0.1-git.tgz 28074 cfe8ff39d2006b55a46b7f0bdf770ecb 327ad56f17a4923c9124834168791462d5274252 template-function-v0.0.1-git template-function-tests.asd template-function.asd +temporal-functions http://beta.quicklisp.org/archive/temporal-functions/2017-10-19/temporal-functions-20171019-git.tgz 6586 0a4ad318c90a9cc2c7ca391d2c471c1a 70bfe85677d18c3de5434d054d6dd7b6ae3395d4 temporal-functions-20171019-git temporal-functions.asd +temporary-file http://beta.quicklisp.org/archive/temporary-file/2015-06-08/temporary-file-20150608-git.tgz 10812 0df609812523566a84604d768158f3b0 1ac3046923b6136defee3d28344f9c4e69d8e83a temporary-file-20150608-git temporary-file.asd +terminfo http://beta.quicklisp.org/archive/terminfo/2018-08-31/terminfo-20180831-git.tgz 12813 0b3ee86845c43c92cfb8eaddaa94ce42 39995b17e1b4fe3a6e6bd4aaf16720bb646cfa7c terminfo-20180831-git terminfo.asd +terrable http://beta.quicklisp.org/archive/terrable/2019-07-10/terrable-20190710-git.tgz 8756 99d92ae77464827a2c3f17cbcef09388 5b7f6b7821374d913cc4f8aa34968db75a065480 terrable-20190710-git terrable.asd +test-utils http://beta.quicklisp.org/archive/test-utils/2018-08-31/test-utils-20180831-git.tgz 5073 dff3c30e51b7ff5812b6eb7671342033 b11396183f5751bb224571c8981290a59fab14f0 test-utils-20180831-git test-utils.asd +testbild http://beta.quicklisp.org/archive/testbild/2010-12-07/testbild-20101207-git.tgz 52330 d3008e32481ed01aaf4bf8d2fd0bcbad 95fca0344bb5af81f7f9c0453ed51e24fd27419f testbild-20101207-git testbild-test.asd testbild.asd +texp http://beta.quicklisp.org/archive/texp/2015-12-18/texp-20151218-git.tgz 16321 0ded17b1ba2ad4506e5f4bde9ba9a2d7 e73f7a2267913b386f31b78b6e68ddd4c896de92 texp-20151218-git texp.asd +text-query http://beta.quicklisp.org/archive/text-query/2011-11-05/text-query-1.1.tgz 5548 57d28b552f346a00ece98824b1bc898f f5ec2327f9d7049749d6bea161ea7d90a5db5017 text-query-1.1 text-query.asd +tfm http://beta.quicklisp.org/archive/tfm/2019-11-30/tfm-20191130-git.tgz 39947 a86c7c0f808b834cd42557375003bfc1 95a09ff4cf730fe82a9a03a85efb3d9e2bbf7542 tfm-20191130-git core/net.didierverna.tfm.core.asd net.didierverna.tfm.asd setup/net.didierverna.tfm.setup.asd +the-cost-of-nothing http://beta.quicklisp.org/archive/the-cost-of-nothing/2019-11-30/the-cost-of-nothing-20191130-git.tgz 6864 e7b9891f6a3827425124ed8c00b13bab c8f6ee5ed5ee075729d28dcbe354386ba555aab1 the-cost-of-nothing-20191130-git the-cost-of-nothing.asd +thnappy http://beta.quicklisp.org/archive/thnappy/2018-08-31/thnappy-20180831-git.tgz 2879 e399d3a0aea4a4d46b4f3779b083b759 e68599d93d642eb88c3c4ead9a7724c43c34bf5c thnappy-20180831-git thnappy.asd +thorn http://beta.quicklisp.org/archive/thorn/2015-06-08/thorn-20150608-git.tgz 4539 efcc67773fb54b4e4680d50ed5091f9a 436eb3485d54524cc23cc97d1d30ea4f3d1af29b thorn-20150608-git thorn-doc.asd thorn-test.asd thorn.asd +thread-pool http://beta.quicklisp.org/archive/thread-pool/2012-01-07/thread-pool-20120107-git.tgz 3061 9dfcb3dd5692d474d90f7916722d5bf8 5754230b3648ae4d84f80a8cf552518d6851e96b thread-pool-20120107-git thread-pool.asd +thread.comm.rendezvous http://beta.quicklisp.org/archive/thread.comm.rendezvous/2012-10-13/thread.comm.rendezvous-20121013-git.tgz 3295 819e6c2c9fc715f47b9fc1fae4dd9620 fb0ada0703f62f9d2c38cd8d100571b087d6f61f thread.comm.rendezvous-20121013-git thread.comm.rendezvous.asd thread.comm.rendezvous.test.asd +time-interval http://beta.quicklisp.org/archive/time-interval/2019-02-02/time-interval-20190202-git.tgz 3914 be8f598fa583bc02d5aef61c9da05497 2e3b1a01d3aca24e573fdf98ce81b5a15909ce2c time-interval-20190202-git time-interval.asd +timer-wheel http://beta.quicklisp.org/archive/timer-wheel/2018-02-28/timer-wheel-20180228-git.tgz 6804 aecee06490b30b7395bd6bf8e30e293f f5394005e0e5214210a8dd1a0d41fd35674c364d timer-wheel-20180228-git timer-wheel.asd timer-wheel.examples.asd +tinaa http://beta.quicklisp.org/archive/tinaa/2017-12-27/tinaa-20171227-git.tgz 80171 bc067fbe6af7f03f247e93c0d35c5f3a 7cb5eed990ef9deaa609f923c9361840131a90f2 tinaa-20171227-git tinaa-test.asd tinaa.asd +tm http://beta.quicklisp.org/archive/tm/2018-02-28/tm-v0.8.tgz 173992 8c2219879aa24677951a02235855dcf6 dbe34f193e9e3e16b829d8516ef3c510322408c0 tm-v0.8 tm.asd +tmpdir http://beta.quicklisp.org/archive/tmpdir/2019-11-30/tmpdir-20191130-git.tgz 1540 39548e71b34a0a43b2930eb248fe9695 26c38135426f38f3c4b8476b5f1dad1f2382e3e1 tmpdir-20191130-git tmpdir.asd +toadstool http://beta.quicklisp.org/archive/toadstool/2013-06-15/toadstool-20130615-git.tgz 14309 8bd093fb81edf56821b538339c70c1f1 404dd62b14525f642110dfd30dadbe4e753f1e9f toadstool-20130615-git toadstool-tests.asd toadstool.asd +toot http://beta.quicklisp.org/archive/toot/2012-11-25/toot-20121125-git.tgz 57834 569c801b0b9e880977df5ab9743ec23c b97041f2040590e8751eae383532996923ec5ad0 toot-20121125-git toot.asd +tooter http://beta.quicklisp.org/archive/tooter/2019-07-10/tooter-20190710-git.tgz 37879 b53a4836c868a7e2c0008f2d85d4cb98 b9089b0b627fb7378a50fb276b4f186af4530859 tooter-20190710-git tooter.asd +torta http://beta.quicklisp.org/archive/torta/2014-07-13/torta-20140713-git.tgz 126230 5f2ab2b6d6cb48f17dbf147adde1941e 77e116a79f5931c42d675485991dc5d8352beff1 torta-20140713-git torta.asd +towers http://beta.quicklisp.org/archive/towers/2014-12-17/towers-20141217-git.tgz 17597 2af927bf9a75351e0216b45dafef01ce 8949f07d1929307532b2b9ad4009480ea166c808 towers-20141217-git towers.asd +trace-db http://beta.quicklisp.org/archive/trace-db/2019-07-10/trace-db-20190710-git.tgz 52753 4fa5f75f0239ab1e04cf235fe3c0574c 59f7a19923caaceeaab8661b084c99e70485df46 trace-db-20190710-git trace-db.asd +track-best http://beta.quicklisp.org/archive/track-best/2018-10-18/track-best-20181018-git.tgz 6252 e8a45d9ea61867c6873bb5b78018a5f9 96a1746115744d3c733a52b9eaf14a40d9318a08 track-best-20181018-git track-best.asd +trainable-object http://beta.quicklisp.org/archive/trainable-object/2019-12-27/trainable-object-20191227-git.tgz 19230 9db5fb29c21927d7d1aee421e673ee66 bcb41c52a7278aaf9c381b14218eb79617290766 trainable-object-20191227-git trainable-object.asd trainable-object.test.asd +translate http://beta.quicklisp.org/archive/translate/2018-02-28/translate-20180228-git.tgz 6688 95c46dec58c83cd01efd27d60049712f 8660e413ff82b5e83b42bb0d3a64990ee1383db7 translate-20180228-git translate.asd +translate-client http://beta.quicklisp.org/archive/translate-client/2018-02-28/translate-client-20180228-git.tgz 4495 94b7fb3e9836500104348162732512be bdf15a4a38460632c85d3979ef08ea27e79f8c3c translate-client-20180228-git translate-client.asd +transparent-wrap http://beta.quicklisp.org/archive/transparent-wrap/2015-07-09/transparent-wrap-20150709-git.tgz 10282 fbbcfb41c7bdc8e959d4a6716d12fed9 60be87e9f50ecbbde5038341a990ab8e5aaa18f4 transparent-wrap-20150709-git transparent-wrap.asd +treedb http://beta.quicklisp.org/archive/treedb/2016-08-25/treedb-20160825-git.tgz 16294 af216acd41ca7a14497d3f045af39b26 d12e833c2d1c271e6ef49bc189a51ccd8f4edfde treedb-20160825-git doc/treedb.doc.asd tests/treedb.tests.asd treedb.asd +trees http://beta.quicklisp.org/archive/trees/2018-01-31/trees-20180131-git.tgz 20019 a1b156d15d444d114f475f7abc908064 3e5523710bbc6c5d96894e036377fbb4487460f9 trees-20180131-git trees.asd +trivia http://beta.quicklisp.org/archive/trivia/2019-12-27/trivia-20191227-git.tgz 58411 645f0e0fcf57ab37ebd4f0a1b7b05854 2354871dba25e2b875edd4cb9f4ebc6fc416badf trivia-20191227-git trivia.asd trivia.balland2006.asd trivia.benchmark.asd trivia.cffi.asd trivia.level0.asd trivia.level1.asd trivia.level2.asd trivia.ppcre.asd trivia.quasiquote.asd trivia.test.asd trivia.trivial.asd +trivial-arguments http://beta.quicklisp.org/archive/trivial-arguments/2019-07-10/trivial-arguments-20190710-git.tgz 3375 e18fa47699802dee1731e0c2d9903f96 3eac3be70009b856090eaee2c4d217eb702efe81 trivial-arguments-20190710-git trivial-arguments.asd +trivial-backtrace http://beta.quicklisp.org/archive/trivial-backtrace/2019-07-10/trivial-backtrace-20190710-git.tgz 9208 e9035ed00321b24278cbf5449a1aebed 15034f7fba32e86bfa374f97134b0bfda8760e32 trivial-backtrace-20190710-git trivial-backtrace-test.asd trivial-backtrace.asd +trivial-battery http://beta.quicklisp.org/archive/trivial-battery/2019-03-07/trivial-battery-20190307-git.tgz 2248 ccb8f68e7086523a8da2700fab0e5c7d f13fceb155f8e99202ae1d9c99ff0e140b4e4803 trivial-battery-20190307-git trivial-battery.asd +trivial-benchmark http://beta.quicklisp.org/archive/trivial-benchmark/2019-11-30/trivial-benchmark-20191130-git.tgz 14929 8b2be09b1d8312c790006118847261cf aa6d4b7201691f97b4808a34b28b29a1a438ad9b trivial-benchmark-20191130-git trivial-benchmark.asd +trivial-bit-streams http://beta.quicklisp.org/archive/trivial-bit-streams/2019-07-10/trivial-bit-streams-20190710-git.tgz 7667 c08ad7b58a972f45c4939ad6869a9283 819805e50d470ec6b09ee0ea53889f633754408e trivial-bit-streams-20190710-git trivial-bit-streams-tests.asd trivial-bit-streams.asd +trivial-build http://beta.quicklisp.org/archive/trivial-build/2015-12-18/trivial-build-20151218-git.tgz 3150 51479b61f4cbe7a113065b0f3ac50834 654770325c8c5ebd1632430aae2bc3f4ac027fd7 trivial-build-20151218-git trivial-build-test.asd trivial-build.asd +trivial-channels http://beta.quicklisp.org/archive/trivial-channels/2016-04-21/trivial-channels-20160421-git.tgz 2810 7bd8731f8ffbbc61aeaf7fde3309c2a3 2c856642b1ac4006d2f8a1f8bd55d18697c9329e trivial-channels-20160421-git trivial-channels.asd +trivial-clipboard http://beta.quicklisp.org/archive/trivial-clipboard/2019-02-02/trivial-clipboard-20190202-git.tgz 4086 d9b9ee3754e10888ce243172681a0db2 2078c5844dd927ec38e8d7103090b440715dbc32 trivial-clipboard-20190202-git trivial-clipboard-test.asd trivial-clipboard.asd +trivial-cltl2 http://beta.quicklisp.org/archive/trivial-cltl2/2019-07-10/trivial-cltl2-20190710-git.tgz 5067 8114f96b9770a9f0e0a94933918dc171 2530e30e0927283650c2f36c38025edbd84e2473 trivial-cltl2-20190710-git trivial-cltl2.asd +trivial-compress http://beta.quicklisp.org/archive/trivial-compress/2016-04-21/trivial-compress-20160421-git.tgz 2838 8d531a2607e6b206c3bbfe51d003c8b6 d228a5309280c996ceaa25e9234e238359050c16 trivial-compress-20160421-git trivial-compress-test.asd trivial-compress.asd +trivial-continuation http://beta.quicklisp.org/archive/trivial-continuation/2019-10-07/trivial-continuation-20191007-git.tgz 6021 cd66f3f621bd6004b18c8cfb834fa61c b031d2c2d477949c038e14b9a84fb13cba7f5ae6 trivial-continuation-20191007-git trivial-continuation.asd +trivial-debug-console http://beta.quicklisp.org/archive/trivial-debug-console/2015-04-07/trivial-debug-console-20150407-git.tgz 2602 570ce84cfc527c3ce9a66eb9a3e32a33 c78bc7dbf398faba7518f9edc3fa7ef64ac74768 trivial-debug-console-20150407-git trivial-debug-console.asd +trivial-documentation http://beta.quicklisp.org/archive/trivial-documentation/2016-12-04/trivial-documentation-20161204-git.tgz 15596 9f092a90567e4f77dc9bd1d06fa58ed0 be1d89ac255c31e9de3ad7966312cfa1e6cda9e2 trivial-documentation-20161204-git trivial-documentation-test.asd trivial-documentation.asd +trivial-download http://beta.quicklisp.org/archive/trivial-download/2015-12-18/trivial-download-20151218-git.tgz 3819 486d3b0da2d832e3f0a6176e40adc449 c975d97de65d514f66b82ce1f52f4a8dcc8ec68e trivial-download-20151218-git trivial-download-test.asd trivial-download.asd +trivial-dump-core http://beta.quicklisp.org/archive/trivial-dump-core/2017-02-27/trivial-dump-core-20170227-git.tgz 5550 1ba1e853c238b2545002db6ee9530144 8a54cef6a4d0dea05cb5844ebb44f0cf03da762d trivial-dump-core-20170227-git trivial-dump-core.asd +trivial-escapes http://beta.quicklisp.org/archive/trivial-escapes/2018-02-28/trivial-escapes-20180228-git.tgz 6079 b8afeb445f9a3fd8e046d5899fd21e2e 102cfd6ba8f9af527302062704cbd04974848bae trivial-escapes-20180228-git test/trivial-escapes-test.asd trivial-escapes.asd +trivial-exe http://beta.quicklisp.org/archive/trivial-exe/2015-12-18/trivial-exe-20151218-git.tgz 1983 d85a8e198c31aa3d6c07351a41732e49 a860186969c29240babffd1c0e2209635a5e2e3a trivial-exe-20151218-git trivial-exe-test.asd trivial-exe.asd +trivial-extensible-sequences http://beta.quicklisp.org/archive/trivial-extensible-sequences/2019-08-13/trivial-extensible-sequences-20190813-git.tgz 15428 7001347e293ccd5cd15026e0a7ec4158 0f339cefb94cc1225113d7f64ebccbb87e28c8c0 trivial-extensible-sequences-20190813-git trivial-extensible-sequences.asd +trivial-extract http://beta.quicklisp.org/archive/trivial-extract/2016-04-21/trivial-extract-20160421-git.tgz 3545 b9c3ede33a7f4d565f6916a52a6ea708 c89c03f8cd08876c412a3ae40b0ac763b1930635 trivial-extract-20160421-git trivial-extract-test.asd trivial-extract.asd +trivial-features http://beta.quicklisp.org/archive/trivial-features/2019-07-10/trivial-features-20190710-git.tgz 10765 3907b044e00a812ebae989134fe57c55 67b7502615c36002f611536020ee5ffb3e23513a trivial-features-20190710-git trivial-features-tests.asd trivial-features.asd +trivial-file-size http://beta.quicklisp.org/archive/trivial-file-size/2018-01-31/trivial-file-size-20180131-git.tgz 3254 ac921679334dd8bd12f927f0bd806f4b cf8f78bbbbb18e547dd47cff487ac30a4f356c43 trivial-file-size-20180131-git trivial-file-size.asd +trivial-garbage http://beta.quicklisp.org/archive/trivial-garbage/2019-05-21/trivial-garbage-20190521-git.tgz 10438 38fb70797069d4402c6b0fe91f4ca5a8 d9013ebd6a0ea3bd5a23dc9368fb0e318d651fcd trivial-garbage-20190521-git trivial-garbage.asd +trivial-gray-streams http://beta.quicklisp.org/archive/trivial-gray-streams/2018-10-18/trivial-gray-streams-20181018-git.tgz 8024 0a9f564079dc41ce10d7869d82cc0952 27c3dc766e7c8fed3051403e0c38468a235f6acf trivial-gray-streams-20181018-git trivial-gray-streams-test.asd trivial-gray-streams.asd +trivial-hashtable-serialize http://beta.quicklisp.org/archive/trivial-hashtable-serialize/2019-10-07/trivial-hashtable-serialize-20191007-git.tgz 4010 9983c4dff65eb69b0eadb067cf03a834 79afe82d413cd42fbcd64a6f66a7bdb0f15ad245 trivial-hashtable-serialize-20191007-git trivial-hashtable-serialize.asd +trivial-http http://beta.quicklisp.org/archive/trivial-http/2011-02-19/trivial-http-20110219-http.tgz 12646 9f6b15eb07fd99fd0b6b69387a520a4f c71ab658c7c6a98eefdd9a69f8d358a9752bb1dc trivial-http-20110219-http trivial-http-test.asd trivial-http.asd +trivial-indent http://beta.quicklisp.org/archive/trivial-indent/2019-10-07/trivial-indent-20191007-git.tgz 3419 d0489ff824d58c03b5c2a9b16279f583 480bc42651968cf7b9566c190c83d39a42be03d3 trivial-indent-20191007-git trivial-indent.asd +trivial-irc http://beta.quicklisp.org/archive/trivial-irc/2017-10-19/trivial-irc-20171019-git.tgz 22705 e63a9436c7db593d5aab25d4eb89679b 1fd2165891ad015f7d978e275dc7f99063a605fa trivial-irc-20171019-git trivial-irc-echobot.asd trivial-irc.asd +trivial-json-codec http://beta.quicklisp.org/archive/trivial-json-codec/2019-10-07/trivial-json-codec-20191007-git.tgz 8065 1c55c7d97d49750189d5bd9fbc5afd15 2261bc37879f3f0be83fd74bcdc6964ebec13dbe trivial-json-codec-20191007-git trivial-json-codec.asd +trivial-jumptables http://beta.quicklisp.org/archive/trivial-jumptables/2019-11-30/trivial-jumptables_1.1.tgz 12374 f8ef2c3b2659c6874a0d3f5555b353af 83d069ac067e1a258ad39ee3b5d0cc437f33469f trivial-jumptables_1.1 tests/trivial-jumptables_tests.asd trivial-jumptables.asd +trivial-lazy http://beta.quicklisp.org/archive/trivial-lazy/2015-07-09/trivial-lazy-20150709-git.tgz 1714 ebb499de9ea8b79b0d580222d36ddee9 e9b99256aeec0f0184f3ae5cf20a9e294c1dd972 trivial-lazy-20150709-git trivial-lazy.asd +trivial-ldap http://beta.quicklisp.org/archive/trivial-ldap/2018-07-11/trivial-ldap-20180711-git.tgz 28258 355759d2c532a377b0ec3c0a689548fd 160ff42b50f8f664b029cb53e598301cd8f2d7f4 trivial-ldap-20180711-git trivial-ldap.asd +trivial-left-pad http://beta.quicklisp.org/archive/trivial-left-pad/2019-08-13/trivial-left-pad-20190813-git.tgz 6592 04a7ef287111319605989f582bf7ce4f 544fa2a3c678fe11f7a5a65e7f3e591abf9bcd5e trivial-left-pad-20190813-git trivial-left-pad.asd +trivial-macroexpand-all http://beta.quicklisp.org/archive/trivial-macroexpand-all/2017-10-23/trivial-macroexpand-all-20171023-git.tgz 1968 9cec494869344eb64ebce802c01928c5 87006c97029637389a4371efc28ba43ececfc315 trivial-macroexpand-all-20171023-git trivial-macroexpand-all.asd +trivial-main-thread http://beta.quicklisp.org/archive/trivial-main-thread/2019-07-10/trivial-main-thread-20190710-git.tgz 6114 ab95906f1831aa5b40f271eebdfe11a3 899bc9fa1f863baeece94f9aea0d7f6b7385dbbb trivial-main-thread-20190710-git trivial-main-thread.asd +trivial-method-combinations http://beta.quicklisp.org/archive/trivial-method-combinations/2019-11-30/trivial-method-combinations-20191130-git.tgz 1502 810ed9f3459831000b175970a35c0a0f 323703b64bd61e9dbe911d601c8360e4500c0057 trivial-method-combinations-20191130-git trivial-method-combinations.asd +trivial-mimes http://beta.quicklisp.org/archive/trivial-mimes/2019-07-10/trivial-mimes-20190710-git.tgz 20215 b7fa1cb9382a2a562343c6ca87b1b4ac 9ab070fa12b583fee21df36d50f102b29ef648c5 trivial-mimes-20190710-git trivial-mimes.asd +trivial-mmap http://beta.quicklisp.org/archive/trivial-mmap/2018-07-11/trivial-mmap-20180711-git.tgz 3387 17bfc83b320be648da993a83991f911a efaef0202a10f2416443adea49d225bc9da3e3ff trivial-mmap-20180711-git trivial-mmap.asd +trivial-monitored-thread http://beta.quicklisp.org/archive/trivial-monitored-thread/2019-10-07/trivial-monitored-thread-20191007-git.tgz 6500 2ae90d97c0abe51cd14fc59427233ced 482f9c9a177bd73291fdfc24b9e21c5ae48751ce trivial-monitored-thread-20191007-git trivial-monitored-thread.asd +trivial-msi http://beta.quicklisp.org/archive/trivial-msi/2016-02-08/trivial-msi-20160208-git.tgz 2142 c2b860a6959e61707142419756f7cf3e 0d6d8cf48d175a6616a245801fa44a165baee4c4 trivial-msi-20160208-git trivial-msi-test.asd trivial-msi.asd +trivial-nntp http://beta.quicklisp.org/archive/trivial-nntp/2016-12-04/trivial-nntp-20161204-git.tgz 4937 f03c13ee62ce27792941d9f9d8cd7c43 b311c46a549c4dbffaed13b8c338ce976ad7b892 trivial-nntp-20161204-git trivial-nntp.asd +trivial-object-lock http://beta.quicklisp.org/archive/trivial-object-lock/2019-10-07/trivial-object-lock-20191007-git.tgz 128346 c0fe973e9a00faf5286895d18952c231 6e0a1fc45e98e903b54182cf2ac1d01bee87993c trivial-object-lock-20191007-git trivial-object-lock.asd +trivial-octet-streams http://beta.quicklisp.org/archive/trivial-octet-streams/2013-01-28/trivial-octet-streams-20130128-git.tgz 3452 00d2c8cd41b5ace65519f366bc6542fb e0b865e9b1787e6f91b5d5e6c454a1a5890e077e trivial-octet-streams-20130128-git trivial-octet-streams.asd +trivial-open-browser http://beta.quicklisp.org/archive/trivial-open-browser/2016-08-25/trivial-open-browser-20160825-git.tgz 1176 038c4cd110fa9b34a77fe655bc1e35ba bac02728c1ed3037f88b89764dacf204bb8a1b4a trivial-open-browser-20160825-git trivial-open-browser.asd +trivial-openstack http://beta.quicklisp.org/archive/trivial-openstack/2016-06-28/trivial-openstack-20160628-git.tgz 9849 fd4cea1d1a6e3079f4778c226fbb08b1 d7bb60c337b47ad21205099b8ac38efb7b48bd59 trivial-openstack-20160628-git trivial-openstack-test.asd trivial-openstack.asd +trivial-package-local-nicknames http://beta.quicklisp.org/archive/trivial-package-local-nicknames/2019-11-30/trivial-package-local-nicknames-20191130-git.tgz 3681 703a57785a11477361ac4253aab0698e 56036aae9c02f10390e91c6c141e9a15bf0e0462 trivial-package-local-nicknames-20191130-git trivial-package-local-nicknames.asd +trivial-package-manager http://beta.quicklisp.org/archive/trivial-package-manager/2017-12-27/trivial-package-manager-20171227-git.tgz 6042 161ae810ca261f04aae86068365839da bdda9666a328e2d6e8278fceb8d6b9dff46e1c31 trivial-package-manager-20171227-git trivial-package-manager.asd trivial-package-manager.test.asd +trivial-pooled-database http://beta.quicklisp.org/archive/trivial-pooled-database/2019-10-07/trivial-pooled-database-20191007-git.tgz 6240 4649ea77d57c2e1a5a01656f8f480eb9 2d7e41c5267119fb0a7a10f77c115ece76804b29 trivial-pooled-database-20191007-git trivial-pooled-database.asd +trivial-project http://beta.quicklisp.org/archive/trivial-project/2017-08-30/trivial-project-quicklisp-9e3fe231-git.tgz 7676 1702cda33bf5d228c4f865f4ca2f28da f9050c412d5c9851d3f384000a6b8b8eaab82473 trivial-project-quicklisp-9e3fe231-git trivial-project.asd +trivial-raw-io http://beta.quicklisp.org/archive/trivial-raw-io/2014-12-17/trivial-raw-io-20141217-git.tgz 2861 627f83a54a94278675c03c14934b272a f89b8c4e06554471bfcb9216dd2eb385b5dd8e8a trivial-raw-io-20141217-git trivial-raw-io.asd +trivial-renamer http://beta.quicklisp.org/archive/trivial-renamer/2017-08-30/trivial-renamer-quicklisp-1282597d-git.tgz 3794 ff77e08decb7ca7b5b18e7b03c6cb05b 071cd2c4f5eb569ca958dbfd91a8effb3f0df647 trivial-renamer-quicklisp-1282597d-git trivial-renamer.asd +trivial-rfc-1123 http://beta.quicklisp.org/archive/trivial-rfc-1123/2017-01-24/trivial-rfc-1123-20170124-git.tgz 5622 a91a7fc1fae5a5da9e34ff58b72236e7 8fd5bfe63f661ab64c368a0831c81bedf9f0d015 trivial-rfc-1123-20170124-git trivial-rfc-1123.asd +trivial-shell http://beta.quicklisp.org/archive/trivial-shell/2018-02-28/trivial-shell-20180228-git.tgz 14473 d7b93648abd06be95148d43d09fa2ed0 cea06f83f2a0a7f17ba75b612535dc2676296025 trivial-shell-20180228-git trivial-shell-test.asd trivial-shell.asd +trivial-signal http://beta.quicklisp.org/archive/trivial-signal/2019-07-10/trivial-signal-20190710-git.tgz 13446 835a39ed6f968c22862be53487bab640 f1eda45929be115101e995590fefd4fcf8abd6f3 trivial-signal-20190710-git trivial-signal.asd +trivial-sockets http://beta.quicklisp.org/archive/trivial-sockets/2019-01-07/trivial-sockets-20190107-git.tgz 11603 bd56e19a9716b8beb0d482d38fc16472 da768132611e7d7ff0b44212a8011bf17b45e99f trivial-sockets-20190107-git trivial-sockets.asd +trivial-ssh http://beta.quicklisp.org/archive/trivial-ssh/2019-11-30/trivial-ssh-20191130-git.tgz 16118 d1b5dcc547de445a4fde156b66942ab1 001183c4093a3ff5b6133f9f81327f062842d8a5 trivial-ssh-20191130-git trivial-ssh-libssh2.asd trivial-ssh-test.asd trivial-ssh.asd +trivial-string-template http://beta.quicklisp.org/archive/trivial-string-template/2016-10-31/trivial-string-template-20161031-git.tgz 9755 d9836199d9f7a53e1c3e7625c08a6208 cf82a2302fffcbbc86b385e73aba958fd26a6044 trivial-string-template-20161031-git trivial-string-template-test.asd trivial-string-template.asd +trivial-swank http://beta.quicklisp.org/archive/trivial-swank/2018-02-28/trivial-swank-quicklisp-ab90d90f-git.tgz 5553 a5ca451d2b9c5bf338f16f5bbf52fd14 840a996a64f567f46af09caa8213fc7b38fd184a trivial-swank-quicklisp-ab90d90f-git trivial-swank.asd +trivial-tco http://beta.quicklisp.org/archive/trivial-tco/2013-10-03/trivial-tco-20131003-git.tgz 2541 9123b9c05aec84967cb9db6648c958f4 2416c68735324bfec2f53d16abfd76cc29846861 trivial-tco-20131003-git trivial-tco-test.asd trivial-tco.asd +trivial-thumbnail http://beta.quicklisp.org/archive/trivial-thumbnail/2019-07-10/trivial-thumbnail-20190710-git.tgz 5331 c8bfe5f627830e849104d7e0ba54bca6 86865b4054ada83afe01f1a5fbebf35076328215 trivial-thumbnail-20190710-git trivial-thumbnail.asd +trivial-timeout http://beta.quicklisp.org/archive/trivial-timeout/2018-01-31/trivial-timeout-20180131-git.tgz 8556 43a318a74a174a0a5bb0921f650f0727 afe9bd2217f8ebc0c67c9c66d4b3d76a678a4d98 trivial-timeout-20180131-git trivial-timeout.asd +trivial-timer http://beta.quicklisp.org/archive/trivial-timer/2019-10-07/trivial-timer-20191007-git.tgz 5648 5da2440d5bf9b090992aa9df04751858 337112f3b0548401daaa336c0ad865ff259128e0 trivial-timer-20191007-git trivial-timer.asd +trivial-timers http://beta.quicklisp.org/archive/trivial-timers/2010-10-06/trivial-timers-20101006-http.tgz 4064 c2191b98e93888880e7b99c5f3db050e caf09574cc58601410b46b2b03654f0e7742347b trivial-timers-20101006-http trivial-timers.asd +trivial-types http://beta.quicklisp.org/archive/trivial-types/2012-04-07/trivial-types-20120407-git.tgz 3228 b14dbe0564dcea33d8f4e852a612d7db acf9e5a4b0ef99bdcb121cfbc8f07c647c302e57 trivial-types-20120407-git trivial-types.asd +trivial-update http://beta.quicklisp.org/archive/trivial-update/2018-01-31/trivial-update-20180131-git.tgz 2718 d8c0e6814b49272876ea768cd1e46e2f 4b672e0127418b00f5c12a21f24f5db7cc8af279 trivial-update-20180131-git trivial-update.asd +trivial-utf-8 http://beta.quicklisp.org/archive/trivial-utf-8/2011-10-01/trivial-utf-8-20111001-darcs.tgz 6055 0206c4ba7a6c0b9b23762f244aca6614 a6eb987246e5f233c6b9c4b8b15edbbe2770d848 trivial-utf-8-20111001-darcs trivial-utf-8.asd +trivial-utilities http://beta.quicklisp.org/archive/trivial-utilities/2019-10-07/trivial-utilities-20191007-git.tgz 7187 bb0a1b0c7edd5783ff7e2717fde2df60 9a64bfa3b0c977f7d4f4c5856be3a1853a76c3a3 trivial-utilities-20191007-git trivial-utilities.asd +trivial-variable-bindings http://beta.quicklisp.org/archive/trivial-variable-bindings/2019-10-07/trivial-variable-bindings-20191007-git.tgz 4594 13e84f4912598f04d5da6a4bd4c7be5f 8bfa3f68d6b82a13767f88f5595cecc8a6df2d3a trivial-variable-bindings-20191007-git trivial-variable-bindings.asd +trivial-wish http://beta.quicklisp.org/archive/trivial-wish/2017-06-30/trivial-wish-quicklisp-910afeea-git.tgz 3604 37c6d054b8047635f893bcca3b20043f 477cbc87778ab161717f3247495b99ce82d26fe0 trivial-wish-quicklisp-910afeea-git trivial-wish.asd +trivial-with http://beta.quicklisp.org/archive/trivial-with/2017-08-30/trivial-with-quicklisp-2fd8ca54-git.tgz 1554 8b816ed9e2c29f3f8015efb749417e1f ee005208b66ede42608dd15837b701d270932620 trivial-with-quicklisp-2fd8ca54-git trivial-with.asd +trivial-ws http://beta.quicklisp.org/archive/trivial-ws/2018-01-31/trivial-ws-20180131-git.tgz 2798 d94a58b084bfae82b57533be1ab60d22 6b21f895b2401e4b6ba676597db3398d4d45eeaa trivial-ws-20180131-git trivial-ws-client.asd trivial-ws-test.asd trivial-ws.asd +trivial-yenc http://beta.quicklisp.org/archive/trivial-yenc/2016-12-04/trivial-yenc-20161204-git.tgz 24777 3e30073ec4a3aac9eb79bcedd773afd3 63208129d025e58445a65f7da343aaf5a2661d96 trivial-yenc-20161204-git trivial-yenc.asd +trivialib.bdd http://beta.quicklisp.org/archive/trivialib.bdd/2018-03-28/trivialib.bdd-20180328-git.tgz 5701 13f189714290a75342f159476d9df3d1 f71adf02c9caabe16c2f23318d992d67d7c2b25a trivialib.bdd-20180328-git trivialib.bdd.asd trivialib.bdd.test.asd +trivialib.type-unify http://beta.quicklisp.org/archive/trivialib.type-unify/2016-08-25/trivialib.type-unify-20160825-git.tgz 6556 039773d2b44f8c1fd8f517288b88a4ff 6bd076666d819c7e6443509bd6405d7e5d3704c9 trivialib.type-unify-20160825-git trivialib.type-unify.asd trivialib.type-unify.test.asd +twfy http://beta.quicklisp.org/archive/twfy/2013-04-20/twfy-20130420-git.tgz 6872 970b20e4c143014bf2faf5d470e3cf72 3840c3c70a63c07bf225bea595bc196ed243b17c twfy-20130420-git twfy.asd +type-i http://beta.quicklisp.org/archive/type-i/2019-12-27/type-i-20191227-git.tgz 5932 af344179d3f97b836d1e3106f8d1c306 ef2cd7a2e099a2d1c1bc1f5d913a711872735f1b type-i-20191227-git type-i.asd type-i.test.asd +type-r http://beta.quicklisp.org/archive/type-r/2019-12-27/type-r-20191227-git.tgz 10627 9dd5400746e6c8352fc4248e5384669a 82c0916f793c2f678770c2c0152dbd26af130259 type-r-20191227-git type-r.asd type-r.test.asd +uax-14 http://beta.quicklisp.org/archive/uax-14/2019-10-07/uax-14-20191007-git.tgz 130672 6b9518e234152ca5cb540e2ca6b81c17 e9838d6abfd6bc21873d737cc59eacc4aee37b8e uax-14-20191007-git uax-14-test.asd uax-14.asd +uax-9 http://beta.quicklisp.org/archive/uax-9/2019-10-07/uax-9-20191007-git.tgz 1794867 dc653d87a4ddfb75efec85030a074cbc 7cdb719c1cdc1b1724860826c9436f71db9898c8 uax-9-20191007-git uax-9-test.asd uax-9.asd +ubiquitous http://beta.quicklisp.org/archive/ubiquitous/2019-07-10/ubiquitous-20190710-git.tgz 43252 f1300d3ed47beda6abc92ef0d85a8eee 30b0eb81f56864c4e07a916d94a849c72577cd9e ubiquitous-20190710-git ubiquitous-concurrent.asd ubiquitous.asd +ucons http://beta.quicklisp.org/archive/ucons/2019-03-07/ucons-20190307-git.tgz 5200 44d78424883fa78514e14bfd24ddde67 d8fbdea632c3050f1a4bbd2f63b74e1cc0f626c7 ucons-20190307-git code/ucons.asd +ucw http://beta.quicklisp.org/archive/ucw/2016-02-08/ucw-20160208-darcs.tgz 164029 b5a4f28e311b70010bd98be79e544c48 d461b81886f15d368a521ba254c282f224638623 ucw-20160208-darcs ucw-core.asd ucw.asd +uffi http://beta.quicklisp.org/archive/uffi/2018-02-28/uffi-20180228-git.tgz 179928 b0dfb2f966912f4797327948aa7e9119 3fa7b46bc21bcbbc59528bf4c2ea9bda84f57088 uffi-20180228-git uffi-tests.asd uffi.asd +ufo http://beta.quicklisp.org/archive/ufo/2016-12-04/ufo-20161204-git.tgz 5130 bb490f5b3086088cab2746a7c7a102eb ff24b84a9e8f1118e87b77fe8edb002005b91883 ufo-20161204-git ufo-test.asd ufo.asd +ugly-tiny-infix-macro http://beta.quicklisp.org/archive/ugly-tiny-infix-macro/2016-08-25/ugly-tiny-infix-macro-20160825-git.tgz 8284 ed38d0a89cf772f96244934a78bc1ec4 3d5e3f693c1f45322d1c7f6d117fa96a3d9d4557 ugly-tiny-infix-macro-20160825-git ugly-tiny-infix-macro.asd +uiop http://beta.quicklisp.org/archive/uiop/2019-05-21/uiop-3.3.3.tgz 99847 64d561117f048ad8621eff7a6173d65e c044515fda0bcb9d12c1b53ba47f1aee03031f49 uiop-3.3.3 asdf-driver.asd uiop.asd +umbra http://beta.quicklisp.org/archive/umbra/2019-12-27/umbra-20191227-git.tgz 24348 7a8a74b32f35a6541c115af22f20a04e 716e497a8588bd0de7b3c30fa9f5decf78ce5dc1 umbra-20191227-git umbra.asd +umlisp http://beta.quicklisp.org/archive/umlisp/2018-02-28/umlisp-20180228-git.tgz 46926 26b8f39fc0e8833f389a322c41bb7a30 a7fbd8c2636c3dbc182355c9637fb7c90bcd1351 umlisp-20180228-git umlisp-tests.asd umlisp.asd +umlisp-orf http://beta.quicklisp.org/archive/umlisp-orf/2015-09-23/umlisp-orf-20150923-git.tgz 31495 401d1d133f874eccafc76426495bdfc6 340233287e9c9c427e2d0260eb2cb457cb494a56 umlisp-orf-20150923-git umlisp-orf.asd +unicly http://beta.quicklisp.org/archive/unicly/2012-09-09/unicly-20120909-git.tgz 101223 bb1940ca1f2a88b46863874742c7e469 74a73d2f1507e0bd808aefffa5e7519ccadcdfbb unicly-20120909-git unicly.asd +unit-formula http://beta.quicklisp.org/archive/unit-formula/2018-07-11/unit-formula-20180711-git.tgz 22478 4739cdb264153430300215eec7d8a766 43c9faa30a3d9bf36d81be4df653f66c5104a8c2 unit-formula-20180711-git unit-formulas.asd +unit-test http://beta.quicklisp.org/archive/unit-test/2012-05-20/unit-test-20120520-git.tgz 5026 ffcde1c03dd33862cd4f7288649c3cbc a90ba788826db66fb183ef221a2bd57550d66d51 unit-test-20120520-git unit-test.asd +universal-config http://beta.quicklisp.org/archive/universal-config/2018-04-30/universal-config-20180430-git.tgz 18717 ea3d382afa8904aa76d6e3131c89a1b8 b177d9d562fe68db71f805451e6d7e357647d055 universal-config-20180430-git universal-config.asd +unix-options http://beta.quicklisp.org/archive/unix-options/2015-10-31/unix-options-20151031-git.tgz 11220 3bbdeafbef3e7a2e94b9756bf173f636 64c26167d493cca5c981c1c9a3f923f7406d6e25 unix-options-20151031-git unix-options.asd +unix-opts http://beta.quicklisp.org/archive/unix-opts/2018-04-30/unix-opts-20180430-git.tgz 11405 2875ea0a1f5c49ef2697bb1046c4c4e5 4a650a081079badf6f7e93f4f50f5efa2ea77dae unix-opts-20180430-git unix-opts-tests.asd unix-opts.asd +uri-template http://beta.quicklisp.org/archive/uri-template/2019-08-13/uri-template-1.3.1.tgz 20667 2819c38acf5408c90ef2c4f12bfaf73e 42d350f11de6975925bd1aba0878e322836b8817 uri-template-1.3.1 uri-template.asd uri-template.test.asd +url-rewrite http://beta.quicklisp.org/archive/url-rewrite/2017-12-27/url-rewrite-20171227-git.tgz 12733 a27f51e1cd3b62263386c02b07b754b5 16fe74d55e44c734edc7286ac793686150721520 url-rewrite-20171227-git url-rewrite.asd +userial http://beta.quicklisp.org/archive/userial/2011-06-19/userial_0.8.2011.06.02.tgz 25305 18ca2d20cbb483ddb2cb6712387384dc 358b810d26b835ff5a26e1be33aeb6721801d94d userial_0.8.2011.06.02 userial-tests.asd userial.asd +usocket http://beta.quicklisp.org/archive/usocket/2019-12-27/usocket-0.8.3.tgz 85851 b1103034f32565487ab3b6eb92c0ca2b 12cc3af115d1d393cad4eae8e9b3e3aa123617ed usocket-0.8.3 usocket-server.asd usocket-test.asd usocket.asd +utilities.binary-dump http://beta.quicklisp.org/archive/utilities.binary-dump/2018-12-10/utilities.binary-dump-20181210-git.tgz 13155 2f2ae5e2669f8d4f3e0bbea638cf473f 437ea86b8f923e9929ffc644beebc1e687433e9f utilities.binary-dump-20181210-git utilities.binary-dump.asd +utilities.print-items http://beta.quicklisp.org/archive/utilities.print-items/2019-08-13/utilities.print-items-20190813-git.tgz 10205 0f26580bb5d3587ed1815f70976b2a0a 6ac5606c1d28cb88aa5f1c3e861653d738b756dc utilities.print-items-20190813-git utilities.print-items.asd +utilities.print-tree http://beta.quicklisp.org/archive/utilities.print-tree/2017-12-27/utilities.print-tree-20171227-git.tgz 9725 5a730c9e31eeaf14dd40a04fcb1c126e a9d3766bf42b8ffbfa90400e62430cd9612ab7c7 utilities.print-tree-20171227-git utilities.print-tree.asd +utility http://beta.quicklisp.org/archive/utility/2019-02-02/utility-20190202-git.tgz 5158 55e9e5ba352fe19b956af04fa4dc19bc 62360ca825f0bbbbaf2d244698a01cbf75f6e86e utility-20190202-git utility.asd +utility-arguments http://beta.quicklisp.org/archive/utility-arguments/2016-12-04/utility-arguments-20161204-git.tgz 8656 0f60552f326f7164cac4b957e4d48099 9cdfeb9cad7d4e0d84c18ac8f895ce7561bf62e4 utility-arguments-20161204-git utility-arguments.asd +utils-kt http://beta.quicklisp.org/archive/utils-kt/2018-03-28/utils-kt-20180328-git.tgz 17087 d953652f3e3d5bfa076af8d99abf8b6f bd13212a6d0d1e3538d9e0e21fe6d555ca461ee1 utils-kt-20180328-git utils-kt.asd +utm http://beta.quicklisp.org/archive/utm/2018-10-18/utm-20181018-git.tgz 5031 947c9a1da25a77c21cf9417245c0d170 d9f0506f6eb45e71215c986c569ed1d5b5f78331 utm-20181018-git utm.asd utm.test.asd +uuid http://beta.quicklisp.org/archive/uuid/2018-08-31/uuid-20180831-git.tgz 22230 ad7c7cbe9889e1ccd6aea7e63a230919 dbf0542e03040e75c3583c69aa252b5575446d17 uuid-20180831-git uuid.asd +varjo http://beta.quicklisp.org/archive/varjo/2019-10-07/varjo-release-quicklisp-6150bdcb-git.tgz 335430 d7a1a178eb64d77ee41be43c5c62b415 ee6c88aab96f8a3f9d5bf712ef5dde106c46e2ee varjo-release-quicklisp-6150bdcb-git varjo.asd varjo.import.asd varjo.tests.asd +vas-string-metrics http://beta.quicklisp.org/archive/vas-string-metrics/2016-02-08/vas-string-metrics-20160208-git.tgz 6807 5f38d4ee241c11286be6147f481e7fd0 f8d0b6752ab519cc94a92c2371aca239867a4b9f vas-string-metrics-20160208-git test.vas-string-metrics.asd vas-string-metrics.asd +vecto http://beta.quicklisp.org/archive/vecto/2017-12-27/vecto-1.5.tgz 70758 69e6b2f7fa10066d50f9134942afad73 e5c820e88138ed60294d2987002a523ce37e2b02 vecto-1.5 vecto.asd vectometry/vectometry.asd +vector http://beta.quicklisp.org/archive/vector/2013-01-28/vector-20130128-git.tgz 13555 d00644c19ce7e0d1302acda0bf238081 042f916e4c5c4648ab2b8e2d41f164783563522a vector-20130128-git com.elbeno.vector.asd +vectors http://beta.quicklisp.org/archive/vectors/2017-12-27/vectors-20171227-git.tgz 4968 413caa1cced2681421c9ee3438079a7c a52d5b2e5ff875860d90cd76f8cf63650041e60a vectors-20171227-git vectors.asd +verbose http://beta.quicklisp.org/archive/verbose/2019-10-07/verbose-20191007-git.tgz 61584 e3c00fd4bf624d2c6982e1fc4ff2f410 c803731cb2f4bada32b942a19a83034d5b6c0b35 verbose-20191007-git verbose.asd +vernacular http://beta.quicklisp.org/archive/vernacular/2019-11-30/vernacular-20191130-git.tgz 40968 8cd9c408b36fb1a34616cb2d35341cfa f947b87120806fe045a2641f04e0e0be2b3b3055 vernacular-20191130-git vernacular.asd +verrazano http://beta.quicklisp.org/archive/verrazano/2012-09-09/verrazano-20120909-darcs.tgz 154093 fdb516677e8414b3400fd8dd6f91817b 3dfe039d928da642c40544b7418fcc8929a43dae verrazano-20120909-darcs verrazano-runtime.asd verrazano.asd +vertex http://beta.quicklisp.org/archive/vertex/2015-06-08/vertex-20150608-git.tgz 3549 f0e1a725b6733155306c4dd9d8245ea8 27473fcccbf03bd3a904a3c0d04b8c40413c514d vertex-20150608-git vertex-test.asd vertex.asd +vgplot http://beta.quicklisp.org/archive/vgplot/2018-12-10/vgplot-20181210-git.tgz 18197 58711ed4482a29cdc31a3434f59ade7b 0fb4df3cdd8986b89ef01a21bddde9ce24b93874 vgplot-20181210-git vgplot.asd +vom http://beta.quicklisp.org/archive/vom/2016-08-25/vom-20160825-git.tgz 4286 ad16bdc0221b08de371be6ce25ce3d47 4618a41b412c27f8a543c70bef09b49d68d9b1f7 vom-20160825-git vom.asd +water http://beta.quicklisp.org/archive/water/2019-01-07/water-20190107-git.tgz 2387 8340d15004bc9b07d822eb08d73846d7 679bc44d0f73f8963f5ced8211c3abd45e7cb8b8 water-20190107-git water.asd +weblocks http://beta.quicklisp.org/archive/weblocks/2018-02-28/weblocks-20180228-git.tgz 312275 b6f3ca9a3ded521dafa271773a659883 e416f64744e54eb0e7cb6e199c09d3b797ea21b3 weblocks-20180228-git contrib/jwr/yui/weblocks-yui.asd contrib/s11001001/weblocks-s11.asd contrib/yarek/examples/weblocks-demo-popover/weblocks-demo-popover.asd contrib/yarek/weblocks-yarek.asd weblocks-scripts.asd weblocks-test.asd weblocks-util.asd weblocks.asd +weblocks-examples http://beta.quicklisp.org/archive/weblocks-examples/2017-04-03/weblocks-examples-20170403-git.tgz 375952 1b9270e0836945d03becda9cdb5187a6 ed2905772b09a5f2b2a053c3e6c080f8384e45bd weblocks-examples-20170403-git simple-blog/simple-blog.asd weblocks-clsql-demo/weblocks-clsql-demo.asd weblocks-demo/weblocks-demo.asd +weblocks-prototype-js http://beta.quicklisp.org/archive/weblocks-prototype-js/2016-09-29/weblocks-prototype-js-20160929-git.tgz 90118 d0771a1127d33de4a5151f53e728dd1c 507c4195da245c61e9cbd80863039b51661b8dc7 weblocks-prototype-js-20160929-git weblocks-prototype-js.asd +weblocks-stores http://beta.quicklisp.org/archive/weblocks-stores/2016-12-08/weblocks-stores-20161208-git.tgz 25350 e1af85f0729db0461ae83c659b2532cd 55f2582051f6490ec3e505ddc8c81edb063794c8 weblocks-stores-20161208-git src/store/clsql/weblocks-clsql.asd src/store/custom/weblocks-custom.asd src/store/memory/weblocks-memory.asd src/store/montezuma/weblocks-montezuma.asd src/store/perec/weblocks-perec.asd src/store/postmodern/weblocks-postmodern.asd src/store/prevalence/weblocks-prevalence.asd weblocks-store-test.asd weblocks-stores.asd +weblocks-tree-widget http://beta.quicklisp.org/archive/weblocks-tree-widget/2014-12-17/weblocks-tree-widget-20141217-git.tgz 10153 5b1d46fcd648d745bbaff396d3f36146 3c7ebac35e2c49ca5f288b84449f247475450854 weblocks-tree-widget-20141217-git weblocks-tree-widget.asd +weblocks-utils http://beta.quicklisp.org/archive/weblocks-utils/2017-01-24/weblocks-utils-20170124-git.tgz 15494 6434a0c9e0384261c38a620b4beeca8a d73a491d6787b8338f269427c1d0e740e5de042b weblocks-utils-20170124-git weblocks-utils.asd +websocket-driver http://beta.quicklisp.org/archive/websocket-driver/2019-01-07/websocket-driver-20190107-git.tgz 11394 d1504b09817ad229459d33120e9c52a1 7a704d461b3cde4dd89b4eab9d738a52bfcdae31 websocket-driver-20190107-git websocket-driver-base.asd websocket-driver-client.asd websocket-driver-server.asd websocket-driver.asd +weft http://beta.quicklisp.org/archive/weft/2018-02-28/weft-20180228-git.tgz 6282 ec7196f159294035d3c06b5723920058 d9ea5ff22d830c1f0deb6fd047e4b62ec280c74c weft-20180228-git weft.asd +westbrook http://beta.quicklisp.org/archive/westbrook/2018-01-31/westbrook-20180131-git.tgz 3249 43e514336921135f6fc3c1b3063eaf4b 97ed8af62728b92027a7321387a64b918475ca7c westbrook-20180131-git westbrook-tests.asd westbrook.asd +what3words http://beta.quicklisp.org/archive/what3words/2016-12-04/what3words-20161204-git.tgz 5600 54303b21497ffca394575c7376c8b9f3 7b37b1c4c32ab419d4f07cf6f1798f4a0b69b88f what3words-20161204-git what3words.asd +which http://beta.quicklisp.org/archive/which/2016-04-21/which-20160421-git.tgz 2063 d352101dca7f6e985c0e437bcdb6fe40 528a7fdbb3c1485e5685145fd0023ece6a9b32c5 which-20160421-git which-test.asd which.asd +whofields http://beta.quicklisp.org/archive/whofields/2018-08-31/whofields-20180831-git.tgz 5512 5679091e30971df0d7aae59146a3b1c6 520ef39d46eed4734d891be27a44fadd80b54ae4 whofields-20180831-git whofields.asd +wild-package-inferred-system http://beta.quicklisp.org/archive/wild-package-inferred-system/2019-01-07/wild-package-inferred-system-20190107-git.tgz 9603 5699a756f42960ef0c7ed450572e2f08 fbd51d7acb33d182d3b105fa01b7f4013bcbded8 wild-package-inferred-system-20190107-git test/foo-wild/foo-wild.asd wild-package-inferred-system.asd +winhttp http://beta.quicklisp.org/archive/winhttp/2019-01-07/winhttp-20190107-git.tgz 13864 03ad3ec6a6f5ca7f86fe4956dba43021 f2a6ac37a949396ed7898af1ffcb7f56ace0a2a1 winhttp-20190107-git winhttp.asd +winlock http://beta.quicklisp.org/archive/winlock/2019-11-30/winlock-20191130-git.tgz 3577 f637484323c2b64fc680325bcadef786 fc646ddf5184afcbf5c84370b68087120a63e7bd winlock-20191130-git winlock.asd +with-c-syntax http://beta.quicklisp.org/archive/with-c-syntax/2019-05-21/with-c-syntax-20190521-git.tgz 59911 7cf31666dd69c8cde2471fabeb593733 46347e74d5741633ee26723301c3b11c3be4c3b6 with-c-syntax-20190521-git with-c-syntax-test.asd with-c-syntax.asd +with-cached-reader-conditionals http://beta.quicklisp.org/archive/with-cached-reader-conditionals/2017-06-30/with-cached-reader-conditionals-20170630-git.tgz 2457 16049564ecfdb5a6db9edd1bdcf0a921 4be7101d32ea9f59c716ce5b822a58e0bb124a05 with-cached-reader-conditionals-20170630-git with-cached-reader-conditionals.asd +with-output-to-stream http://beta.quicklisp.org/archive/with-output-to-stream/2019-10-07/with-output-to-stream_1.0.tgz 4266 d9bee5027d6c04bcd7f63f4c48706f5c a3b23295277552cf9dd81191edd50ed8019a1c67 with-output-to-stream_1.0 tests/with-output-to-stream_tests.asd with-output-to-stream.asd +with-setf http://beta.quicklisp.org/archive/with-setf/2018-02-28/with-setf-release-quicklisp-df3eed9d-git.tgz 2558 9218b3765e9e2fd26a7f103e63fc89fe a6db3e7df0bb1b289e2134d8668be0ff51b4389e with-setf-release-quicklisp-df3eed9d-git with-setf.asd +with-shadowed-bindings http://beta.quicklisp.org/archive/with-shadowed-bindings/2019-01-07/with-shadowed-bindings-1.0.tgz 5127 1f583c77f5d2c67c934ab33d2ba810c3 a786cd36c9aee7348f63f7d6fe482225a728ccb2 with-shadowed-bindings-1.0 tests/with-shadowed-bindings_tests.asd with-shadowed-bindings.asd +with-user-abort http://beta.quicklisp.org/archive/with-user-abort/2019-11-30/with-user-abort-20191130-git.tgz 962 b66699b4f17ac57a0dfd3d4dc12c287b 1cdb0588df587008e8c151e547975707ba56c9e0 with-user-abort-20191130-git with-user-abort.asd +woo http://beta.quicklisp.org/archive/woo/2019-11-30/woo-20191130-git.tgz 225538 a876d194ed1ccb7439e3f3b6da63760e 1c4d4a1928361e61fc45518b6bcaf1f094484470 woo-20191130-git clack-handler-woo.asd woo-test.asd woo.asd +wookie http://beta.quicklisp.org/archive/wookie/2019-11-30/wookie-20191130-git.tgz 29738 5e5d6537637312919fd528bb1d0c1eba 660d6b8277d9bc3a82aeb0db51bb2d51e71a3678 wookie-20191130-git wookie.asd +wordnet http://beta.quicklisp.org/archive/wordnet/2019-05-21/wordnet-20190521-git.tgz 10484879 ee0272f4d2fa645dd13d555d759a3345 8638e9e3ac07cdbacab95baa0f03a5d20ecc83e9 wordnet-20190521-git wordnet.asd +workout-timer http://beta.quicklisp.org/archive/workout-timer/2017-12-27/workout-timer-20171227-git.tgz 319162 b5dc79cd91c6d2a4aed6f67a244bff9a d99a5b7d16a1b94b17b0c248b5bb4e1873d7dff8 workout-timer-20171227-git workout-timer.asd +wu-decimal http://beta.quicklisp.org/archive/wu-decimal/2013-01-28/wu-decimal-20130128-git.tgz 6244 e0676ea5ba7ce65e4d80cc5128c1e668 b37c145557a1b9541f9219629c1091976dc2656f wu-decimal-20130128-git wu-decimal.asd +wu-sugar http://beta.quicklisp.org/archive/wu-sugar/2016-08-25/wu-sugar-20160825-git.tgz 3555 ef7aec6772cda55c04bf117a2a8cb4ac a2dde559d7e28bdaa93dfcf0e1f080447873c9d3 wu-sugar-20160825-git wu-sugar.asd +wuwei http://beta.quicklisp.org/archive/wuwei/2019-02-02/wuwei-20190202-git.tgz 140953 e389c75644b0a8a5900e21e0daecfcd8 da295007ea36414aabdd389c4fff3aa3a40b10ce wuwei-20190202-git wuwei.asd +x.fdatatypes http://beta.quicklisp.org/archive/x.fdatatypes/2015-07-09/x.fdatatypes-20150709-git.tgz 15713 45c2b2939107acb4a07fbf66a1479750 8f58da1f8c5fb55a797b6458f81033ebe3caf9c4 x.fdatatypes-20150709-git x.fdatatypes-iterate.asd x.fdatatypes.asd +x.let-star http://beta.quicklisp.org/archive/x.let-star/2015-07-09/x.let-star-20150709-git.tgz 7921 2a0f7fbf6a621cd121020e140af08ded c66f72bf9b9e42964818dcc75c322203a262c52b x.let-star-20150709-git x.let-star.asd +xarray http://beta.quicklisp.org/archive/xarray/2014-01-13/xarray-20140113-git.tgz 26181 477bb421f87f6de0236065bf81949a32 5466b0687c3ac4a6466d2761b9d29510658785bb xarray-20140113-git xarray-test.asd xarray.asd +xecto http://beta.quicklisp.org/archive/xecto/2015-12-18/xecto-20151218-git.tgz 29803 f770596c9d7a9ce86fb2d7952bc9e40e 489a3f39048451dfaab304a73681d5f8ce779a8b xecto-20151218-git xecto.asd +xhtmlambda http://beta.quicklisp.org/archive/xhtmlambda/2019-01-07/xhtmlambda-20190107-git.tgz 49855 70ddb72e53acf4cfe8eb5610164e28f5 7c03dc39b2d88d62be563748aca9c86613c1c84c xhtmlambda-20190107-git xhtmlambda.asd +xhtmlgen http://beta.quicklisp.org/archive/xhtmlgen/2017-01-24/xhtmlgen-20170124-git.tgz 4264 17fc90eab99b1fb0cf6335065e84c109 bbb503e316f419d7cffb2f3f648e0227bc61cb15 xhtmlgen-20170124-git xhtmlgen.asd +xlsx http://beta.quicklisp.org/archive/xlsx/2018-07-11/xlsx-20180711-git.tgz 3050 10133595e8973f9acdd0301c00d04f8c 5a5dc8579c348ffae3625fbb088aa4ee008e3eaf xlsx-20180711-git xlsx.asd +xlunit http://beta.quicklisp.org/archive/xlunit/2015-09-23/xlunit-20150923-git.tgz 9484 1c673862f57e998c7a7b8e74de0d0c92 de0142632a8227f339178055eb5543a0c8dce789 xlunit-20150923-git xlunit.asd +xml-emitter http://beta.quicklisp.org/archive/xml-emitter/2019-11-30/xml-emitter-20191130-git.tgz 6734 6976af2c99934b14486c754dae996801 2895936a28c46607a5fb737b29d80c8e7f25a0df xml-emitter-20191130-git xml-emitter.asd +xml-mop http://beta.quicklisp.org/archive/xml-mop/2011-04-18/xml-mop-20110418-git.tgz 15391 028fde76c0d121865cb5167962a4b78b f5fb4a43a2defedb352b072be94d4c22f433dfc3 xml-mop-20110418-git xml-mop.asd +xml.location http://beta.quicklisp.org/archive/xml.location/2018-08-31/xml.location-20180831-git.tgz 31123 ad828a5b218d4a88e9e102ad534920ed 4679296b59b742a41b58a8d8f4be5e5e0a08be2c xml.location-20180831-git xml.location-and-local-time.asd xml.location.asd +xmls http://beta.quicklisp.org/archive/xmls/2018-04-30/xmls-3.0.2.tgz 113037 2462bab4a5d74e87ef7bdef41cd06dc8 80181e6c0ac15a4a41eb352b50b871679c65ab4d xmls-3.0.2 xmls.asd +xptest http://beta.quicklisp.org/archive/xptest/2015-09-23/xptest-20150923-git.tgz 6874 61f6ff5cc44cf8da5d8036084a31fbc3 09eebbc1fa611a9b628c9d2de12f6c81bf4420b8 xptest-20150923-git xptest.asd +xsubseq http://beta.quicklisp.org/archive/xsubseq/2017-08-30/xsubseq-20170830-git.tgz 4006 960bb8f329649b6e4b820e065e6b38e8 77ef22871e590349e22e892cd8f80121db1b1566 xsubseq-20170830-git xsubseq-test.asd xsubseq.asd +xuriella http://beta.quicklisp.org/archive/xuriella/2012-03-05/xuriella-20120305-git.tgz 122204 55eb6e13da338bc47b640a2767b0bd20 49899b4682e3a72322c69feb21ced8a109675833 xuriella-20120305-git xuriella.asd +yaclml http://beta.quicklisp.org/archive/yaclml/2018-01-31/yaclml-20180131-git.tgz 32006 b3dba0cd334aef4fc75b465b2b31a94a 76172119d82a08b4483721cc6746228c8d9b8079 yaclml-20180131-git yaclml.asd +yason http://beta.quicklisp.org/archive/yason/2019-12-27/yason-v0.7.8.tgz 27918 7c3231635aa494f1721273713ea8c56a ac532785adb017b0eecdd6dfa9b3ab1add7100f9 yason-v0.7.8 yason.asd +youtube http://beta.quicklisp.org/archive/youtube/2019-12-27/youtube-20191227-git.tgz 3054 36af0a0118f51e4e57d1dee28f720a44 dc8b73c9c8d14ba29827baf8ef5bda3b0a25d275 youtube-20191227-git youtube.asd +zacl http://beta.quicklisp.org/archive/zacl/2018-12-10/zacl-20181210-git.tgz 20817 08bff0310769f27a0d24ad7ebd8ae924 315cf8c605344323d082cdcd0bb82c6dfd59c697 zacl-20181210-git zacl.asd +zaws http://beta.quicklisp.org/archive/zaws/2015-04-07/zaws-20150407-git.tgz 13832 13ada144680e2f5d111df8f0a0217d99 8d181469163fac8b77280c98c5ab28ca7098fe4b zaws-20150407-git xml/zaws-xml.asd zaws.asd +zbucium http://beta.quicklisp.org/archive/zbucium/2019-07-10/zbucium-20190710-git.tgz 4503 90b10e33e3fa82d42174016881d557bc d0e1df0c25eb87e1e0e66af27fd2dac5b20c7fb4 zbucium-20190710-git zbucium.asd +zcdb http://beta.quicklisp.org/archive/zcdb/2015-04-07/zcdb-1.0.4.tgz 7393 e924c2b419f9875364cd662184fc55d1 db5f7a8e8a22f858794b64ef255f7dea015835f8 zcdb-1.0.4 zcdb.asd +zenekindarl http://beta.quicklisp.org/archive/zenekindarl/2017-11-30/zenekindarl-20171130-git.tgz 17395 2c8e9002b6434d92761ced8e187c5903 0a732633d8173828feec7a8b5eaab103de638e7f zenekindarl-20171130-git zenekindarl-test.asd zenekindarl.asd +zip http://beta.quicklisp.org/archive/zip/2015-06-08/zip-20150608-git.tgz 20940 5be194863779dcbd3c83e07524392f14 a8fa33dc2a19df78942e02c0e35a78f054992bd7 zip-20150608-git zip.asd +ziz http://beta.quicklisp.org/archive/ziz/2019-10-07/ziz-20191007-git.tgz 3184 24b32be09b15855c77b6fddc2d6d6ea3 f9d30703cd655564a12063a77b466930cd52a41d ziz-20191007-git ziz.asd +zlib http://beta.quicklisp.org/archive/zlib/2017-04-03/zlib-20170403-git.tgz 9104 67450036249df47288f4a8330ea28f57 498b41ab3e46c63d5f0ae3ece8eeb47c95009bad zlib-20170403-git zlib.asd +zpb-exif http://beta.quicklisp.org/archive/zpb-exif/2015-04-07/zpb-exif-1.2.3.tgz 15564 f2286ce8d693823e55886c2cd5d73390 69dfc9d86bdf5bd858815c453da0db024556dcfe zpb-exif-1.2.3 zpb-exif.asd +zpb-ttf http://beta.quicklisp.org/archive/zpb-ttf/2013-07-20/zpb-ttf-1.0.3.tgz 44869 1e896d8b0b01babab882e43fe4c3c2d4 f144607522f1fd0914e5576581b459e017cbde9f zpb-ttf-1.0.3 zpb-ttf.asd +zpng http://beta.quicklisp.org/archive/zpng/2015-04-07/zpng-1.2.2.tgz 40141 0a208f4ce0087ef578d477341d5f4078 0374a5e03f266152dea01c6fff9839798725697c zpng-1.2.2 zpng.asd +zs3 http://beta.quicklisp.org/archive/zs3/2019-10-07/zs3-1.3.3.tgz 57149 5ea13aa7a490758882e245c3f8bb063e 8b3bcc4f7a524ca09f3b6fa6600c510e1f2d9e3b zs3-1.3.3 zs3.asd +zsort http://beta.quicklisp.org/archive/zsort/2012-05-20/zsort-20120520-git.tgz 6259 08689032aed3f283c9ab84b536d0aca3 5b8b68c44983d394a8328f30cdc2b8fb6c96331a zsort-20120520-git zsort.asd diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/.boring b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/.boring new file mode 100644 index 0000000..dfa9e6d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/.boring @@ -0,0 +1,13 @@ +# Boring file regexps: +~$ +^_darcs +^\{arch\} +^.arch-ids +\# +\.dfsl$ +\.ppcf$ +\.fasl$ +\.x86f$ +\.fas$ +\.lib$ +^public_html diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/.gitignore b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/.gitignore new file mode 100644 index 0000000..e832e94 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/.gitignore @@ -0,0 +1,4 @@ +*.fasl +*~ +\#* +*.patch diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/AUTHORS b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/AUTHORS new file mode 100644 index 0000000..b550ea5 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/AUTHORS @@ -0,0 +1,9 @@ + +ACTA EST FABULA PLAUDITE + +Nikodemus Siivola +Attila Lendvai +Marco Baringer +Robert Strandh +Luis Oliveira +Tobias C. Rittweiler \ No newline at end of file diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/LICENCE b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/LICENCE new file mode 100644 index 0000000..b5140fb --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/LICENCE @@ -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. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/README b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/README new file mode 100644 index 0000000..59e49ab --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/README @@ -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. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/alexandria-tests.asd b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/alexandria-tests.asd new file mode 100644 index 0000000..445c18c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/alexandria-tests.asd @@ -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 , 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)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/alexandria.asd b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/alexandria.asd new file mode 100644 index 0000000..db10e4f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/alexandria.asd @@ -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")))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/arrays.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/arrays.lisp new file mode 100644 index 0000000..76c1879 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/arrays.lisp @@ -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)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/binding.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/binding.lisp new file mode 100644 index 0000000..37a3d52 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/binding.lisp @@ -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)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/conditions.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/conditions.lisp new file mode 100644 index 0000000..ac471cc --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/conditions.lisp @@ -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))))))))) \ No newline at end of file diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/control-flow.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/control-flow.lisp new file mode 100644 index 0000000..dd00df3 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/control-flow.lisp @@ -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))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/definitions.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/definitions.lisp new file mode 100644 index 0000000..863e1f6 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/definitions.lisp @@ -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)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/.gitignore b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/.gitignore new file mode 100644 index 0000000..f22577b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/.gitignore @@ -0,0 +1,3 @@ +alexandria +include + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/Makefile b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/Makefile new file mode 100644 index 0000000..85eb818 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/Makefile @@ -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 diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/alexandria.texinfo b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/alexandria.texinfo new file mode 100644 index 0000000..89b03ac --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/alexandria.texinfo @@ -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 diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/docstrings.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/docstrings.lisp new file mode 100644 index 0000000..51dda07 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/docstrings.lisp @@ -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 , 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 +\"__.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 \".texinfo\" is generated. + +The definitions can be referenced using Texinfo statements like +@ref{__.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))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/features.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/features.lisp new file mode 100644 index 0000000..67348db --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/features.lisp @@ -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)))))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/functions.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/functions.lisp new file mode 100644 index 0000000..dd83e38 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/functions.lisp @@ -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)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/hash-tables.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/hash-tables.lisp new file mode 100644 index 0000000..a9f7902 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/hash-tables.lisp @@ -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)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/io.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/io.lisp new file mode 100644 index 0000000..28bf5e6 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/io.lisp @@ -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 "~@" '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 "~@" '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)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/lists.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/lists.lisp new file mode 100644 index 0000000..5128607 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/lists.lisp @@ -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))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/macros.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/macros.lisp new file mode 100644 index 0000000..4364ad6 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/macros.lisp @@ -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 (( ) + ... + ( )) + ) + +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))) + + + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/numbers.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/numbers.lisp new file mode 100644 index 0000000..1c06f71 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/numbers.lisp @@ -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)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/package.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/package.lisp new file mode 100644 index 0000000..f9d2014 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/package.lisp @@ -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 + )) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/sequences.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/sequences.lisp new file mode 100644 index 0000000..21464f5 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/sequences.lisp @@ -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))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/strings.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/strings.lisp new file mode 100644 index 0000000..e9fd91c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/strings.lisp @@ -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)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/symbols.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/symbols.lisp new file mode 100644 index 0000000..5733d3e --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/symbols.lisp @@ -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)))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/tests.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/tests.lisp new file mode 100644 index 0000000..b70ef04 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/tests.lisp @@ -0,0 +1,2047 @@ +(in-package :cl-user) + +(defpackage :alexandria-tests + (:use :cl :alexandria #+sbcl :sb-rt #-sbcl :rtest) + (:import-from #+sbcl :sb-rt #-sbcl :rtest + #:*compile-tests* #:*expected-failures*)) + +(in-package :alexandria-tests) + +(defun run-tests (&key ((:compiled *compile-tests*))) + (do-tests)) + +(defun hash-table-test-name (name) + ;; Workaround for Clisp calling EQL in a hash-table FASTHASH-EQL. + (hash-table-test (make-hash-table :test name))) + +;;;; Arrays + +(deftest copy-array.1 + (let* ((orig (vector 1 2 3)) + (copy (copy-array orig))) + (values (eq orig copy) (equalp orig copy))) + nil t) + +(deftest copy-array.2 + (let ((orig (make-array 1024 :fill-pointer 0))) + (vector-push-extend 1 orig) + (vector-push-extend 2 orig) + (vector-push-extend 3 orig) + (let ((copy (copy-array orig))) + (values (eq orig copy) (equalp orig copy) + (array-has-fill-pointer-p copy) + (eql (fill-pointer orig) (fill-pointer copy))))) + nil t t t) + +(deftest copy-array.3 + (let* ((orig (vector 1 2 3)) + (copy (copy-array orig))) + (typep copy 'simple-array)) + t) + +(deftest copy-array.4 + (let ((orig (make-array 21 + :adjustable t + :fill-pointer 0))) + (dotimes (n 42) + (vector-push-extend n orig)) + (let ((copy (copy-array orig + :adjustable nil + :fill-pointer nil))) + (typep copy 'simple-array))) + t) + +(deftest array-index.1 + (typep 0 'array-index) + t) + +;;;; Conditions + +(deftest unwind-protect-case.1 + (let (result) + (unwind-protect-case () + (random 10) + (:normal (push :normal result)) + (:abort (push :abort result)) + (:always (push :always result))) + result) + (:always :normal)) + +(deftest unwind-protect-case.2 + (let (result) + (unwind-protect-case () + (random 10) + (:always (push :always result)) + (:normal (push :normal result)) + (:abort (push :abort result))) + result) + (:normal :always)) + +(deftest unwind-protect-case.3 + (let (result1 result2 result3) + (ignore-errors + (unwind-protect-case () + (error "FOOF!") + (:normal (push :normal result1)) + (:abort (push :abort result1)) + (:always (push :always result1)))) + (catch 'foof + (unwind-protect-case () + (throw 'foof 42) + (:normal (push :normal result2)) + (:abort (push :abort result2)) + (:always (push :always result2)))) + (block foof + (unwind-protect-case () + (return-from foof 42) + (:normal (push :normal result3)) + (:abort (push :abort result3)) + (:always (push :always result3)))) + (values result1 result2 result3)) + (:always :abort) + (:always :abort) + (:always :abort)) + +(deftest unwind-protect-case.4 + (let (result) + (unwind-protect-case (aborted-p) + (random 42) + (:always (setq result aborted-p))) + result) + nil) + +(deftest unwind-protect-case.5 + (let (result) + (block foof + (unwind-protect-case (aborted-p) + (return-from foof) + (:always (setq result aborted-p)))) + result) + t) + +;;;; Control flow + +(deftest switch.1 + (switch (13 :test =) + (12 :oops) + (13.0 :yay)) + :yay) + +(deftest switch.2 + (switch (13) + ((+ 12 2) :oops) + ((- 13 1) :oops2) + (t :yay)) + :yay) + +(deftest eswitch.1 + (let ((x 13)) + (eswitch (x :test =) + (12 :oops) + (13.0 :yay))) + :yay) + +(deftest eswitch.2 + (let ((x 13)) + (eswitch (x :key 1+) + (11 :oops) + (14 :yay))) + :yay) + +(deftest cswitch.1 + (cswitch (13 :test =) + (12 :oops) + (13.0 :yay)) + :yay) + +(deftest cswitch.2 + (cswitch (13 :key 1-) + (12 :yay) + (13.0 :oops)) + :yay) + +(deftest multiple-value-prog2.1 + (multiple-value-prog2 + (values 1 1 1) + (values 2 20 200) + (values 3 3 3)) + 2 20 200) + +(deftest nth-value-or.1 + (multiple-value-bind (a b c) + (nth-value-or 1 + (values 1 nil 1) + (values 2 2 2)) + (= a b c 2)) + t) + +(deftest whichever.1 + (let ((x (whichever 1 2 3))) + (and (member x '(1 2 3)) t)) + t) + +(deftest whichever.2 + (let* ((a 1) + (b 2) + (c 3) + (x (whichever a b c))) + (and (member x '(1 2 3)) t)) + t) + +(deftest xor.1 + (xor nil nil 1 nil) + 1 + t) + +(deftest xor.2 + (xor nil nil 1 2) + nil + nil) + +(deftest xor.3 + (xor nil nil nil) + nil + t) + +;;;; Definitions + +(deftest define-constant.1 + (let ((name (gensym))) + (eval `(define-constant ,name "FOO" :test 'equal)) + (eval `(define-constant ,name "FOO" :test 'equal)) + (values (equal "FOO" (symbol-value name)) + (constantp name))) + t + t) + +(deftest define-constant.2 + (let ((name (gensym))) + (eval `(define-constant ,name 13)) + (eval `(define-constant ,name 13)) + (values (eql 13 (symbol-value name)) + (constantp name))) + t + t) + +;;;; Errors + +;;; TYPEP is specified to return a generalized boolean and, for +;;; example, ECL exploits this by returning the superclasses of ERROR +;;; in this case. +(defun errorp (x) + (not (null (typep x 'error)))) + +(deftest required-argument.1 + (multiple-value-bind (res err) + (ignore-errors (required-argument)) + (errorp err)) + t) + +;;;; Hash tables + +(deftest ensure-gethash.1 + (let ((table (make-hash-table)) + (x (list 1))) + (multiple-value-bind (value already-there) + (ensure-gethash x table 42) + (and (= value 42) + (not already-there) + (= 42 (gethash x table)) + (multiple-value-bind (value2 already-there2) + (ensure-gethash x table 13) + (and (= value2 42) + already-there2 + (= 42 (gethash x table))))))) + t) + +(deftest ensure-gethash.2 + (let ((table (make-hash-table)) + (count 0)) + (multiple-value-call #'values + (ensure-gethash (progn (incf count) :foo) + (progn (incf count) table) + (progn (incf count) :bar)) + (gethash :foo table) + count)) + :bar nil :bar t 3) + +(deftest copy-hash-table.1 + (let ((orig (make-hash-table :test 'eq :size 123)) + (foo "foo")) + (setf (gethash orig orig) t + (gethash foo orig) t) + (let ((eq-copy (copy-hash-table orig)) + (eql-copy (copy-hash-table orig :test 'eql)) + (equal-copy (copy-hash-table orig :test 'equal)) + (equalp-copy (copy-hash-table orig :test 'equalp))) + (list (eql (hash-table-size eq-copy) (hash-table-size orig)) + (eql (hash-table-rehash-size eq-copy) + (hash-table-rehash-size orig)) + (hash-table-count eql-copy) + (gethash orig eq-copy) + (gethash (copy-seq foo) eql-copy) + (gethash foo eql-copy) + (gethash (copy-seq foo) equal-copy) + (gethash "FOO" equal-copy) + (gethash "FOO" equalp-copy)))) + (t t 2 t nil t t nil t)) + +(deftest copy-hash-table.2 + (let ((ht (make-hash-table)) + (list (list :list (vector :A :B :C)))) + (setf (gethash 'list ht) list) + (let* ((shallow-copy (copy-hash-table ht)) + (deep1-copy (copy-hash-table ht :key 'copy-list)) + (list (gethash 'list ht)) + (shallow-list (gethash 'list shallow-copy)) + (deep1-list (gethash 'list deep1-copy))) + (list (eq ht shallow-copy) + (eq ht deep1-copy) + (eq list shallow-list) + (eq list deep1-list) ; outer list was copied. + (eq (second list) (second shallow-list)) + (eq (second list) (second deep1-list)) ; inner vector wasn't copied. + ))) + (nil nil t nil t t)) + +(deftest maphash-keys.1 + (let ((keys nil) + (table (make-hash-table))) + (declare (notinline maphash-keys)) + (dotimes (i 10) + (setf (gethash i table) t)) + (maphash-keys (lambda (k) (push k keys)) table) + (set-equal keys '(0 1 2 3 4 5 6 7 8 9))) + t) + +(deftest maphash-values.1 + (let ((vals nil) + (table (make-hash-table))) + (declare (notinline maphash-values)) + (dotimes (i 10) + (setf (gethash i table) (- i))) + (maphash-values (lambda (v) (push v vals)) table) + (set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9))) + t) + +(deftest hash-table-keys.1 + (let ((table (make-hash-table))) + (dotimes (i 10) + (setf (gethash i table) t)) + (set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9))) + t) + +(deftest hash-table-values.1 + (let ((table (make-hash-table))) + (dotimes (i 10) + (setf (gethash (gensym) table) i)) + (set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9))) + t) + +(deftest hash-table-alist.1 + (let ((table (make-hash-table))) + (dotimes (i 10) + (setf (gethash i table) (- i))) + (let ((alist (hash-table-alist table))) + (list (length alist) + (assoc 0 alist) + (assoc 3 alist) + (assoc 9 alist) + (assoc nil alist)))) + (10 (0 . 0) (3 . -3) (9 . -9) nil)) + +(deftest hash-table-plist.1 + (let ((table (make-hash-table))) + (dotimes (i 10) + (setf (gethash i table) (- i))) + (let ((plist (hash-table-plist table))) + (list (length plist) + (getf plist 0) + (getf plist 2) + (getf plist 7) + (getf plist nil)))) + (20 0 -2 -7 nil)) + +(deftest alist-hash-table.1 + (let* ((alist '((0 a) (1 b) (2 c))) + (table (alist-hash-table alist))) + (list (hash-table-count table) + (gethash 0 table) + (gethash 1 table) + (gethash 2 table) + (eq (hash-table-test-name 'eql) + (hash-table-test table)))) + (3 (a) (b) (c) t)) + +(deftest alist-hash-table.duplicate-keys + (let* ((alist '((0 a) (1 b) (0 c) (1 d) (2 e))) + (table (alist-hash-table alist))) + (list (hash-table-count table) + (gethash 0 table) + (gethash 1 table) + (gethash 2 table))) + (3 (a) (b) (e))) + +(deftest plist-hash-table.1 + (let* ((plist '(:a 1 :b 2 :c 3)) + (table (plist-hash-table plist :test 'eq))) + (list (hash-table-count table) + (gethash :a table) + (gethash :b table) + (gethash :c table) + (gethash 2 table) + (gethash nil table) + (eq (hash-table-test-name 'eq) + (hash-table-test table)))) + (3 1 2 3 nil nil t)) + +(deftest plist-hash-table.duplicate-keys + (let* ((plist '(:a 1 :b 2 :a 3 :b 4 :c 5)) + (table (plist-hash-table plist))) + (list (hash-table-count table) + (gethash :a table) + (gethash :b table) + (gethash :c table))) + (3 1 2 5)) + +;;;; Functions + +(deftest disjoin.1 + (let ((disjunction (disjoin (lambda (x) + (and (consp x) :cons)) + (lambda (x) + (and (stringp x) :string))))) + (list (funcall disjunction 'zot) + (funcall disjunction '(foo bar)) + (funcall disjunction "test"))) + (nil :cons :string)) + +(deftest disjoin.2 + (let ((disjunction (disjoin #'zerop))) + (list (funcall disjunction 0) + (funcall disjunction 1))) + (t nil)) + +(deftest conjoin.1 + (let ((conjunction (conjoin #'consp + (lambda (x) + (stringp (car x))) + (lambda (x) + (char (car x) 0))))) + (list (funcall conjunction 'zot) + (funcall conjunction '(foo)) + (funcall conjunction '("foo")))) + (nil nil #\f)) + +(deftest conjoin.2 + (let ((conjunction (conjoin #'zerop))) + (list (funcall conjunction 0) + (funcall conjunction 1))) + (t nil)) + +(deftest compose.1 + (let ((composite (compose '1+ + (lambda (x) + (* x 2)) + #'read-from-string))) + (funcall composite "1")) + 3) + +(deftest compose.2 + (let ((composite + (locally (declare (notinline compose)) + (compose '1+ + (lambda (x) + (* x 2)) + #'read-from-string)))) + (funcall composite "2")) + 5) + +(deftest compose.3 + (let ((compose-form (funcall (compiler-macro-function 'compose) + '(compose '1+ + (lambda (x) + (* x 2)) + #'read-from-string) + nil))) + (let ((fun (funcall (compile nil `(lambda () ,compose-form))))) + (funcall fun "3"))) + 7) + +(deftest compose.4 + (let ((composite (compose #'zerop))) + (list (funcall composite 0) + (funcall composite 1))) + (t nil)) + +(deftest multiple-value-compose.1 + (let ((composite (multiple-value-compose + #'truncate + (lambda (x y) + (values y x)) + (lambda (x) + (with-input-from-string (s x) + (values (read s) (read s))))))) + (multiple-value-list (funcall composite "2 7"))) + (3 1)) + +(deftest multiple-value-compose.2 + (let ((composite (locally (declare (notinline multiple-value-compose)) + (multiple-value-compose + #'truncate + (lambda (x y) + (values y x)) + (lambda (x) + (with-input-from-string (s x) + (values (read s) (read s)))))))) + (multiple-value-list (funcall composite "2 11"))) + (5 1)) + +(deftest multiple-value-compose.3 + (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose) + '(multiple-value-compose + #'truncate + (lambda (x y) + (values y x)) + (lambda (x) + (with-input-from-string (s x) + (values (read s) (read s))))) + nil))) + (let ((fun (funcall (compile nil `(lambda () ,compose-form))))) + (multiple-value-list (funcall fun "2 9")))) + (4 1)) + +(deftest multiple-value-compose.4 + (let ((composite (multiple-value-compose #'truncate))) + (multiple-value-list (funcall composite 9 2))) + (4 1)) + +(deftest curry.1 + (let ((curried (curry '+ 3))) + (funcall curried 1 5)) + 9) + +(deftest curry.2 + (let ((curried (locally (declare (notinline curry)) + (curry '* 2 3)))) + (funcall curried 7)) + 42) + +(deftest curry.3 + (let ((curried-form (funcall (compiler-macro-function 'curry) + '(curry '/ 8) + nil))) + (let ((fun (funcall (compile nil `(lambda () ,curried-form))))) + (funcall fun 2))) + 4) + +(deftest curry.4 + (let* ((x 1) + (curried (curry (progn + (incf x) + (lambda (y z) (* x y z))) + 3))) + (list (funcall curried 7) + (funcall curried 7) + x)) + (42 42 2)) + +(deftest rcurry.1 + (let ((r (rcurry '/ 2))) + (funcall r 8)) + 4) + +(deftest rcurry.2 + (let* ((x 1) + (curried (rcurry (progn + (incf x) + (lambda (y z) (* x y z))) + 3))) + (list (funcall curried 7) + (funcall curried 7) + x)) + (42 42 2)) + +(deftest named-lambda.1 + (let ((fac (named-lambda fac (x) + (if (> x 1) + (* x (fac (- x 1))) + x)))) + (funcall fac 5)) + 120) + +(deftest named-lambda.2 + (let ((fac (named-lambda fac (&key x) + (if (> x 1) + (* x (fac :x (- x 1))) + x)))) + (funcall fac :x 5)) + 120) + +;;;; Lists + +(deftest alist-plist.1 + (alist-plist '((a . 1) (b . 2) (c . 3))) + (a 1 b 2 c 3)) + +(deftest plist-alist.1 + (plist-alist '(a 1 b 2 c 3)) + ((a . 1) (b . 2) (c . 3))) + +(deftest unionf.1 + (let* ((list (list 1 2 3)) + (orig list)) + (unionf list (list 1 2 4)) + (values (equal orig (list 1 2 3)) + (eql (length list) 4) + (set-difference list (list 1 2 3 4)) + (set-difference (list 1 2 3 4) list))) + t + t + nil + nil) + +(deftest nunionf.1 + (let ((list (list 1 2 3))) + (nunionf list (list 1 2 4)) + (values (eql (length list) 4) + (set-difference (list 1 2 3 4) list) + (set-difference list (list 1 2 3 4)))) + t + nil + nil) + +(deftest appendf.1 + (let* ((list (list 1 2 3)) + (orig list)) + (appendf list '(4 5 6) '(7 8)) + (list list (eq list orig))) + ((1 2 3 4 5 6 7 8) nil)) + +(deftest nconcf.1 + (let ((list1 (list 1 2 3)) + (list2 (list 4 5 6))) + (nconcf list1 list2 (list 7 8 9)) + list1) + (1 2 3 4 5 6 7 8 9)) + +(deftest circular-list.1 + (let ((circle (circular-list 1 2 3))) + (list (first circle) + (second circle) + (third circle) + (fourth circle) + (eq circle (nthcdr 3 circle)))) + (1 2 3 1 t)) + +(deftest circular-list-p.1 + (let* ((circle (circular-list 1 2 3 4)) + (tree (list circle circle)) + (dotted (cons circle t)) + (proper (list 1 2 3 circle)) + (tailcirc (list* 1 2 3 circle))) + (list (circular-list-p circle) + (circular-list-p tree) + (circular-list-p dotted) + (circular-list-p proper) + (circular-list-p tailcirc))) + (t nil nil nil t)) + +(deftest circular-list-p.2 + (circular-list-p 'foo) + nil) + +(deftest circular-tree-p.1 + (let* ((circle (circular-list 1 2 3 4)) + (tree1 (list circle circle)) + (tree2 (let* ((level2 (list 1 nil 2)) + (level1 (list level2))) + (setf (second level2) level1) + level1)) + (dotted (cons circle t)) + (proper (list 1 2 3 circle)) + (tailcirc (list* 1 2 3 circle)) + (quite-proper (list 1 2 3)) + (quite-dotted (list 1 (cons 2 3)))) + (list (circular-tree-p circle) + (circular-tree-p tree1) + (circular-tree-p tree2) + (circular-tree-p dotted) + (circular-tree-p proper) + (circular-tree-p tailcirc) + (circular-tree-p quite-proper) + (circular-tree-p quite-dotted))) + (t t t t t t nil nil)) + +(deftest circular-tree-p.2 + (alexandria:circular-tree-p '#1=(#1#)) + t) + +(deftest proper-list-p.1 + (let ((l1 (list 1)) + (l2 (list 1 2)) + (l3 (cons 1 2)) + (l4 (list (cons 1 2) 3)) + (l5 (circular-list 1 2))) + (list (proper-list-p l1) + (proper-list-p l2) + (proper-list-p l3) + (proper-list-p l4) + (proper-list-p l5))) + (t t nil t nil)) + +(deftest proper-list-p.2 + (proper-list-p '(1 2 . 3)) + nil) + +(deftest proper-list.type.1 + (let ((l1 (list 1)) + (l2 (list 1 2)) + (l3 (cons 1 2)) + (l4 (list (cons 1 2) 3)) + (l5 (circular-list 1 2))) + (list (typep l1 'proper-list) + (typep l2 'proper-list) + (typep l3 'proper-list) + (typep l4 'proper-list) + (typep l5 'proper-list))) + (t t nil t nil)) + +(deftest proper-list-length.1 + (values + (proper-list-length nil) + (proper-list-length (list 1)) + (proper-list-length (list 2 2)) + (proper-list-length (list 3 3 3)) + (proper-list-length (list 4 4 4 4)) + (proper-list-length (list 5 5 5 5 5)) + (proper-list-length (list 6 6 6 6 6 6)) + (proper-list-length (list 7 7 7 7 7 7 7)) + (proper-list-length (list 8 8 8 8 8 8 8 8)) + (proper-list-length (list 9 9 9 9 9 9 9 9 9))) + 0 1 2 3 4 5 6 7 8 9) + +(deftest proper-list-length.2 + (flet ((plength (x) + (handler-case + (proper-list-length x) + (type-error () + :ok)))) + (values + (plength (list* 1)) + (plength (list* 2 2)) + (plength (list* 3 3 3)) + (plength (list* 4 4 4 4)) + (plength (list* 5 5 5 5 5)) + (plength (list* 6 6 6 6 6 6)) + (plength (list* 7 7 7 7 7 7 7)) + (plength (list* 8 8 8 8 8 8 8 8)) + (plength (list* 9 9 9 9 9 9 9 9 9)))) + :ok :ok :ok + :ok :ok :ok + :ok :ok :ok) + +(deftest lastcar.1 + (let ((l1 (list 1)) + (l2 (list 1 2))) + (list (lastcar l1) + (lastcar l2))) + (1 2)) + +(deftest lastcar.error.2 + (handler-case + (progn + (lastcar (circular-list 1 2 3)) + nil) + (error () + t)) + t) + +(deftest setf-lastcar.1 + (let ((l (list 1 2 3 4))) + (values (lastcar l) + (progn + (setf (lastcar l) 42) + (lastcar l)))) + 4 + 42) + +(deftest setf-lastcar.2 + (let ((l (circular-list 1 2 3))) + (multiple-value-bind (res err) + (ignore-errors (setf (lastcar l) 4)) + (typep err 'type-error))) + t) + +(deftest make-circular-list.1 + (let ((l (make-circular-list 3 :initial-element :x))) + (setf (car l) :y) + (list (eq l (nthcdr 3 l)) + (first l) + (second l) + (third l) + (fourth l))) + (t :y :x :x :y)) + +(deftest circular-list.type.1 + (let* ((l1 (list 1 2 3)) + (l2 (circular-list 1 2 3)) + (l3 (list* 1 2 3 l2))) + (list (typep l1 'circular-list) + (typep l2 'circular-list) + (typep l3 'circular-list))) + (nil t t)) + +(deftest ensure-list.1 + (let ((x (list 1)) + (y 2)) + (list (ensure-list x) + (ensure-list y))) + ((1) (2))) + +(deftest ensure-cons.1 + (let ((x (cons 1 2)) + (y nil) + (z "foo")) + (values (ensure-cons x) + (ensure-cons y) + (ensure-cons z))) + (1 . 2) + (nil) + ("foo")) + +(deftest setp.1 + (setp '(1)) + t) + +(deftest setp.2 + (setp nil) + t) + +(deftest setp.3 + (setp "foo") + nil) + +(deftest setp.4 + (setp '(1 2 3 1)) + nil) + +(deftest setp.5 + (setp '(1 2 3)) + t) + +(deftest setp.6 + (setp '(a :a)) + t) + +(deftest setp.7 + (setp '(a :a) :key 'character) + nil) + +(deftest setp.8 + (setp '(a :a) :key 'character :test (constantly nil)) + t) + +(deftest set-equal.1 + (set-equal '(1 2 3) '(3 1 2)) + t) + +(deftest set-equal.2 + (set-equal '("Xa") '("Xb") + :test (lambda (a b) (eql (char a 0) (char b 0)))) + t) + +(deftest set-equal.3 + (set-equal '(1 2) '(4 2)) + nil) + +(deftest set-equal.4 + (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal) + t) + +(deftest set-equal.5 + (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal) + nil) + +(deftest set-equal.6 + (set-equal '(a b c) '(a b c d)) + nil) + +(deftest map-product.1 + (map-product 'cons '(2 3) '(1 4)) + ((2 . 1) (2 . 4) (3 . 1) (3 . 4))) + +(deftest map-product.2 + (map-product #'cons '(2 3) '(1 4)) + ((2 . 1) (2 . 4) (3 . 1) (3 . 4))) + +(deftest flatten.1 + (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7)) + (1 2 3 4 5 6 7)) + +(deftest remove-from-plist.1 + (let ((orig '(a 1 b 2 c 3 d 4))) + (list (remove-from-plist orig 'a 'c) + (remove-from-plist orig 'b 'd) + (remove-from-plist orig 'b) + (remove-from-plist orig 'a) + (remove-from-plist orig 'd 42 "zot") + (remove-from-plist orig 'a 'b 'c 'd) + (remove-from-plist orig 'a 'b 'c 'd 'x) + (equal orig '(a 1 b 2 c 3 d 4)))) + ((b 2 d 4) + (a 1 c 3) + (a 1 c 3 d 4) + (b 2 c 3 d 4) + (a 1 b 2 c 3) + nil + nil + t)) + +(deftest delete-from-plist.1 + (let ((orig '(a 1 b 2 c 3 d 4 d 5))) + (list (delete-from-plist (copy-list orig) 'a 'c) + (delete-from-plist (copy-list orig) 'b 'd) + (delete-from-plist (copy-list orig) 'b) + (delete-from-plist (copy-list orig) 'a) + (delete-from-plist (copy-list orig) 'd 42 "zot") + (delete-from-plist (copy-list orig) 'a 'b 'c 'd) + (delete-from-plist (copy-list orig) 'a 'b 'c 'd 'x) + (equal orig (delete-from-plist orig)) + (eq orig (delete-from-plist orig)))) + ((b 2 d 4 d 5) + (a 1 c 3) + (a 1 c 3 d 4 d 5) + (b 2 c 3 d 4 d 5) + (a 1 b 2 c 3) + nil + nil + t + t)) + +(deftest mappend.1 + (mappend (compose 'list '*) '(1 2 3) '(1 2 3)) + (1 4 9)) + +(deftest assoc-value.1 + (let ((key1 '(complex key)) + (key2 'simple-key) + (alist '()) + (result '())) + (push 1 (assoc-value alist key1 :test #'equal)) + (push 2 (assoc-value alist key1 :test 'equal)) + (push 42 (assoc-value alist key2)) + (push 43 (assoc-value alist key2 :test 'eq)) + (push (assoc-value alist key1 :test #'equal) result) + (push (assoc-value alist key2) result) + + (push 'very (rassoc-value alist (list 2 1) :test #'equal)) + (push (cdr (assoc '(very complex key) alist :test #'equal)) result) + result) + ((2 1) (43 42) (2 1))) + +;;;; Numbers + +(deftest clamp.1 + (list (clamp 1.5 1 2) + (clamp 2.0 1 2) + (clamp 1.0 1 2) + (clamp 3 1 2) + (clamp 0 1 2)) + (1.5 2.0 1.0 2 1)) + +(deftest gaussian-random.1 + (let ((min -0.2) + (max +0.2)) + (multiple-value-bind (g1 g2) + (gaussian-random min max) + (values (<= min g1 max) + (<= min g2 max) + (/= g1 g2) ;uh + ))) + t + t + t) + +#+sbcl +(deftest gaussian-random.2 + (handler-case + (sb-ext:with-timeout 2 + (progn + (loop + :repeat 10000 + :do (gaussian-random 0 nil)) + 'done)) + (sb-ext:timeout () + 'timed-out)) + done) + +(deftest iota.1 + (iota 3) + (0 1 2)) + +(deftest iota.2 + (iota 3 :start 0.0d0) + (0.0d0 1.0d0 2.0d0)) + +(deftest iota.3 + (iota 3 :start 2 :step 3.0) + (2.0 5.0 8.0)) + +(deftest map-iota.1 + (let (all) + (declare (notinline map-iota)) + (values (map-iota (lambda (x) (push x all)) + 3 + :start 2 + :step 1.1d0) + all)) + 3 + (4.2d0 3.1d0 2.0d0)) + +(deftest lerp.1 + (lerp 0.5 1 2) + 1.5) + +(deftest lerp.2 + (lerp 0.1 1 2) + 1.1) + +(deftest lerp.3 + (lerp 0.1 4 25) + 6.1) + +(deftest mean.1 + (mean '(1 2 3)) + 2) + +(deftest mean.2 + (mean '(1 2 3 4)) + 5/2) + +(deftest mean.3 + (mean '(1 2 10)) + 13/3) + +(deftest median.1 + (median '(100 0 99 1 98 2 97)) + 97) + +(deftest median.2 + (median '(100 0 99 1 98 2 97 96)) + 193/2) + +(deftest variance.1 + (variance (list 1 2 3)) + 2/3) + +(deftest standard-deviation.1 + (< 0 (standard-deviation (list 1 2 3)) 1) + t) + +(deftest maxf.1 + (let ((x 1)) + (maxf x 2) + x) + 2) + +(deftest maxf.2 + (let ((x 1)) + (maxf x 0) + x) + 1) + +(deftest maxf.3 + (let ((x 1) + (c 0)) + (maxf x (incf c)) + (list x c)) + (1 1)) + +(deftest maxf.4 + (let ((xv (vector 0 0 0)) + (p 0)) + (maxf (svref xv (incf p)) (incf p)) + (list p xv)) + (2 #(0 2 0))) + +(deftest minf.1 + (let ((y 1)) + (minf y 0) + y) + 0) + +(deftest minf.2 + (let ((xv (vector 10 10 10)) + (p 0)) + (minf (svref xv (incf p)) (incf p)) + (list p xv)) + (2 #(10 2 10))) + +(deftest subfactorial.1 + (mapcar #'subfactorial (iota 22)) + (1 + 0 + 1 + 2 + 9 + 44 + 265 + 1854 + 14833 + 133496 + 1334961 + 14684570 + 176214841 + 2290792932 + 32071101049 + 481066515734 + 7697064251745 + 130850092279664 + 2355301661033953 + 44750731559645106 + 895014631192902121 + 18795307255050944540)) + +;;;; Arrays + +#+nil +(deftest array-index.type) + +#+nil +(deftest copy-array) + +;;;; Sequences + +(deftest rotate.1 + (list (rotate (list 1 2 3) 0) + (rotate (list 1 2 3) 1) + (rotate (list 1 2 3) 2) + (rotate (list 1 2 3) 3) + (rotate (list 1 2 3) 4)) + ((1 2 3) + (3 1 2) + (2 3 1) + (1 2 3) + (3 1 2))) + +(deftest rotate.2 + (list (rotate (vector 1 2 3 4) 0) + (rotate (vector 1 2 3 4)) + (rotate (vector 1 2 3 4) 2) + (rotate (vector 1 2 3 4) 3) + (rotate (vector 1 2 3 4) 4) + (rotate (vector 1 2 3 4) 5)) + (#(1 2 3 4) + #(4 1 2 3) + #(3 4 1 2) + #(2 3 4 1) + #(1 2 3 4) + #(4 1 2 3))) + +(deftest rotate.3 + (list (rotate (list 1 2 3) 0) + (rotate (list 1 2 3) -1) + (rotate (list 1 2 3) -2) + (rotate (list 1 2 3) -3) + (rotate (list 1 2 3) -4)) + ((1 2 3) + (2 3 1) + (3 1 2) + (1 2 3) + (2 3 1))) + +(deftest rotate.4 + (list (rotate (vector 1 2 3 4) 0) + (rotate (vector 1 2 3 4) -1) + (rotate (vector 1 2 3 4) -2) + (rotate (vector 1 2 3 4) -3) + (rotate (vector 1 2 3 4) -4) + (rotate (vector 1 2 3 4) -5)) + (#(1 2 3 4) + #(2 3 4 1) + #(3 4 1 2) + #(4 1 2 3) + #(1 2 3 4) + #(2 3 4 1))) + +(deftest rotate.5 + (values (rotate (list 1) 17) + (rotate (list 1) -5)) + (1) + (1)) + +(deftest shuffle.1 + (let ((s (shuffle (iota 100)))) + (list (equal s (iota 100)) + (every (lambda (x) + (member x s)) + (iota 100)) + (every (lambda (x) + (typep x '(integer 0 99))) + s))) + (nil t t)) + +(deftest shuffle.2 + (let ((s (shuffle (coerce (iota 100) 'vector)))) + (list (equal s (coerce (iota 100) 'vector)) + (every (lambda (x) + (find x s)) + (iota 100)) + (every (lambda (x) + (typep x '(integer 0 99))) + s))) + (nil t t)) + +(deftest shuffle.3 + (let* ((orig (coerce (iota 21) 'vector)) + (copy (copy-seq orig))) + (shuffle copy :start 10 :end 15) + (list (every #'eql (subseq copy 0 10) (subseq orig 0 10)) + (every #'eql (subseq copy 15) (subseq orig 15)))) + (t t)) + +(deftest random-elt.1 + (let ((s1 #(1 2 3 4)) + (s2 '(1 2 3 4))) + (list (dotimes (i 1000 nil) + (unless (member (random-elt s1) s2) + (return nil)) + (when (/= (random-elt s1) (random-elt s1)) + (return t))) + (dotimes (i 1000 nil) + (unless (member (random-elt s2) s2) + (return nil)) + (when (/= (random-elt s2) (random-elt s2)) + (return t))))) + (t t)) + +(deftest removef.1 + (let* ((x '(1 2 3)) + (x* x) + (y #(1 2 3)) + (y* y)) + (removef x 1) + (removef y 3) + (list x x* y y*)) + ((2 3) + (1 2 3) + #(1 2) + #(1 2 3))) + +(deftest deletef.1 + (let* ((x (list 1 2 3)) + (x* x) + (y (vector 1 2 3))) + (deletef x 2) + (deletef y 1) + (list x x* y)) + ((1 3) + (1 3) + #(2 3))) + +(deftest map-permutations.1 + (let ((seq (list 1 2 3)) + (seen nil) + (ok t)) + (map-permutations (lambda (s) + (unless (set-equal s seq) + (setf ok nil)) + (when (member s seen :test 'equal) + (setf ok nil)) + (push s seen)) + seq + :copy t) + (values ok (length seen))) + t + 6) + +(deftest proper-sequence.type.1 + (mapcar (lambda (x) + (typep x 'proper-sequence)) + (list (list 1 2 3) + (vector 1 2 3) + #2a((1 2) (3 4)) + (circular-list 1 2 3 4))) + (t t nil nil)) + +(deftest emptyp.1 + (mapcar #'emptyp + (list (list 1) + (circular-list 1) + nil + (vector) + (vector 1))) + (nil nil t t nil)) + +(deftest sequence-of-length-p.1 + (mapcar #'sequence-of-length-p + (list nil + #() + (list 1) + (vector 1) + (list 1 2) + (vector 1 2) + (list 1 2) + (vector 1 2) + (list 1 2) + (vector 1 2)) + (list 0 + 0 + 1 + 1 + 2 + 2 + 1 + 1 + 4 + 4)) + (t t t t t t nil nil nil nil)) + +(deftest length=.1 + (mapcar #'length= + (list nil + #() + (list 1) + (vector 1) + (list 1 2) + (vector 1 2) + (list 1 2) + (vector 1 2) + (list 1 2) + (vector 1 2)) + (list 0 + 0 + 1 + 1 + 2 + 2 + 1 + 1 + 4 + 4)) + (t t t t t t nil nil nil nil)) + +(deftest length=.2 + ;; test the compiler macro + (macrolet ((x (&rest args) + (funcall + (compile nil + `(lambda () + (length= ,@args)))))) + (list (x 2 '(1 2)) + (x '(1 2) '(3 4)) + (x '(1 2) 2) + (x '(1 2) 2 '(3 4)) + (x 1 2 3))) + (t t t t nil)) + +(deftest copy-sequence.1 + (let ((l (list 1 2 3)) + (v (vector #\a #\b #\c))) + (declare (notinline copy-sequence)) + (let ((l.list (copy-sequence 'list l)) + (l.vector (copy-sequence 'vector l)) + (l.spec-v (copy-sequence '(vector fixnum) l)) + (v.vector (copy-sequence 'vector v)) + (v.list (copy-sequence 'list v)) + (v.string (copy-sequence 'string v))) + (list (member l (list l.list l.vector l.spec-v)) + (member v (list v.vector v.list v.string)) + (equal l.list l) + (equalp l.vector #(1 2 3)) + (type= (upgraded-array-element-type 'fixnum) + (array-element-type l.spec-v)) + (equalp v.vector v) + (equal v.list '(#\a #\b #\c)) + (equal "abc" v.string)))) + (nil nil t t t t t t)) + +(deftest first-elt.1 + (mapcar #'first-elt + (list (list 1 2 3) + "abc" + (vector :a :b :c))) + (1 #\a :a)) + +(deftest first-elt.error.1 + (mapcar (lambda (x) + (handler-case + (first-elt x) + (type-error () + :type-error))) + (list nil + #() + 12 + :zot)) + (:type-error + :type-error + :type-error + :type-error)) + +(deftest setf-first-elt.1 + (let ((l (list 1 2 3)) + (s (copy-seq "foobar")) + (v (vector :a :b :c))) + (setf (first-elt l) -1 + (first-elt s) #\x + (first-elt v) 'zot) + (values l s v)) + (-1 2 3) + "xoobar" + #(zot :b :c)) + +(deftest setf-first-elt.error.1 + (let ((l 'foo)) + (multiple-value-bind (res err) + (ignore-errors (setf (first-elt l) 4)) + (typep err 'type-error))) + t) + +(deftest last-elt.1 + (mapcar #'last-elt + (list (list 1 2 3) + (vector :a :b :c) + "FOOBAR" + #*001 + #*010)) + (3 :c #\R 1 0)) + +(deftest last-elt.error.1 + (mapcar (lambda (x) + (handler-case + (last-elt x) + (type-error () + :type-error))) + (list nil + #() + 12 + :zot + (circular-list 1 2 3) + (list* 1 2 3 (circular-list 4 5)))) + (:type-error + :type-error + :type-error + :type-error + :type-error + :type-error)) + +(deftest setf-last-elt.1 + (let ((l (list 1 2 3)) + (s (copy-seq "foobar")) + (b (copy-seq #*010101001))) + (setf (last-elt l) '??? + (last-elt s) #\? + (last-elt b) 0) + (values l s b)) + (1 2 ???) + "fooba?" + #*010101000) + +(deftest setf-last-elt.error.1 + (handler-case + (setf (last-elt 'foo) 13) + (type-error () + :type-error)) + :type-error) + +(deftest starts-with.1 + (list (starts-with 1 '(1 2 3)) + (starts-with 1 #(1 2 3)) + (starts-with #\x "xyz") + (starts-with 2 '(1 2 3)) + (starts-with 3 #(1 2 3)) + (starts-with 1 1) + (starts-with nil nil)) + (t t t nil nil nil nil)) + +(deftest starts-with.2 + (values (starts-with 1 '(-1 2 3) :key '-) + (starts-with "foo" '("foo" "bar") :test 'equal) + (starts-with "f" '(#\f) :key 'string :test 'equal) + (starts-with -1 '(0 1 2) :key #'1+) + (starts-with "zot" '("ZOT") :test 'equal)) + t + t + t + nil + nil) + +(deftest ends-with.1 + (list (ends-with 3 '(1 2 3)) + (ends-with 3 #(1 2 3)) + (ends-with #\z "xyz") + (ends-with 2 '(1 2 3)) + (ends-with 1 #(1 2 3)) + (ends-with 1 1) + (ends-with nil nil)) + (t t t nil nil nil nil)) + +(deftest ends-with.2 + (values (ends-with 2 '(0 13 1) :key '1+) + (ends-with "foo" (vector "bar" "foo") :test 'equal) + (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal) + (ends-with "foo" "foo" :test 'equal)) + t + t + t + nil) + +(deftest ends-with.error.1 + (handler-case + (ends-with 3 (circular-list 3 3 3 1 3 3)) + (type-error () + :type-error)) + :type-error) + +(deftest sequences.passing-improper-lists + (macrolet ((signals-error-p (form) + `(handler-case + (progn ,form nil) + (type-error (e) + t))) + (cut (fn &rest args) + (with-gensyms (arg) + (print`(lambda (,arg) + (apply ,fn (list ,@(substitute arg '_ args)))))))) + (let ((circular-list (make-circular-list 5 :initial-element :foo)) + (dotted-list (list* 'a 'b 'c 'd))) + (loop for nth from 0 + for fn in (list + (cut #'lastcar _) + (cut #'rotate _ 3) + (cut #'rotate _ -3) + (cut #'shuffle _) + (cut #'random-elt _) + (cut #'last-elt _) + (cut #'ends-with :foo _)) + nconcing + (let ((on-circular-p (signals-error-p (funcall fn circular-list))) + (on-dotted-p (signals-error-p (funcall fn dotted-list)))) + (when (or (not on-circular-p) (not on-dotted-p)) + (append + (unless on-circular-p + (let ((*print-circle* t)) + (list + (format nil + "No appropriate error signalled when passing ~S to ~Ath entry." + circular-list nth)))) + (unless on-dotted-p + (list + (format nil + "No appropriate error signalled when passing ~S to ~Ath entry." + dotted-list nth))))))))) + nil) + +;;;; IO + +(deftest read-stream-content-into-string.1 + (values (with-input-from-string (stream "foo bar") + (read-stream-content-into-string stream)) + (with-input-from-string (stream "foo bar") + (read-stream-content-into-string stream :buffer-size 1)) + (with-input-from-string (stream "foo bar") + (read-stream-content-into-string stream :buffer-size 6)) + (with-input-from-string (stream "foo bar") + (read-stream-content-into-string stream :buffer-size 7))) + "foo bar" + "foo bar" + "foo bar" + "foo bar") + +(deftest read-stream-content-into-string.2 + (handler-case + (let ((stream (make-broadcast-stream))) + (read-stream-content-into-string stream :buffer-size 0)) + (type-error () + :type-error)) + :type-error) + +#+(or) +(defvar *octets* + (map '(simple-array (unsigned-byte 8) (7)) #'char-code "foo bar")) + +#+(or) +(deftest read-stream-content-into-byte-vector.1 + (values (with-input-from-byte-vector (stream *octets*) + (read-stream-content-into-byte-vector stream)) + (with-input-from-byte-vector (stream *octets*) + (read-stream-content-into-byte-vector stream :initial-size 1)) + (with-input-from-byte-vector (stream *octets*) + (read-stream-content-into-byte-vector stream 'alexandria::%length 6)) + (with-input-from-byte-vector (stream *octets*) + (read-stream-content-into-byte-vector stream 'alexandria::%length 3))) + *octets* + *octets* + *octets* + (subseq *octets* 0 3)) + +(deftest read-stream-content-into-byte-vector.2 + (handler-case + (let ((stream (make-broadcast-stream))) + (read-stream-content-into-byte-vector stream :initial-size 0)) + (type-error () + :type-error)) + :type-error) + +;;;; Macros + +(deftest with-unique-names.1 + (let ((*gensym-counter* 0)) + (let ((syms (with-unique-names (foo bar quux) + (list foo bar quux)))) + (list (find-if #'symbol-package syms) + (equal '("FOO0" "BAR1" "QUUX2") + (mapcar #'symbol-name syms))))) + (nil t)) + +(deftest with-unique-names.2 + (let ((*gensym-counter* 0)) + (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q)) + (list foo bar quux)))) + (list (find-if #'symbol-package syms) + (equal '("_foo_0" "-BAR-1" "q2") + (mapcar #'symbol-name syms))))) + (nil t)) + +(deftest with-unique-names.3 + (let ((*gensym-counter* 0)) + (multiple-value-bind (res err) + (ignore-errors + (eval + '(let ((syms + (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42)) + (list foo bar quux)))) + (list (find-if #'symbol-package syms) + (equal '("_foo_0" "-BAR-1" "q2") + (mapcar #'symbol-name syms)))))) + (errorp err))) + t) + +(deftest once-only.1 + (macrolet ((cons1.good (x) + (once-only (x) + `(cons ,x ,x))) + (cons1.bad (x) + `(cons ,x ,x))) + (let ((y 0)) + (list (cons1.good (incf y)) + y + (cons1.bad (incf y)) + y))) + ((1 . 1) 1 (2 . 3) 3)) + +(deftest once-only.2 + (macrolet ((cons1 (x) + (once-only ((y x)) + `(cons ,y ,y)))) + (let ((z 0)) + (list (cons1 (incf z)) + z + (cons1 (incf z))))) + ((1 . 1) 1 (2 . 2))) + +(deftest parse-body.1 + (parse-body '("doc" "body") :documentation t) + ("body") + nil + "doc") + +(deftest parse-body.2 + (parse-body '("body") :documentation t) + ("body") + nil + nil) + +(deftest parse-body.3 + (parse-body '("doc" "body")) + ("doc" "body") + nil + nil) + +(deftest parse-body.4 + (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t) + (body) + ((declare (foo)) (declare (bar))) + "doc") + +(deftest parse-body.5 + (parse-body '((declare (foo)) "doc" (declare (bar)) body)) + ("doc" (declare (bar)) body) + ((declare (foo))) + nil) + +(deftest parse-body.6 + (multiple-value-bind (res err) + (ignore-errors + (parse-body '("foo" "bar" "quux") + :documentation t)) + (errorp err)) + t) + +;;;; Symbols + +(deftest ensure-symbol.1 + (ensure-symbol :cons :cl) + cons + :external) + +(deftest ensure-symbol.2 + (ensure-symbol "CONS" :alexandria) + cons + :inherited) + +(deftest ensure-symbol.3 + (ensure-symbol 'foo :keyword) + :foo + :external) + +(deftest ensure-symbol.4 + (ensure-symbol #\* :alexandria) + * + :inherited) + +(deftest format-symbol.1 + (let ((s (format-symbol nil '#:x-~d 13))) + (list (symbol-package s) + (string= (string '#:x-13) (symbol-name s)))) + (nil t)) + +(deftest format-symbol.2 + (format-symbol :keyword '#:sym-~a (string :bolic)) + :sym-bolic) + +(deftest format-symbol.3 + (let ((*package* (find-package :cl))) + (format-symbol t '#:find-~a (string 'package))) + find-package) + +(deftest make-keyword.1 + (list (make-keyword 'zot) + (make-keyword "FOO") + (make-keyword #\Q)) + (:zot :foo :q)) + +(deftest make-gensym-list.1 + (let ((*gensym-counter* 0)) + (let ((syms (make-gensym-list 3 "FOO"))) + (list (find-if 'symbol-package syms) + (equal '("FOO0" "FOO1" "FOO2") + (mapcar 'symbol-name syms))))) + (nil t)) + +(deftest make-gensym-list.2 + (let ((*gensym-counter* 0)) + (let ((syms (make-gensym-list 3))) + (list (find-if 'symbol-package syms) + (equal '("G0" "G1" "G2") + (mapcar 'symbol-name syms))))) + (nil t)) + +;;;; Type-system + +(deftest of-type.1 + (locally + (declare (notinline of-type)) + (let ((f (of-type 'string))) + (list (funcall f "foo") + (funcall f 'bar)))) + (t nil)) + +(deftest type=.1 + (type= 'string 'string) + t + t) + +(deftest type=.2 + (type= 'list '(or null cons)) + t + t) + +(deftest type=.3 + (type= 'null '(and symbol list)) + t + t) + +(deftest type=.4 + (type= 'string '(satisfies emptyp)) + nil + nil) + +(deftest type=.5 + (type= 'string 'list) + nil + t) + +(macrolet + ((test (type numbers) + `(deftest ,(format-symbol t '#:cdr5.~a (string type)) + (let ((numbers ,numbers)) + (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers) + (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers) + (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers) + (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers))) + (t t t nil nil nil nil) + (t t t t nil nil nil) + (nil nil nil t t t t) + (nil nil nil nil t t t)))) + (test fixnum (list most-negative-fixnum -42 -1 0 1 42 most-positive-fixnum)) + (test integer (list (1- most-negative-fixnum) -42 -1 0 1 42 (1+ most-positive-fixnum))) + (test rational (list (1- most-negative-fixnum) -42/13 -1 0 1 42/13 (1+ most-positive-fixnum))) + (test real (list most-negative-long-float -42/13 -1 0 1 42/13 most-positive-long-float)) + (test float (list most-negative-short-float -42.02 -1.0 0.0 1.0 42.02 most-positive-short-float)) + (test short-float (list most-negative-short-float -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float)) + (test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float)) + (test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float)) + (test long-float (list most-negative-long-float -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float))) + +;;;; Bindings + +(declaim (notinline opaque)) +(defun opaque (x) + x) + +(deftest if-let.1 + (if-let (x (opaque :ok)) + x + :bad) + :ok) + +(deftest if-let.2 + (if-let (x (opaque nil)) + :bad + (and (not x) :ok)) + :ok) + +(deftest if-let.3 + (let ((x 1)) + (if-let ((x 2) + (y x)) + (+ x y) + :oops)) + 3) + +(deftest if-let.4 + (if-let ((x 1) + (y nil)) + :oops + (and (not y) x)) + 1) + +(deftest if-let.5 + (if-let (x) + :oops + (not x)) + t) + +(deftest if-let.error.1 + (handler-case + (eval '(if-let x + :oops + :oops)) + (type-error () + :type-error)) + :type-error) + +(deftest when-let.1 + (when-let (x (opaque :ok)) + (setf x (cons x x)) + x) + (:ok . :ok)) + +(deftest when-let.2 + (when-let ((x 1) + (y nil) + (z 3)) + :oops) + nil) + +(deftest when-let.3 + (let ((x 1)) + (when-let ((x 2) + (y x)) + (+ x y))) + 3) + +(deftest when-let.error.1 + (handler-case + (eval '(when-let x :oops)) + (type-error () + :type-error)) + :type-error) + +(deftest when-let*.1 + (let ((x 1)) + (when-let* ((x 2) + (y x)) + (+ x y))) + 4) + +(deftest when-let*.2 + (let ((y 1)) + (when-let* (x y) + (1+ x))) + 2) + +(deftest when-let*.3 + (when-let* ((x t) + (y (consp x)) + (z (error "OOPS"))) + t) + nil) + +(deftest when-let*.error.1 + (handler-case + (eval '(when-let* x :oops)) + (type-error () + :type-error)) + :type-error) + +(deftest doplist.1 + (let (keys values) + (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v)) + (push k keys) + (push v values))) + t + (a b c) + (1 2 3) + nil + nil) + +(deftest count-permutations.1 + (values (count-permutations 31 7) + (count-permutations 1 1) + (count-permutations 2 1) + (count-permutations 2 2) + (count-permutations 3 2) + (count-permutations 3 1)) + 13253058000 + 1 + 2 + 2 + 6 + 3) + +(deftest binomial-coefficient.1 + (alexandria:binomial-coefficient 1239 139) + 28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154) + +;; Exercise bignum case (at least on x86). +(deftest binomial-coefficient.2 + (alexandria:binomial-coefficient 2000000000000 20) + 430998041177272843950422879590338454856322722740402365741730748431530623813012487773080486408378680853987520854296499536311275320016878730999689934464711239072435565454954447356845336730100919970769793030177499999999900000000000) + +(deftest copy-stream.1 + (let ((data "sdkfjhsakfh weior763495ewofhsdfk sdfadlkfjhsadf woif sdlkjfhslkdfh sdklfjh")) + (values (equal data + (with-input-from-string (in data) + (with-output-to-string (out) + (alexandria:copy-stream in out)))) + (equal (subseq data 10 20) + (with-input-from-string (in data) + (with-output-to-string (out) + (alexandria:copy-stream in out :start 10 :end 20)))) + (equal (subseq data 10) + (with-input-from-string (in data) + (with-output-to-string (out) + (alexandria:copy-stream in out :start 10)))) + (equal (subseq data 0 20) + (with-input-from-string (in data) + (with-output-to-string (out) + (alexandria:copy-stream in out :end 20)))))) + t + t + t + t) + +(deftest extremum.1 + (let ((n 0)) + (dotimes (i 10) + (let ((data (shuffle (coerce (iota 10000 :start i) 'vector))) + (ok t)) + (unless (eql i (extremum data #'<)) + (setf ok nil)) + (unless (eql i (extremum (coerce data 'list) #'<)) + (setf ok nil)) + (unless (eql (+ 9999 i) (extremum data #'>)) + (setf ok nil)) + (unless (eql (+ 9999 i) (extremum (coerce data 'list) #'>)) + (setf ok nil)) + (when ok + (incf n)))) + (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3)) + (incf n)) + (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs)) + (incf n)) + (when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b)))) + (incf n)) + n) + 13) + +(deftest starts-with-subseq.string + (starts-with-subseq "f" "foo" :return-suffix t) + t + "oo") + +(deftest starts-with-subseq.vector + (starts-with-subseq #(1) #(1 2 3) :return-suffix t) + t + #(2 3)) + +(deftest starts-with-subseq.list + (starts-with-subseq '(1) '(1 2 3) :return-suffix t) + t + (2 3)) + +(deftest starts-with-subseq.start1 + (starts-with-subseq "foo" "oop" :start1 1) + t + nil) + +(deftest starts-with-subseq.start2 + (starts-with-subseq "foo" "xfoop" :start2 1) + t + nil) + +(deftest format-symbol.print-case-bound + (let ((upper (intern "FOO-BAR")) + (lower (intern "foo-bar")) + (*print-escape* nil)) + (values + (let ((*print-case* :downcase)) + (and (eq upper (format-symbol t "~A" upper)) + (eq lower (format-symbol t "~A" lower)))) + (let ((*print-case* :upcase)) + (and (eq upper (format-symbol t "~A" upper)) + (eq lower (format-symbol t "~A" lower)))) + (let ((*print-case* :capitalize)) + (and (eq upper (format-symbol t "~A" upper)) + (eq lower (format-symbol t "~A" lower)))))) + t + t + t) + +(deftest iota.fp-start-and-complex-integer-step + (equal '(#C(0.0 0.0) #C(0.0 2.0) #C(0.0 4.0)) + (iota 3 :start 0.0 :step #C(0 2))) + t) + +(deftest parse-ordinary-lambda-list.1 + (multiple-value-bind (req opt rest keys allowp aux keyp) + (parse-ordinary-lambda-list '(a b c + &optional o1 (o2 42) (o3 42 o3-supplied?) + &key (k1) ((:key k2)) (k3 42 k3-supplied?)) + :normalize t) + (and (equal '(a b c) req) + (equal '((o1 nil nil) + (o2 42 nil) + (o3 42 o3-supplied?)) + opt) + (equal '(((:k1 k1) nil nil) + ((:key k2) nil nil) + ((:k3 k3) 42 k3-supplied?)) + keys) + (not allowp) + (not aux) + (eq t keyp))) + t) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/types.lisp b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/types.lisp new file mode 100644 index 0000000..1942d0e --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/types.lisp @@ -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.") diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/.gitref b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/.gitref new file mode 100644 index 0000000..f879a62 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/.gitref @@ -0,0 +1 @@ +c1f15e2bd02fabe7bb468b05fe311cd9a932f14f \ No newline at end of file diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/.travis.yml b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/.travis.yml new file mode 100644 index 0000000..f02735e --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/.travis.yml @@ -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 diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/CONTRIBUTING.md b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/CONTRIBUTING.md new file mode 100644 index 0000000..6bf01dc --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/CONTRIBUTING.md @@ -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-.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/ diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/Makefile b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/Makefile new file mode 100644 index 0000000..ed63e6f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/Makefile @@ -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 diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/NEWS b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/NEWS new file mode 100644 index 0000000..9f24e38 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/NEWS @@ -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 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. + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/PROBLEMS b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/PROBLEMS new file mode 100644 index 0000000..704f435 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/PROBLEMS @@ -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. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/README.md b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/README.md new file mode 100644 index 0000000..7ef8cd3 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/README.md @@ -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 diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/Makefile b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/Makefile new file mode 100644 index 0000000..27dcd80 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/Makefile @@ -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)))' + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/README.md b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/README.md new file mode 100644 index 0000000..94fd02f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/README.md @@ -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. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/bridge.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/bridge.el new file mode 100644 index 0000000..5bf8779 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/bridge.el @@ -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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/inferior-slime.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/inferior-slime.el new file mode 100644 index 0000000..b176098 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/inferior-slime.el @@ -0,0 +1,133 @@ +;;; inferior-slime.el --- Minor mode with Slime keys for comint buffers +;; +;; Author: Luke Gorrie +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path "") +;; (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 + "\\\ +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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-asdf.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-asdf.el new file mode 100644 index 0000000..fa4b176 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-asdf.el @@ -0,0 +1,313 @@ +(require 'slime) +(require 'cl-lib) +(require 'grep) + +(define-slime-contrib slime-asdf + "ASDF support." + (:authors "Daniel Barlow " + "Marco Baringer " + "Edi Weitz " + "Stas Boukarev " + "Tobias C Rittweiler ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-autodoc.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-autodoc.el new file mode 100644 index 0000000..1ea629e --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-autodoc.el @@ -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 " + "Lawrence Mitchell " + "Matthias Koeppe " + "Tobias C. Rittweiler ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-banner.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-banner.el new file mode 100644 index 0000000..f4eb8c4 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-banner.el @@ -0,0 +1,35 @@ +(require 'slime) +(require 'slime-repl) + +(define-slime-contrib slime-banner + "Persistent header line and startup animation." + (:authors "Helmut Eller " + "Luke Gorrie ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-buffer-streams.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-buffer-streams.el new file mode 100644 index 0000000..2fa700d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-buffer-streams.el @@ -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 ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-c-p-c.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-c-p-c.el new file mode 100644 index 0000000..22a267b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-c-p-c.el @@ -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 " + "Edi Weitz " + "Matthias Koeppe " + "Tobias C. Rittweiler ") + (: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) + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-cl-indent.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-cl-indent.el new file mode 100644 index 0000000..96ebb58 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-cl-indent.el @@ -0,0 +1,1821 @@ +;;; slime-cl-indent.el --- enhanced lisp-indent mode + +;; Copyright (C) 1987, 2000-2011 Free Software Foundation, Inc. + +;; Author: Richard Mlynarik +;; Created: July 1987 +;; Maintainer: FSF +;; Keywords: lisp, tools +;; Package: emacs + +;; This file is forked from cl-indent.el, which is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This package supplies a single entry point, common-lisp-indent-function, +;; which performs indentation in the preferred style for Common Lisp code. +;; To enable it: +;; +;; (setq lisp-indent-function 'common-lisp-indent-function) +;; +;; This file is substantially patched from original cl-indent.el, +;; which is in Emacs proper. It does not require SLIME, but is instead +;; required by one of it's contribs, `slime-indentation'. +;; +;; Before making modifications to this file, consider adding them to +;; Emacs's own `cl-indent' and refactoring this file to be an +;; extension of Emacs's. + +;;; Code: + +(require 'slime) ; only for its cl-lib loading smartness +(require 'cl-lib) +(eval-when-compile (require 'cl)) + +(defgroup lisp-indent nil + "Indentation in Lisp." + :group 'lisp) + +(defcustom lisp-indent-maximum-backtracking 6 + "Maximum depth to backtrack out from a sublist for structured indentation. +If this variable is 0, no backtracking will occur and forms such as `flet' +may not be correctly indented if this value is less than 4." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-tag-indentation 1 + "Indentation of tags relative to containing list. +This variable is used by the function `lisp-indent-tagbody'." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-tag-body-indentation 3 + "Indentation of non-tagged lines relative to containing list. +This variable is used by the function `lisp-indent-tagbody' to indent normal +lines (lines without tags). +The indentation is relative to the indentation of the parenthesis enclosing +the special form. If the value is t, the body of tags will be indented +as a block at the same indentation as the first s-expression following +the tag. In this case, any forms before the first tag are indented +by `lisp-body-indent'." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-backquote-indentation t + "Whether or not to indent backquoted lists as code. +If nil, indent backquoted lists as data, i.e., like quoted lists." + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-loop-indent-subclauses t + "Whether or not to indent loop subclauses." + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-simple-loop-indentation 2 + "Indentation of forms in simple loop forms." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-loop-clauses-indentation 2 + "Indentation of loop clauses if `loop' is immediately followed by a newline." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-loop-indent-body-forms-relative-to-loop-start nil + "When true, indent loop body clauses relative to the open paren of the loop +form, instead of the keyword position." + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-loop-body-forms-indentation 3 + "Indentation of loop body clauses." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-loop-indent-forms-like-keywords nil + "Whether or not to indent loop subforms just like +loop keywords. Only matters when `lisp-loop-indent-subclauses' +is nil." + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-align-keywords-in-calls t + "Whether to align keyword arguments vertically or not. +If t (the default), keywords in contexts where no other +indentation rule takes precedence are aligned like this: + +\(make-instance 'foo :bar t + :quux 42) + +If nil, they are indented like any other function +call arguments: + +\(make-instance 'foo :bar t + :quux 42)" + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-lambda-list-indentation t + "Whether to indent lambda-lists specially. Defaults to t. Setting this to +nil makes `lisp-lambda-list-keyword-alignment', +`lisp-lambda-list-keyword-parameter-alignment', and +`lisp-lambda-list-keyword-parameter-indentation' meaningless, causing +lambda-lists to be indented as if they were data: + +\(defun example (a b &optional o1 o2 + o3 o4 + &rest r + &key k1 k2 + k3 k4) + #|...|#)" + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-lambda-list-keyword-alignment nil + "Whether to vertically align lambda-list keywords together. +If nil (the default), keyworded lambda-list parts are aligned +with the initial mandatory arguments, like this: + +\(defun foo (arg1 arg2 &rest rest + &key key1 key2) + #|...|#) + +If non-nil, alignment is done with the first keyword +\(or falls back to the previous case), as in: + +\(defun foo (arg1 arg2 &rest rest + &key key1 key2) + #|...|#)" + :type 'boolean + :group 'lisp-indent) + +(defcustom lisp-lambda-list-keyword-parameter-indentation 2 + "Indentation of lambda list keyword parameters. +See `lisp-lambda-list-keyword-parameter-alignment' +for more information." + :type 'integer + :group 'lisp-indent) + +(defcustom lisp-lambda-list-keyword-parameter-alignment nil + "Whether to vertically align lambda-list keyword parameters together. +If nil (the default), the parameters are aligned +with their corresponding keyword, plus the value of +`lisp-lambda-list-keyword-parameter-indentation', like this: + +\(defun foo (arg1 arg2 &key key1 key2 + key3 key4) + #|...|#) + +If non-nil, alignment is done with the first parameter +\(or falls back to the previous case), as in: + +\(defun foo (arg1 arg2 &key key1 key2 + key3 key4) + #|...|#)" + :type 'boolean + :group 'lisp-indent) + + +(defvar lisp-indent-defun-method '(4 &lambda &body) + "Defun-like indentation method. +This applies when the value of the `common-lisp-indent-function' property +is set to `defun'.") + + +;;;; Named styles. +;;;; +;;;; -*- common-lisp-style: foo -*- +;;;; +;;;; sets the style for the buffer. +;;;; +;;;; A Common Lisp style is a list of the form: +;;;; +;;;; (NAME INHERIT VARIABLES INDENTATION HOOK DOCSTRING) +;;;; +;;;; where NAME is a symbol naming the style, INHERIT is the name of the style +;;;; it inherits from, VARIABLES is an alist specifying buffer local variables +;;;; for the style, and INDENTATION is an alist specifying non-standard +;;;; indentations for Common Lisp symbols. HOOK is a function to call when +;;;; activating the style. DOCSTRING is the documentation for the style. +;;;; +;;;; Convenience accessors `common-lisp-style-name', &co exist. +;;;; +;;;; `common-lisp-style' stores the name of the current style. +;;;; +;;;; `common-lisp-style-default' stores the name of the style to use when none +;;;; has been specified. +;;;; +;;;; `common-lisp-active-style' stores a cons of the list specifying the +;;;; current style, and a hash-table containing all indentation methods of +;;;; that style and any styles it inherits from. Whenever we're indenting, we +;;;; check that this is up to date, and recompute when necessary. +;;;; +;;;; Just setting the buffer local common-lisp-style will be enough to have +;;;; the style take effect. `common-lisp-set-style' can also be called +;;;; explicitly, however, and offers name completion, etc. + +;;; Convenience accessors +(defun common-lisp-style-name (style) (first style)) +(defun common-lisp-style-inherits (style) (second style)) +(defun common-lisp-style-variables (style) (third style)) +(defun common-lisp-style-indentation (style) (fourth style)) +(defun common-lisp-style-hook (style) (fifth style)) +(defun common-lisp-style-docstring (style) (sixth style)) + +(defun common-lisp-make-style (stylename inherits variables indentation hook + documentation) + (list stylename inherits variables indentation hook documentation)) + +(defvar common-lisp-style nil) + +;;; `define-common-lisp-style' updates the docstring of +;;; `common-lisp-style', using this as the base. +(put 'common-lisp-style 'common-lisp-style-base-doc + "Name of the Common Lisp indentation style used in the current buffer. +Set this by giving eg. + + ;; -*- common-lisp-style: sbcl -*- + +in the first line of the file, or by calling `common-lisp-set-style'. If +buffer has no style specified, but `common-lisp-style-default' is set, that +style is used instead. Use `define-common-lisp-style' to define new styles.") + +(make-variable-buffer-local 'common-lisp-style) +(set-default 'common-lisp-style nil) + +;;; `lisp-mode' kills all buffer-local variables. Setting the +;;; `permanent-local' property allows us to retain the style. +(put 'common-lisp-style 'permanent-local t) + +;;; Mark as safe when the style doesn't evaluate arbitrary code. +(put 'common-lisp-style 'safe-local-variable 'common-lisp-safe-style-p) + +;;; Common Lisp indentation style specifications. +(defvar common-lisp-styles (make-hash-table :test 'equal)) + +(defun common-lisp-delete-style (stylename) + (remhash stylename common-lisp-styles)) + +(defun common-lisp-find-style (stylename) + (let ((name (if (symbolp stylename) + (symbol-name stylename) + stylename))) + (or (gethash name common-lisp-styles) + (error "Unknown Common Lisp style: %s" name)))) + +(defun common-lisp-safe-style-p (stylename) + "True for known Common Lisp style without an :EVAL option. +Ie. styles that will not evaluate arbitrary code on activation." + (let* ((style (ignore-errors (common-lisp-find-style stylename))) + (base (common-lisp-style-inherits style))) + (and style + (not (common-lisp-style-hook style)) + (or (not base) + (common-lisp-safe-style-p base))))) + +(defun common-lisp-add-style (stylename inherits variables indentation hooks + documentation) + ;; Invalidate indentation methods cached in common-lisp-active-style. + (maphash (lambda (k v) + (puthash k (cl-copy-list v) common-lisp-styles)) + common-lisp-styles) + ;; Add/Redefine the specified style. + (puthash stylename + (common-lisp-make-style stylename inherits variables indentation + hooks documentation) + common-lisp-styles) + ;; Frob `common-lisp-style' docstring. + (let ((doc (get 'common-lisp-style 'common-lisp-style-base-doc)) + (all nil)) + (setq doc (concat doc "\n\nAvailable styles are:\n")) + (maphash (lambda (name style) + (push (list name (common-lisp-style-docstring style)) all)) + common-lisp-styles) + (dolist (info (sort all (lambda (a b) (string< (car a) (car b))))) + (let ((style-name (first info)) + (style-doc (second info))) + (if style-doc + (setq doc (concat doc + "\n " style-name "\n" + " " style-doc "\n")) + (setq doc (concat doc + "\n " style-name " (undocumented)\n"))))) + (put 'common-lisp-style 'variable-documentation doc)) + stylename) + +;;; Activate STYLENAME, adding its indentation methods to METHODS -- and +;;; recurse on style inherited from. +(defun common-lisp-activate-style (stylename methods) + (let* ((style (common-lisp-find-style stylename)) + (basename (common-lisp-style-inherits style))) + ;; Recurse on parent. + (when basename + (common-lisp-activate-style basename methods)) + ;; Copy methods + (dolist (spec (common-lisp-style-indentation style)) + (puthash (first spec) (second spec) methods)) + ;; Bind variables. + (dolist (var (common-lisp-style-variables style)) + (set (make-local-variable (first var)) (second var))) + ;; Run hook. + (let ((hook (common-lisp-style-hook style))) + (when hook + (funcall hook))))) + +;;; When a style is being used, `common-lisp-active-style' holds a cons +;;; +;;; (STYLE . METHODS) +;;; +;;; where STYLE is the list specifying the currently active style, and +;;; METHODS is the table of indentation methods -- including inherited +;;; ones -- for it. `common-lisp-active-style-methods' is reponsible +;;; for keeping this up to date. +(make-variable-buffer-local (defvar common-lisp-active-style nil)) + +;;; Makes sure common-lisp-active-style corresponds to common-lisp-style, and +;;; pick up redefinitions, etc. Returns the method table for the currently +;;; active style. +(defun common-lisp-active-style-methods () + (let* ((name common-lisp-style) + (style (when name (common-lisp-find-style name)))) + (if (eq style (car common-lisp-active-style)) + (cdr common-lisp-active-style) + (when style + (let ((methods (make-hash-table :test 'equal))) + (common-lisp-activate-style name methods) + (setq common-lisp-active-style (cons style methods)) + methods))))) + +(defvar common-lisp-set-style-history nil) + +(defun common-lisp-style-names () + (let (names) + (maphash (lambda (k v) + (push (cons k v) names)) + common-lisp-styles) + names)) + +(defun common-lisp-set-style (stylename) + "Set current buffer to use the Common Lisp style STYLENAME. +STYLENAME, a string, must be an existing Common Lisp style. Styles +are added (and updated) using `define-common-lisp-style'. + +The buffer-local variable `common-lisp-style' will get set to STYLENAME. + +A Common Lisp style is composed of local variables, indentation +specifications, and may also contain arbitrary elisp code to run upon +activation." + (interactive + (list (let ((completion-ignore-case t) + (prompt "Specify Common Lisp indentation style: ")) + (completing-read prompt + (common-lisp-style-names) nil t nil + 'common-lisp-set-style-history)))) + (setq common-lisp-style (common-lisp-style-name + (common-lisp-find-style stylename)) + common-lisp-active-style nil) + ;; Actually activates the style. + (common-lisp-active-style-methods) + stylename) + +(defmacro define-common-lisp-style (name documentation &rest options) + "Define a Common Lisp indentation style. + +NAME is the name of the style. + +DOCUMENTATION is the docstring for the style, automatically added to the +docstring of `common-lisp-style'. + +OPTIONS are: + + (:variables (name value) ...) + + Specifying the buffer local variables associated with the style. + + (:indentation (symbol spec) ...) + + Specifying custom indentations associated with the style. SPEC is + a normal `common-lisp-indent-function' indentation specification. + + (:inherit style) + + Inherit variables and indentations from another Common Lisp style. + + (:eval form ...) + + Lisp code to evaluate when activating the style. This can be used to + eg. activate other modes. It is possible that over the lifetime of + a buffer same style gets activated multiple times, so code in :eval + option should cope with that. +" + (when (consp documentation) + (setq options (cons documentation options) + documentation nil)) + `(common-lisp-add-style ,name + ',(cadr (assoc :inherit options)) + ',(cdr (assoc :variables options)) + ',(cdr (assoc :indentation options)) + ,(when (assoc :eval options) + `(lambda () + ,@(cdr (assoc :eval options)))) + ,documentation)) + +(define-common-lisp-style "basic-common" + (:variables + (lisp-indent-maximum-backtracking 6) + (lisp-tag-indentation 1) + (lisp-tag-body-indentation 3) + (lisp-backquote-indentation t) + (lisp-loop-indent-subclauses t) + (lisp-loop-indent-forms-like-keywords nil) + (lisp-simple-loop-indentation 2) + (lisp-align-keywords-in-calls t) + (lisp-lambda-list-indentation t) + (lisp-lambda-list-keyword-alignment nil) + (lisp-lambda-list-keyword-parameter-indentation 2) + (lisp-lambda-list-keyword-parameter-alignment nil) + (lisp-indent-defun-method (4 &lambda &body)) + (lisp-loop-clauses-indentation 2) + (lisp-loop-indent-body-forms-relative-to-loop-start nil) + (lisp-loop-body-forms-indentation 3))) + +(define-common-lisp-style "basic-emacs25" + "This style adds a workaround needed for Emacs 25" + (:inherit "basic-common") + (:variables + ;; Without these (;;foo would get a space inserted between + ;; ( and ; by indent-sexp. + (comment-indent-function (lambda () nil)))) + +(define-common-lisp-style "basic-emacs26" + "This style is the same as basic-common. It doesn't need or + want the workaround used in Emacs 25. In Emacs 26, that + workaround introduces a weird behavior where a single + semicolon breaks the mode and causes the cursor to move to the + start of the line after every character inserted." + (:inherit "basic-common")) + +(if (>= emacs-major-version 26) + (define-common-lisp-style "basic" + "This style merely gives all identation variables their default values, + making it easy to create new styles that are proof against user + customizations. It also adjusts comment indentation from default. + All other predefined modes inherit from basic." + (:inherit "basic-emacs26")) + (define-common-lisp-style "basic" + "This style merely gives all identation variables their default values, + making it easy to create new styles that are proof against user + customizations. It also adjusts comment indentation from default. + All other predefined modes inherit from basic." + (:inherit "basic-emacs25"))) + +(define-common-lisp-style "classic" + "This style of indentation emulates the most striking features of 1995 + vintage cl-indent.el once included as part of Slime: IF indented by two + spaces, and CASE clause bodies indentented more deeply than the keys." + (:inherit "basic") + (:variables + (lisp-lambda-list-keyword-parameter-indentation 0)) + (:indentation + (case (4 &rest (&whole 2 &rest 3))) + (if (4 2 2)))) + +(define-common-lisp-style "modern" + "A good general purpose style. Turns on lambda-list keyword and keyword + parameter alignment, and turns subclause aware loop indentation off. + (Loop indentation so because simpler style is more prevalent in existing + sources, not because it is necessarily preferred.)" + (:inherit "basic") + (:variables + (lisp-lambda-list-keyword-alignment t) + (lisp-lambda-list-keyword-parameter-alignment t) + (lisp-lambda-list-keyword-parameter-indentation 0) + (lisp-loop-indent-subclauses nil))) + +(define-common-lisp-style "sbcl" + "Style used in SBCL sources. A good if somewhat intrusive general purpose + style based on the \"modern\" style. Adds indentation for a few SBCL + specific constructs, sets indentation to use spaces instead of tabs, + fill-column to 78, and activates whitespace-mode to show tabs and trailing + whitespace." + (:inherit "modern") + (:eval + (whitespace-mode 1)) + (:variables + (whitespace-style (tabs trailing)) + (indent-tabs-mode nil) + (comment-fill-column nil) + (fill-column 78)) + (:indentation + (def!constant (as defconstant)) + (def!macro (as defmacro)) + (def!method (as defmethod)) + (def!struct (as defstruct)) + (def!type (as deftype)) + (defmacro-mundanely (as defmacro)) + (define-source-transform (as defun)) + (!def-type-translator (as defun)) + (!def-debug-command (as defun)))) + +(defcustom common-lisp-style-default nil + "Name of the Common Lisp indentation style to use in lisp-mode buffers if +none has been specified." + :type `(choice (const :tag "None" nil) + ,@(mapcar (lambda (spec) + `(const :tag ,(car spec) ,(car spec))) + (common-lisp-style-names)) + (string :tag "Other")) + :group 'lisp-indent) + +;;; If style is being used, that's a sufficient invitation to snag +;;; the indentation function. +(defun common-lisp-lisp-mode-hook () + (let ((style (or common-lisp-style common-lisp-style-default))) + (when style + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function) + (common-lisp-set-style style)))) +(add-hook 'lisp-mode-hook 'common-lisp-lisp-mode-hook) + + +;;;; The indentation specs are stored at three levels. In order of priority: +;;;; +;;;; 1. Indentation as set by current style, from the indentation table +;;;; in the current style. +;;;; +;;;; 2. Globally set indentation, from the `common-lisp-indent-function' +;;;; property of the symbol. +;;;; +;;;; 3. Per-package indentation derived by the system. A live Common Lisp +;;;; system may (via Slime, eg.) add indentation specs to +;;;; common-lisp-system-indentation, where they are associated with +;;;; the package of the symbol. Then we run some lossy heuristics and +;;;; find something that looks promising. +;;;; +;;;; FIXME: for non-system packages the derived indentation should probably +;;;; take precedence. + +;;; This maps symbols into lists of (INDENT . PACKAGES) where INDENT is +;;; an indentation spec, and PACKAGES are the names of packages where this +;;; applies. +;;; +;;; We never add stuff here by ourselves: this is for things like Slime to +;;; fill. +(defvar common-lisp-system-indentation (make-hash-table :test 'equal)) + +(defun common-lisp-guess-current-package () + (let (pkg) + (save-excursion + (ignore-errors + (when (let ((case-fold-search t)) + (search-backward "(in-package ")) + (re-search-forward "[ :\"]+") + (let ((start (point))) + (re-search-forward "[\":)]") + (setf pkg (upcase (buffer-substring-no-properties + start (1- (point))))))))) + pkg)) + +(defvar common-lisp-current-package-function 'common-lisp-guess-current-package + "Used to derive the package name to use for indentation at a +given point. Defaults to `common-lisp-guess-current-package'.") + +(defun common-lisp-symbol-package (string) + (if (and (stringp string) (string-match ":" string)) + (let ((p (match-beginning 0))) + (if (eql 0 p) + "KEYWORD" + (upcase (substring string 0 p)))) + (funcall common-lisp-current-package-function))) + +(defun common-lisp-get-indentation (name &optional full) + "Retrieves the indentation information for NAME." + (let ((method + (or + ;; From style + (when common-lisp-style + (gethash name (common-lisp-active-style-methods))) + ;; From global settings. + (get name 'common-lisp-indent-function) + ;; From system derived information. + (let ((system-info (gethash name common-lisp-system-indentation))) + (if (not (cdr system-info)) + (caar system-info) + (let ((guess nil) + (guess-n 0) + (package (common-lisp-symbol-package full))) + (dolist (info system-info guess) + (let* ((pkgs (cdr info)) + (n (length pkgs))) + (cond ((member package pkgs) + ;; This is it. + (return (car info))) + ((> n guess-n) + ;; If we can't find the real thing, go with the one + ;; accessible in most packages. + (setf guess (car info) + guess-n n))))))))))) + (if (and (consp method) (eq 'as (car method))) + (common-lisp-get-indentation (cadr method)) + method))) + +;;;; LOOP indentation, the simple version + +(defun common-lisp-loop-type (loop-start) + "Returns the type of the loop form at LOOP-START. +Possible types are SIMPLE, SIMPLE/SPLIT, EXTENDED, and EXTENDED/SPLIT. */SPLIT +refers to extended loops whose body does not start on the same line as the +opening parenthesis of the loop." + (let (comment-split) + (condition-case () + (save-excursion + (goto-char loop-start) + (let ((line (line-number-at-pos)) + (maybe-split t)) + (forward-char 1) + (forward-sexp 1) + (save-excursion + (when (looking-at "\\s-*\\\n*;") + (search-forward ";") + (backward-char 1) + (if (= line (line-number-at-pos)) + (setq maybe-split nil) + (setq comment-split t)))) + (forward-sexp 1) + (backward-sexp 1) + (if (eql (char-after) ?\() + (if (or (not maybe-split) (= line (line-number-at-pos))) + 'simple + 'simple/split) + (if (or (not maybe-split) (= line (line-number-at-pos))) + 'extended + 'extended/split)))) + (error + (if comment-split + 'simple/split + 'simple))))) + +(defun common-lisp-trailing-comment () + (ignore-errors + ;; If we had a trailing comment just before this, find it. + (save-excursion + (backward-sexp) + (forward-sexp) + (when (looking-at "\\s-*;") + (search-forward ";") + (1- (current-column)))))) + +;;;###autoload +(defun common-lisp-indent-function (indent-point state) + "Function to indent the arguments of a Lisp function call. +This is suitable for use as the value of the variable +`lisp-indent-function'. INDENT-POINT is the point at which the +indentation function is called, and STATE is the +`parse-partial-sexp' state at that position. Browse the +`lisp-indent' customize group for options affecting the behavior +of this function. + +If the indentation point is in a call to a Lisp function, that +function's common-lisp-indent-function property specifies how +this function should indent it. Possible values for this +property are: + +* defun, meaning indent according to `lisp-indent-defun-method'; + i.e., like (4 &lambda &body), as explained below. + +* any other symbol, meaning a function to call. The function should + take the arguments: PATH STATE INDENT-POINT SEXP-COLUMN NORMAL-INDENT. + PATH is a list of integers describing the position of point in terms of + list-structure with respect to the containing lists. For example, in + ((a b c (d foo) f) g), foo has a path of (0 3 1). In other words, + to reach foo take the 0th element of the outermost list, then + the 3rd element of the next list, and finally the 1st element. + STATE and INDENT-POINT are as in the arguments to + `common-lisp-indent-function'. SEXP-COLUMN is the column of + the open parenthesis of the innermost containing list. + NORMAL-INDENT is the column the indentation point was + originally in. This function should behave like `lisp-indent-259'. + +* an integer N, meaning indent the first N arguments like + function arguments, and any further arguments like a body. + This is equivalent to (4 4 ... &body). + +* a list starting with `as' specifies an indirection: indentation is done as + if the form being indented had started with the second element of the list. + +* any other list. The list element in position M specifies how to indent the + Mth function argument. If there are fewer elements than function arguments, + the last list element applies to all remaining arguments. The accepted list + elements are: + + * nil, meaning the default indentation. + + * an integer, specifying an explicit indentation. + + * &lambda. Indent the argument (which may be a list) by 4. + + * &rest. When used, this must be the penultimate element. The + element after this one applies to all remaining arguments. + + * &body. This is equivalent to &rest lisp-body-indent, i.e., indent + all remaining elements by `lisp-body-indent'. + + * &whole. This must be followed by nil, an integer, or a + function symbol. This indentation is applied to the + associated argument, and as a base indent for all remaining + arguments. For example, an integer P means indent this + argument by P, and all remaining arguments by P, plus the + value specified by their associated list element. + + * a symbol. A function to call, with the 6 arguments specified above. + + * a list, with elements as described above. This applies when the + associated function argument is itself a list. Each element of the list + specifies how to indent the associated argument. + +For example, the function `case' has an indent property +\(4 &rest (&whole 2 &rest 1)), meaning: + * indent the first argument by 4. + * arguments after the first should be lists, and there may be any number + of them. The first list element has an offset of 2, all the rest + have an offset of 2+1=3." + (common-lisp-indent-function-1 indent-point state)) + +;;; XEmacs doesn't have looking-back, so we define a simple one. Faster to +;;; boot, and sufficient for our needs. +(defun common-lisp-looking-back (string) + (let ((len (length string))) + (dotimes (i len t) + (unless (eql (elt string (- len i 1)) (char-before (- (point) i))) + (return nil))))) + +(defvar common-lisp-feature-expr-regexp "#!?\\(+\\|-\\)") + +;;; Semi-feature-expression aware keyword check. +(defun common-lisp-looking-at-keyword () + (or (looking-at ":") + (and (looking-at common-lisp-feature-expr-regexp) + (save-excursion + (forward-sexp) + (skip-chars-forward " \t\n") + (common-lisp-looking-at-keyword))))) + +;;; Semi-feature-expression aware backwards movement for keyword +;;; argument pairs. +(defun common-lisp-backward-keyword-argument () + (ignore-errors + (backward-sexp 2) + (when (looking-at common-lisp-feature-expr-regexp) + (cond ((ignore-errors + (save-excursion + (backward-sexp 2) + (looking-at common-lisp-feature-expr-regexp))) + (common-lisp-backward-keyword-argument)) + ((ignore-errors + (save-excursion + (backward-sexp 1) + (looking-at ":"))) + (backward-sexp)))) + t)) + +(defun common-lisp-indent-function-1 (indent-point state) + ;; If we're looking at a splice, move to the first comma. + (when (or (common-lisp-looking-back ",") (common-lisp-looking-back ",@")) + (when (re-search-backward "[^,@'],") + (forward-char 1))) + (let ((normal-indent (current-column))) + ;; Walk up list levels until we see something + ;; which does special things with subforms. + (let ((depth 0) + ;; Path describes the position of point in terms of + ;; list-structure with respect to containing lists. + ;; `foo' has a path of (0 3 1) in `((a b c (d foo) f) g)'. + (path ()) + ;; set non-nil when somebody works out the indentation to use + calculated + ;; If non-nil, this is an indentation to use + ;; if nothing else specifies it more firmly. + tentative-calculated + (last-point indent-point) + ;; the position of the open-paren of the innermost containing list + (containing-form-start (common-lisp-indent-parse-state-start state)) + ;; the column of the above + sexp-column) + ;; Move to start of innermost containing list + (goto-char containing-form-start) + (setq sexp-column (current-column)) + + ;; Look over successively less-deep containing forms + (while (and (not calculated) + (< depth lisp-indent-maximum-backtracking)) + (let ((containing-sexp (point))) + (forward-char 1) + (parse-partial-sexp (point) indent-point 1 t) + ;; Move to the car of the relevant containing form + (let (tem full function method tentative-defun) + (if (not (looking-at "\\sw\\|\\s_")) + ;; This form doesn't seem to start with a symbol + (setq function nil method nil full nil) + (setq tem (point)) + (forward-sexp 1) + (setq full (downcase (buffer-substring-no-properties + tem (point))) + function full) + (goto-char tem) + (setq tem (intern-soft function) + method (common-lisp-get-indentation tem)) + (cond ((and (null method) + (string-match ":[^:]+" function)) + ;; The pleblisp package feature + (setq function (substring function + (1+ (match-beginning 0))) + method (common-lisp-get-indentation + (intern-soft function) full))) + ((and (null method)) + ;; backwards compatibility + (setq method (common-lisp-get-indentation tem))))) + (let ((n 0)) + ;; How far into the containing form is the current form? + (if (< (point) indent-point) + (while (condition-case () + (progn + (forward-sexp 1) + (if (>= (point) indent-point) + nil + (parse-partial-sexp (point) + indent-point 1 t) + (setq n (1+ n)) + t)) + (error nil)))) + (setq path (cons n path))) + + ;; Guess. + (when (and (not method) function (null (cdr path))) + ;; (package prefix was stripped off above) + (cond ((and (string-match "\\`def" function) + (not (string-match "\\`default" function)) + (not (string-match "\\`definition" function)) + (not (string-match "\\`definer" function))) + (setq tentative-defun t)) + ((string-match + (eval-when-compile + (concat "\\`\\(" + (regexp-opt '("with" "without" "do")) + "\\)-")) + function) + (setq method '(&lambda &body))))) + + ;; #+ and #- cleverness. + (save-excursion + (goto-char indent-point) + (backward-sexp) + (let ((indent (current-column))) + (when (or (looking-at common-lisp-feature-expr-regexp) + (ignore-errors + (backward-sexp) + (when (looking-at + common-lisp-feature-expr-regexp) + (setq indent (current-column)) + (let ((line (line-number-at-pos))) + (while + (ignore-errors + (backward-sexp 2) + (and + (= line (line-number-at-pos)) + (looking-at + common-lisp-feature-expr-regexp))) + (setq indent (current-column)))) + t))) + (setq calculated (list indent containing-form-start))))) + + (cond ((and (or (eq (char-after (1- containing-sexp)) ?\') + (and (not lisp-backquote-indentation) + (eq (char-after (1- containing-sexp)) ?\`))) + (not (eq (char-after (- containing-sexp 2)) ?\#))) + ;; No indentation for "'(...)" elements + (setq calculated (1+ sexp-column))) + ((eq (char-after (1- containing-sexp)) ?\#) + ;; "#(...)" + (setq calculated (1+ sexp-column))) + ((null method) + ;; If this looks like a call to a `def...' form, + ;; think about indenting it as one, but do it + ;; tentatively for cases like + ;; (flet ((defunp () + ;; nil))) + ;; Set both normal-indent and tentative-calculated. + ;; The latter ensures this value gets used + ;; if there are no relevant containing constructs. + ;; The former ensures this value gets used + ;; if there is a relevant containing construct + ;; but we are nested within the structure levels + ;; that it specifies indentation for. + (if tentative-defun + (setq tentative-calculated + (common-lisp-indent-call-method + function lisp-indent-defun-method + path state indent-point + sexp-column normal-indent) + normal-indent tentative-calculated) + (when lisp-align-keywords-in-calls + ;; No method so far. If we're looking at a keyword, + ;; align with the first keyword in this expression. + ;; This gives a reasonable indentation to most things + ;; with keyword arguments. + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (when (common-lisp-looking-at-keyword) + (while (common-lisp-backward-keyword-argument) + (when (common-lisp-looking-at-keyword) + (setq calculated + (list (current-column) + containing-form-start))))))))) + ((integerp method) + ;; convenient top-level hack. + ;; (also compatible with lisp-indent-function) + ;; The number specifies how many `distinguished' + ;; forms there are before the body starts + ;; Equivalent to (4 4 ... &body) + (setq calculated (cond ((cdr path) + normal-indent) + ((<= (car path) method) + ;; `distinguished' form + (list (+ sexp-column 4) + containing-form-start)) + ((= (car path) (1+ method)) + ;; first body form. + (+ sexp-column lisp-body-indent)) + (t + ;; other body form + normal-indent)))) + (t + (setq calculated + (common-lisp-indent-call-method + function method path state indent-point + sexp-column normal-indent))))) + (goto-char containing-sexp) + (setq last-point containing-sexp) + (unless calculated + (condition-case () + (progn (backward-up-list 1) + (setq depth (1+ depth))) + (error + (setq depth lisp-indent-maximum-backtracking)))))) + + (or calculated tentative-calculated + ;; Fallback. + ;; + ;; Instead of punting directly to calculate-lisp-indent we + ;; handle a few of cases it doesn't deal with: + ;; + ;; A: (foo ( + ;; bar zot + ;; quux)) + ;; + ;; would align QUUX with ZOT. + ;; + ;; B: + ;; (foo (or x + ;; y) t + ;; z) + ;; + ;; would align the Z with Y. + ;; + ;; C: + ;; (foo ;; Comment + ;; (bar) + ;; ;; Comment 2 + ;; (quux)) + ;; + ;; would indent BAR and QUUX by one. + (ignore-errors + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (let ((p (point))) + (goto-char containing-form-start) + (down-list) + (let ((one (current-column))) + (skip-chars-forward " \t") + (if (or (eolp) (looking-at ";")) + ;; A. + (list one containing-form-start) + (forward-sexp 2) + (backward-sexp) + (if (/= p (point)) + ;; B. + (list (current-column) containing-form-start) + (backward-sexp) + (forward-sexp) + (let ((tmp (+ (current-column) 1))) + (skip-chars-forward " \t") + (if (looking-at ";") + ;; C. + (list tmp containing-form-start))))))))))))) + + +(defun common-lisp-indent-call-method (function method path state indent-point + sexp-column normal-indent) + (let ((lisp-indent-error-function function)) + (if (symbolp method) + (funcall method + path state indent-point + sexp-column normal-indent) + (lisp-indent-259 method path state indent-point + sexp-column normal-indent)))) + +;; Dynamically bound in common-lisp-indent-call-method. +(defvar lisp-indent-error-function) + +(defun lisp-indent-report-bad-format (m) + (error "%s has a badly-formed %s property: %s" + ;; Love those free variable references!! + lisp-indent-error-function 'common-lisp-indent-function m)) + + +;; Lambda-list indentation is now done in LISP-INDENT-LAMBDA-LIST. +;; See also `lisp-lambda-list-keyword-alignment', +;; `lisp-lambda-list-keyword-parameter-alignment' and +;; `lisp-lambda-list-keyword-parameter-indentation' -- dvl + +(defvar lisp-indent-lambda-list-keywords-regexp + "&\\(\ +optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|\ +environment\\|more\ +\\)\\>" + "Regular expression matching lambda-list keywords.") + +(defun lisp-indent-lambda-list + (indent-point sexp-column containing-form-start) + (if (not lisp-lambda-list-indentation) + (1+ sexp-column) + (lisp-properly-indent-lambda-list + indent-point sexp-column containing-form-start))) + +(defun lisp-properly-indent-lambda-list + (indent-point sexp-column containing-form-start) + (let (limit) + (cond + ((save-excursion + (goto-char indent-point) + (back-to-indentation) + (setq limit (point)) + (looking-at lisp-indent-lambda-list-keywords-regexp)) + ;; We're facing a lambda-list keyword. + (if lisp-lambda-list-keyword-alignment + ;; Align to the first keyword if any, or to the beginning of + ;; the lambda-list. + (save-excursion + (goto-char containing-form-start) + (down-list) + (let ((key-indent nil) + (next t)) + (while (and next (< (point) indent-point)) + (if (looking-at lisp-indent-lambda-list-keywords-regexp) + (setq key-indent (current-column) + next nil) + (setq next (ignore-errors (forward-sexp) t)) + (if next + (ignore-errors + (forward-sexp) + (backward-sexp))))) + (or key-indent + (1+ sexp-column)))) + ;; Align to the beginning of the lambda-list. + (1+ sexp-column))) + (t + ;; Otherwise, align to the first argument of the last lambda-list + ;; keyword, the keyword itself, or the beginning of the + ;; lambda-list. + (save-excursion + (goto-char indent-point) + (let ((indent nil) + (next t)) + (while (and next (> (point) containing-form-start)) + (setq next (ignore-errors (backward-sexp) t)) + (let* ((col (current-column)) + (pos + (save-excursion + (ignore-errors (forward-sexp)) + (skip-chars-forward " \t") + (if (eolp) + (+ col + lisp-lambda-list-keyword-parameter-indentation) + col)))) + (if (looking-at lisp-indent-lambda-list-keywords-regexp) + (setq indent + (if lisp-lambda-list-keyword-parameter-alignment + (or indent pos) + (+ col + lisp-lambda-list-keyword-parameter-indentation)) + next nil) + (setq indent col)))) + (or indent (1+ sexp-column)))))))) + +(defun common-lisp-lambda-list-initial-value-form-p (point) + (let ((state 'x) + (point (save-excursion + (goto-char point) + (back-to-indentation) + (point)))) + (save-excursion + (backward-sexp) + (ignore-errors (down-list 1)) + (while (and point (< (point) point)) + (cond ((or (looking-at "&key") (looking-at "&optional") + (looking-at "&aux")) + (setq state 'key)) + ((looking-at lisp-indent-lambda-list-keywords-regexp) + (setq state 'x))) + (if (not (ignore-errors (forward-sexp) t)) + (setq point nil) + (ignore-errors + (forward-sexp) + (backward-sexp)) + (cond ((> (point) point) + (backward-sexp) + (when (eq state 'var) + (setq state 'x)) + (or (ignore-errors + (down-list 1) + (cond ((> (point) point) + (backward-up-list)) + ((eq 'key state) + (setq state 'var))) + t) + (setq point nil))) + ((eq state 'var) + (setq state 'form)))))) + (eq 'form state))) + +;; Blame the crufty control structure on dynamic scoping +;; -- not on me! +(defun lisp-indent-259 + (method path state indent-point sexp-column normal-indent) + (catch 'exit + (let* ((p (cdr path)) + (containing-form-start (elt state 1)) + (n (1- (car path))) + tem tail) + (if (not (consp method)) + (lisp-indent-report-bad-format method)) + (while n + ;; This while loop is for advancing along a method + ;; until the relevant (possibly &rest/&body) pattern + ;; is reached. + ;; n is set to (1- n) and method to (cdr method) + ;; each iteration. + (setq tem (car method)) + + (or (eq tem 'nil) ;default indentation + (eq tem '&lambda) ;lambda list + (and (eq tem '&body) (null (cdr method))) + (and (eq tem '&rest) + (consp (cdr method)) + (null (cddr method))) + (integerp tem) ;explicit indentation specified + (and (consp tem) ;destructuring + (or (consp (car tem)) + (and (eq (car tem) '&whole) + (or (symbolp (cadr tem)) + (integerp (cadr tem)))))) + (and (symbolp tem) ;a function to call to do the work. + (null (cdr method))) + (lisp-indent-report-bad-format method)) + (cond ((eq tem '&body) + ;; &body means (&rest ) + (throw 'exit + (if (null p) + (+ sexp-column lisp-body-indent) + normal-indent))) + ((eq tem '&rest) + ;; this pattern holds for all remaining forms + (setq tail (> n 0) + n 0 + method (cdr method))) + ((> n 0) + ;; try next element of pattern + (setq n (1- n) + method (cdr method)) + (if (< n 0) + ;; Too few elements in pattern. + (throw 'exit normal-indent))) + ((eq tem 'nil) + (throw 'exit (if (consp normal-indent) + normal-indent + (list normal-indent containing-form-start)))) + ((eq tem '&lambda) + (throw 'exit + (cond ((not (common-lisp-looking-back ")")) + ;; If it's not a list at all, indent it + ;; like body instead. + (if (null p) + (+ sexp-column lisp-body-indent) + normal-indent)) + ((common-lisp-lambda-list-initial-value-form-p + indent-point) + (if (consp normal-indent) + normal-indent + (list normal-indent containing-form-start))) + ((null p) + (list (+ sexp-column 4) containing-form-start)) + (t + ;; Indentation within a lambda-list. -- dvl + (list (lisp-indent-lambda-list + indent-point + sexp-column + containing-form-start) + containing-form-start))))) + ((integerp tem) + (throw 'exit + (if (null p) ;not in subforms + (list (+ sexp-column tem) containing-form-start) + normal-indent))) + ((symbolp tem) ;a function to call + (throw 'exit + (funcall tem path state indent-point + sexp-column normal-indent))) + (t + ;; must be a destructing frob + (if p + ;; descend + (setq method (cddr tem) + n (car p) + p (cdr p) + tail nil) + (let ((wholep (eq '&whole (car tem)))) + (setq tem (cadr tem)) + (throw 'exit + (cond (tail + (if (and wholep (integerp tem) + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (looking-at "\\sw"))) + ;; There's a further level of + ;; destructuring, but we're looking at a + ;; word -- indent to sexp. + (+ sexp-column tem) + normal-indent)) + ((not tem) + (list normal-indent + containing-form-start)) + ((integerp tem) + (list (+ sexp-column tem) + containing-form-start)) + (t + (funcall tem path state indent-point + sexp-column normal-indent)))))))))))) + +(defun lisp-indent-tagbody (path state indent-point sexp-column normal-indent) + (if (not (null (cdr path))) + normal-indent + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (list (cond ((looking-at "\\sw\\|\\s_") + ;; a tagbody tag + (+ sexp-column lisp-tag-indentation)) + ((integerp lisp-tag-body-indentation) + (+ sexp-column lisp-tag-body-indentation)) + ((eq lisp-tag-body-indentation 't) + (condition-case () + (progn (backward-sexp 1) (current-column)) + (error (1+ sexp-column)))) + (t (+ sexp-column lisp-body-indent))) +; (cond ((integerp lisp-tag-body-indentation) +; (+ sexp-column lisp-tag-body-indentation)) +; ((eq lisp-tag-body-indentation 't) +; normal-indent) +; (t +; (+ sexp-column lisp-body-indent))) + (elt state 1) + )))) + +(defun lisp-indent-do (path state indent-point sexp-column normal-indent) + (if (>= (car path) 3) + (let ((lisp-tag-body-indentation lisp-body-indent)) + (funcall (function lisp-indent-tagbody) + path state indent-point sexp-column normal-indent)) + (funcall (function lisp-indent-259) + '((&whole nil &rest + ;; the following causes weird indentation + ;;(&whole 1 1 2 nil) + ) + (&whole nil &rest 1)) + path state indent-point sexp-column normal-indent))) + +(defun lisp-indent-defsetf + (path state indent-point sexp-column normal-indent) + (list + (cond + ;; Inside the lambda-list in a long-form defsetf. + ((and (eql 2 (car path)) (cdr path)) + (lisp-indent-lambda-list indent-point sexp-column (elt state 1))) + ;; Long form: has a lambda-list. + ((or (cdr path) + (save-excursion + (goto-char (elt state 1)) + (ignore-errors + (down-list) + (forward-sexp 3) + (backward-sexp) + (looking-at "nil\\|(")))) + (+ sexp-column + (case (car path) + ((1 3) 4) + (2 4) + (t 2)))) + ;; Short form. + (t + (+ sexp-column + (case (car path) + (1 4) + (2 4) + (t 2))))) + (elt state 1))) + +(defun lisp-beginning-of-defmethod-qualifiers () + (let ((regexp-1 "(defmethod\\|(DEFMETHOD") + (regexp-2 "(:method\\|(:METHOD")) + (while (and (not (or (looking-at regexp-1) + (looking-at regexp-2))) + (ignore-errors (backward-up-list) t))) + (cond ((looking-at regexp-1) + (forward-char) + ;; Skip name. + (forward-sexp 2) + 1) + ((looking-at regexp-2) + (forward-char) + (forward-sexp 1) + 0)))) + +;; LISP-INDENT-DEFMETHOD now supports the presence of more than one method +;; qualifier and indents the method's lambda list properly. -- dvl +(defun lisp-indent-defmethod + (path state indent-point sexp-column normal-indent) + (lisp-indent-259 + (let ((nskip nil)) + (if (save-excursion + (when (setq nskip (lisp-beginning-of-defmethod-qualifiers)) + (skip-chars-forward " \t\n") + (while (looking-at "\\sw\\|\\s_") + (incf nskip) + (forward-sexp) + (skip-chars-forward " \t\n")) + t)) + (append (make-list nskip 4) '(&lambda &body)) + (common-lisp-get-indentation 'defun))) + path state indent-point sexp-column normal-indent)) + +(defun lisp-indent-function-lambda-hack (path state indent-point + sexp-column normal-indent) + ;; indent (function (lambda () )) kludgily. + (if (or (cdr path) ; wtf? + (> (car path) 3)) + ;; line up under previous body form + normal-indent + ;; line up under function rather than under lambda in order to + ;; conserve horizontal space. (Which is what #' is for.) + (condition-case () + (save-excursion + (backward-up-list 2) + (forward-char 1) + (if (looking-at "\\(lisp:+\\)?function\\(\\Sw\\|\\S_\\)") + (+ lisp-body-indent -1 (current-column)) + (+ sexp-column lisp-body-indent))) + (error (+ sexp-column lisp-body-indent))))) + +(defun lisp-indent-loop (path state indent-point sexp-column normal-indent) + (if (cdr path) + normal-indent + (let* ((loop-start (elt state 1)) + (type (common-lisp-loop-type loop-start))) + (cond ((and lisp-loop-indent-subclauses + (member type '(extended extended/split))) + (list (common-lisp-indent-loop-macro-1 state indent-point) + (common-lisp-indent-parse-state-start state))) + (t + (common-lisp-loop-part-indentation indent-point state type)))))) + +;;;; LOOP indentation, the complex version -- handles subclause indentation + +;; Regexps matching various varieties of loop macro keyword ... +(defvar common-lisp-body-introducing-loop-macro-keyword + "\\(#?:\\)?\\(do\\(ing\\)?\\|finally\\|initially\\)" + "Regexp matching loop macro keywords which introduce body forms.") + +;; Not currenctly used +(defvar common-lisp-accumlation-loop-macro-keyword + "\\(#?:\\)?\\(collect\\(ing\\)?\\|append\\(ing\\)?\\|nconc\\(ing\\)?\\|\ +count\\(ing\\)?\\|sum\\(ming\\)?\\|maximiz\\(e\\|ing\\)\\|\ +minimiz\\(e\\|ing\\)\\)" + "Regexp matching loop macro keywords which introduce accumulation clauses.") + +;; This is so "and when" and "else when" get handled right +;; (not to mention "else do" !!!) +(defvar common-lisp-prefix-loop-macro-keyword + "\\(#?:\\)?\\(and\\|else\\)" + "Regexp matching loop macro keywords which are prefixes.") + +(defvar common-lisp-indent-clause-joining-loop-macro-keyword + "\\(#?:\\)?and" + "Regexp matching 'and', and anything else there ever comes to be like it.") + +(defvar common-lisp-indent-indented-loop-macro-keyword + "\\(#?:\\)?\\(\\(up\\|down\\)?(from\\|to)\\|below\\|above\\|in\\(to\\)?\\|\ +on\\|=\\|then\\|across\\|being\\|each\\|the\\|of\\|using\\|\ +\\(present-\\|external-\\)?symbols?\\|fixnum\\|float\\|t\\|nil\\|of-type\\)" + "Regexp matching keywords introducing loop subclauses. +Always indented two.") + +(defvar common-lisp-indenting-loop-macro-keyword + "\\(#?:\\)?\\(when\\|unless\\|if\\)" + "Regexp matching keywords introducing conditional clauses. +Cause subsequent clauses to be indented.") + +(defvar common-lisp-loop-macro-else-keyword "\\(#?:\\)?else") + +;;; Attempt to indent the loop macro ... + +(defun common-lisp-indent-parse-state-depth (parse-state) + (car parse-state)) + +(defun common-lisp-indent-parse-state-start (parse-state) + (car (cdr parse-state))) + +(defun common-lisp-indent-parse-state-prev (parse-state) + (car (cdr (cdr parse-state)))) + +(defun common-lisp-loop-part-indentation (indent-point state type) + "Compute the indentation of loop form constituents." + (let* ((loop-start (elt state 1)) + (loop-indentation (save-excursion + (goto-char loop-start) + (if (eq type 'extended/split) + (- (current-column) 4) + (current-column)))) + (indent nil) + (re "\\(\\(#?:\\)?\\sw+\\|)\\|\n\\)")) + (goto-char indent-point) + (back-to-indentation) + (cond ((eq type 'simple/split) + (+ loop-indentation lisp-simple-loop-indentation)) + ((eq type 'simple) + (+ loop-indentation 6)) + ;; We are already in a body, with forms in it. + ((and (not (looking-at re)) + (save-excursion + (while (and (ignore-errors (backward-sexp) t) + (not (looking-at re))) + (setq indent (current-column))) + (when (and indent + (looking-at + common-lisp-body-introducing-loop-macro-keyword)) + t))) + (list indent loop-start)) + ;; Keyword-style or comment outside body + ((or lisp-loop-indent-forms-like-keywords + (looking-at re) + (looking-at ";")) + (if (and (looking-at ";") + (let ((p (common-lisp-trailing-comment))) + (when p + (setq loop-indentation p)))) + (list loop-indentation loop-start) + (list (+ loop-indentation 6) loop-start))) + ;; Form-style + (t + (list (+ loop-indentation 9) loop-start))))) + +(defun common-lisp-indent-loop-macro-1 (parse-state indent-point) + (catch 'return-indentation + (save-excursion + ;; Find first clause of loop macro, and use it to establish + ;; base column for indentation + (goto-char (common-lisp-indent-parse-state-start parse-state)) + (let ((loop-start-column (current-column))) + (common-lisp-loop-advance-past-keyword-on-line) + + (when (eolp) + (forward-line 1) + (end-of-line) + ;; If indenting first line after "(loop " + ;; cop out ... + (if (<= indent-point (point)) + (throw 'return-indentation (+ lisp-loop-clauses-indentation + loop-start-column))) + (back-to-indentation)) + + (let* ((case-fold-search t) + (loop-macro-first-clause (point)) + (previous-expression-start + (common-lisp-indent-parse-state-prev parse-state)) + (default-value (current-column)) + (loop-body-p nil) + (loop-body-indentation nil) + (indented-clause-indentation (+ 2 default-value))) + ;; Determine context of this loop clause, starting with the + ;; expression immediately preceding the line we're trying to indent + (goto-char previous-expression-start) + + ;; Handle a body-introducing-clause which ends a line specially. + (if (looking-at common-lisp-body-introducing-loop-macro-keyword) + (let ((keyword-position (current-column))) + (setq loop-body-p t) + (setq loop-body-indentation + (if (common-lisp-loop-advance-past-keyword-on-line) + (current-column) + (back-to-indentation) + (if (/= (current-column) keyword-position) + (+ 2 (current-column)) + (+ lisp-loop-body-forms-indentation + (if lisp-loop-indent-body-forms-relative-to-loop-start + loop-start-column + keyword-position)))))) + + (back-to-indentation) + (if (< (point) loop-macro-first-clause) + (goto-char loop-macro-first-clause)) + ;; If there's an "and" or "else," advance over it. + ;; If it is alone on the line, the next "cond" will treat it + ;; as if there were a "when" and indent under it ... + (let ((exit nil)) + (while (and (null exit) + (looking-at common-lisp-prefix-loop-macro-keyword)) + (if (null (common-lisp-loop-advance-past-keyword-on-line)) + (progn (setq exit t) + (back-to-indentation))))) + + ;; Found start of loop clause preceding the one we're + ;; trying to indent. Glean context ... + (cond + ((looking-at "(") + ;; We're in the middle of a clause body ... + (setq loop-body-p t) + (setq loop-body-indentation (current-column))) + ((looking-at common-lisp-body-introducing-loop-macro-keyword) + (setq loop-body-p t) + ;; Know there's something else on the line (or would + ;; have been caught above) + (common-lisp-loop-advance-past-keyword-on-line) + (setq loop-body-indentation (current-column))) + (t + (setq loop-body-p nil) + (if (or (looking-at common-lisp-indenting-loop-macro-keyword) + (looking-at common-lisp-prefix-loop-macro-keyword)) + (setq default-value (+ 2 (current-column)))) + (setq indented-clause-indentation (+ 2 (current-column))) + ;; We still need loop-body-indentation for "syntax errors" ... + (goto-char previous-expression-start) + (setq loop-body-indentation (current-column))))) + + ;; Go to first non-blank character of the line we're trying + ;; to indent. (if none, wind up poised on the new-line ...) + (goto-char indent-point) + (back-to-indentation) + (cond + ((looking-at "(") + ;; Clause body ... + loop-body-indentation) + ((or (eolp) (looking-at ";")) + ;; Blank line. If body-p, indent as body, else indent as + ;; vanilla clause. + (if loop-body-p + loop-body-indentation + (or (and (looking-at ";") (common-lisp-trailing-comment)) + default-value))) + ((looking-at common-lisp-indent-indented-loop-macro-keyword) + indented-clause-indentation) + ((looking-at common-lisp-indent-clause-joining-loop-macro-keyword) + (let ((stolen-indent-column nil)) + (forward-line -1) + (while (and (null stolen-indent-column) + (> (point) loop-macro-first-clause)) + (back-to-indentation) + (if (and (< (current-column) loop-body-indentation) + (looking-at "\\(#?:\\)?\\sw")) + (progn + (if (looking-at common-lisp-loop-macro-else-keyword) + (common-lisp-loop-advance-past-keyword-on-line)) + (setq stolen-indent-column + (current-column))) + (forward-line -1))) + (if stolen-indent-column + stolen-indent-column + default-value))) + (t default-value))))))) + +(defun common-lisp-loop-advance-past-keyword-on-line () + (forward-word 1) + (while (and (looking-at "\\s-") (not (eolp))) + (forward-char 1)) + (if (eolp) + nil + (current-column))) + +;;;; IF* is not standard, but a plague upon the land +;;;; ...let's at least try to indent it. + +(defvar common-lisp-indent-if*-keyword + "threnret\\|elseif\\|then\\|else" + "Regexp matching if* keywords") + +(defun common-lisp-indent-if* + (path parse-state indent-point sexp-column normal-indent) + (list (common-lisp-indent-if*-1 parse-state indent-point) + (common-lisp-indent-parse-state-start parse-state))) + +(defun common-lisp-indent-if*-1 (parse-state indent-point) + (catch 'return-indentation + (save-excursion + ;; Find first clause of if* macro, and use it to establish + ;; base column for indentation + (goto-char (common-lisp-indent-parse-state-start parse-state)) + (let ((if*-start-column (current-column))) + (common-lisp-indent-if*-advance-past-keyword-on-line) + (let* ((case-fold-search t) + (if*-first-clause (point)) + (previous-expression-start + (common-lisp-indent-parse-state-prev parse-state)) + (default-value (current-column)) + (if*-body-p nil) + (if*-body-indentation nil)) + ;; Determine context of this if* clause, starting with the + ;; expression immediately preceding the line we're trying to indent + (goto-char previous-expression-start) + ;; Handle a body-introducing-clause which ends a line specially. + (back-to-indentation) + (if (< (point) if*-first-clause) + (goto-char if*-first-clause)) + ;; Found start of if* clause preceding the one we're trying + ;; to indent. Glean context ... + (cond + ((looking-at common-lisp-indent-if*-keyword) + (setq if*-body-p t) + ;; Know there's something else on the line (or would + ;; have been caught above) + (common-lisp-indent-if*-advance-past-keyword-on-line) + (setq if*-body-indentation (current-column))) + ((looking-at "#'\\|'\\|(") + ;; We're in the middle of a clause body ... + (setq if*-body-p t) + (setq if*-body-indentation (current-column))) + (t + (setq if*-body-p nil) + ;; We still need if*-body-indentation for "syntax errors" ... + (goto-char previous-expression-start) + (setq if*-body-indentation (current-column)))) + + ;; Go to first non-blank character of the line we're trying + ;; to indent. (if none, wind up poised on the new-line ...) + (goto-char indent-point) + (back-to-indentation) + (cond + ((or (eolp) (looking-at ";")) + ;; Blank line. If body-p, indent as body, else indent as + ;; vanilla clause. + (if if*-body-p + if*-body-indentation + default-value)) + ((not (looking-at common-lisp-indent-if*-keyword)) + ;; Clause body ... + if*-body-indentation) + (t + (- (+ 7 if*-start-column) + (- (match-end 0) (match-beginning 0)))))))))) + +(defun common-lisp-indent-if*-advance-past-keyword-on-line () + (forward-word 1) + (block move-forward + (while (and (looking-at "\\s-") (not (eolp))) + (forward-char 1))) + (if (eolp) + nil + (current-column))) + + +;;;; Indentation specs for standard symbols, and a few semistandard ones. +(defun common-lisp-init-standard-indentation () + (let ((l '((block 1) + (case (4 &rest (&whole 2 &rest 1))) + (ccase (as case)) + (ecase (as case)) + (typecase (as case)) + (etypecase (as case)) + (ctypecase (as case)) + (catch 1) + (cond (&rest (&whole 2 &rest nil))) + ;; for DEFSTRUCT + (:constructor (4 &lambda)) + (defvar (4 2 2)) + (defclass (6 (&whole 4 &rest 1) + (&whole 2 &rest 1) + (&whole 2 &rest 1))) + (defconstant (as defvar)) + (defcustom (4 2 2 2)) + (defparameter (as defvar)) + (defconst (as defcustom)) + (define-condition (as defclass)) + (define-modify-macro (4 &lambda &body)) + (defsetf lisp-indent-defsetf) + (defun (4 &lambda &body)) + (defgeneric (4 &lambda &body)) + (define-setf-method (as defun)) + (define-setf-expander (as defun)) + (defmacro (as defun)) + (defsubst (as defun)) + (deftype (as defun)) + (defmethod lisp-indent-defmethod) + (defpackage (4 2)) + (defstruct ((&whole 4 &rest (&whole 2 &rest 1)) + &rest (&whole 2 &rest 1))) + (destructuring-bind (&lambda 4 &body)) + (do lisp-indent-do) + (do* (as do)) + (dolist ((&whole 4 2 1) &body)) + (dotimes (as dolist)) + (eval-when 1) + (flet ((&whole 4 &rest (&whole 1 4 &lambda &body)) &body)) + (labels (as flet)) + (macrolet (as flet)) + (generic-flet (as flet)) + (generic-labels (as flet)) + (handler-case (4 &rest (&whole 2 &lambda &body))) + (restart-case (as handler-case)) + ;; single-else style (then and else equally indented) + (if (&rest nil)) + (if* common-lisp-indent-if*) + (lambda (&lambda &rest lisp-indent-function-lambda-hack)) + (let ((&whole 4 &rest (&whole 1 1 2)) &body)) + (let* (as let)) + (compiler-let (as let)) + (handler-bind (as let)) + (restart-bind (as let)) + (locally 1) + (loop lisp-indent-loop) + (:method lisp-indent-defmethod) ; in `defgeneric' + (multiple-value-bind ((&whole 6 &rest 1) 4 &body)) + (multiple-value-call (4 &body)) + (multiple-value-prog1 1) + (multiple-value-setq (4 2)) + (multiple-value-setf (as multiple-value-setq)) + (named-lambda (4 &lambda &rest lisp-indent-function-lambda-hack)) + (pprint-logical-block (4 2)) + (print-unreadable-object ((&whole 4 1 &rest 1) &body)) + ;; Combines the worst features of BLOCK, LET and TAGBODY + (prog (&lambda &rest lisp-indent-tagbody)) + (prog* (as prog)) + (prog1 1) + (prog2 2) + (progn 0) + (progv (4 4 &body)) + (return 0) + (return-from (nil &body)) + (symbol-macrolet (as let)) + (tagbody lisp-indent-tagbody) + (throw 1) + (unless 1) + (unwind-protect (5 &body)) + (when 1) + (with-accessors (as multiple-value-bind)) + (with-compilation-unit ((&whole 4 &rest 1) &body)) + (with-condition-restarts (as multiple-value-bind)) + (with-output-to-string (4 2)) + (with-slots (as multiple-value-bind)) + (with-standard-io-syntax (2))))) + (dolist (el l) + (let* ((name (car el)) + (spec (cdr el)) + (indentation + (if (symbolp spec) + (error "Old style indirect indentation spec: %s" el) + (when (cdr spec) + (error "Malformed indentation specification: %s" el)) + (car spec)))) + (unless (symbolp name) + (error "Cannot set Common Lisp indentation of a non-symbol: %s" + name)) + (put name 'common-lisp-indent-function indentation))))) +(common-lisp-init-standard-indentation) + +(provide 'cl-indent) +(provide 'slime-cl-indent) + +;;; slime-cl-indent.el ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-clipboard.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-clipboard.el new file mode 100644 index 0000000..4f5dd17 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-clipboard.el @@ -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 ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-compiler-notes-tree.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-compiler-notes-tree.el new file mode 100644 index 0000000..bada587 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-compiler-notes-tree.el @@ -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 ") + (: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-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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-editing-commands.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-editing-commands.el new file mode 100644 index 0000000..db7bb01 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-editing-commands.el @@ -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 " + "Luke Gorrie " + "Bill Clementson " + "Tobias C. Rittweiler ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-enclosing-context.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-enclosing-context.el new file mode 100644 index 0000000..53cee76 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-enclosing-context.el @@ -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 ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy-inspector.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy-inspector.el new file mode 100644 index 0000000..02d0131 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy-inspector.el @@ -0,0 +1,42 @@ +(eval-and-compile + (require 'slime)) + +(define-slime-contrib slime-fancy-inspector + "Fancy inspector for CLOS objects." + (:authors "Marco Baringer 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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy-trace.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy-trace.el new file mode 100644 index 0000000..06a1fab --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy-trace.el @@ -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 " + "Tobias C. Rittweiler ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy.el new file mode 100644 index 0000000..5aba81c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy.el @@ -0,0 +1,38 @@ +(require 'slime) + +(define-slime-contrib slime-fancy + "Make SLIME fancy." + (:authors "Matthias Koeppe " + "Tobias C Rittweiler ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fontifying-fu.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fontifying-fu.el new file mode 100644 index 0000000..42de251 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fontifying-fu.el @@ -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 ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fuzzy.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fuzzy.el new file mode 100644 index 0000000..b2f22f1 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fuzzy.el @@ -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 " + "Tobias C. Rittweiler " + "Attila Lendvai ") + (: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 "")) + 'slime-fuzzy-select-or-update-completions) + (def `([remap previous-line] + ,(kbd "")) + 'slime-fuzzy-prev) + (def `([remap next-line] + ,(kbd "")) + 'slime-fuzzy-next) + (def `([remap isearch-forward] + ,(kbd "C-s")) + 'slime-fuzzy-continue-isearch-in-fuzzy-buffer) + ;; some unconditional direct bindings + (def (list (kbd "") (kbd "RET") (kbd "") "(" ")" "[" "]") + '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 "")) + 'slime-fuzzy-prev) + (def `([remap next-line] + "n" + "\M-n" + ,(kbd "")) + 'slime-fuzzy-next) + (def "\d" 'scroll-down) + (def `([remap slime-fuzzy-indent-and-complete-symbol] + [remap slime-indent-and-complete-symbol] + ,(kbd "")) + 'slime-fuzzy-select) + (def (kbd "") 'slime-fuzzy-select/mouse) + (def `(,(kbd "RET") + ,(kbd "")) + '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 on a completion to select it. + + +Complete listing of keybindings within the target buffer: + +\\\ +\\{slime-target-buffer-fuzzy-completions-map} + +Complete listing of keybindings with *Fuzzy Completions*: + +\\\ +\\{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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-highlight-edits.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-highlight-edits.el new file mode 100644 index 0000000..2a3f0a8 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-highlight-edits.el @@ -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 ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-hyperdoc.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-hyperdoc.el new file mode 100644 index 0000000..64de7ee --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-hyperdoc.el @@ -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 ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-indentation.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-indentation.el new file mode 100644 index 0000000..8e323e0 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-indentation.el @@ -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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-listener-hooks.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-listener-hooks.el new file mode 100644 index 0000000..ec573da --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-listener-hooks.el @@ -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 , R. Mattes ") + (:license "GPL") + (:slime-dependencies slime-repl) + (:swank-dependencies swank-listener-hooks)) + +(provide 'slime-listener-hooks) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-macrostep.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-macrostep.el new file mode 100644 index 0000000..a9dff73 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-macrostep.el @@ -0,0 +1,129 @@ +;;; slime-macrostep.el -- fancy macro-expansion via macrostep.el + +;; Authors: Luís Oliveira +;; Jon Oddie " + "Jon Oddie ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-mdot-fu.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-mdot-fu.el new file mode 100644 index 0000000..ed2e96a --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-mdot-fu.el @@ -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 ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-media.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-media.el new file mode 100644 index 0000000..cb839eb --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-media.el @@ -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 ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-mrepl.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-mrepl.el new file mode 100644 index 0000000..d9ebc38 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-mrepl.el @@ -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 ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-package-fu.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-package-fu.el new file mode 100644 index 0000000..00a1449 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-package-fu.el @@ -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 ") + (: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: diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-parse.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-parse.el new file mode 100644 index 0000000..ed81eb3 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-parse.el @@ -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 " + "Tobias C. Rittweiler ") + (: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 + | ( ) ;matches if the first element in + ; the current list is and + ; if matches. + | (()) ;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 )" and a symbol "(look-at )") + (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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-presentation-streams.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-presentation-streams.el new file mode 100644 index 0000000..786c549 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-presentation-streams.el @@ -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 " + "Matthias Koeppe " + "Helmut Eller ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-presentations.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-presentations.el new file mode 100644 index 0000000..229bf8a --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-presentations.el @@ -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 " + "Matthias Koeppe ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-quicklisp.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-quicklisp.el new file mode 100644 index 0000000..97f5ece --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-quicklisp.el @@ -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 ") + (: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) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-references.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-references.el new file mode 100644 index 0000000..93389ae --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-references.el @@ -0,0 +1,156 @@ +(require 'slime) +(require 'advice) +(require 'slime-compiler-notes-tree) ; FIXME: actually only uses the tree bits, so that should be a library. + +(define-slime-contrib slime-references + "Clickable references to documentation (SBCL only)." + (:authors "Christophe Rhodes " + "Luke Gorrie " + "Tobias C. Rittweiler ") + (:license "GPL") + (:on-load + (ad-enable-advice 'slime-note.message 'after 'slime-note.message+references) + (ad-activate 'slime-note.message) + (setq slime-tree-printer 'slime-tree-print-with-references) + (add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)) + (:on-unload + (ad-disable-advice 'slime-note.message 'after 'slime-note.message+references) + (ad-deactivate 'slime-note.message) + (setq slime-tree-printer 'slime-tree-default-printer) + (remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))) + +(defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/" + "*The base URL of the SBCL manual, for documentation lookup." + :type '(choice (string :tag "HTML Documentation") + (const :tag "Info Documentation" :info)) + :group 'slime-mode) + +(defface sldb-reference-face + (list (list t '(:underline t))) + "Face for references." + :group 'slime-debugger) + + +;;;;; SBCL-style references + +(defvar slime-references-local-keymap + (let ((map (make-sparse-keymap "local keymap for slime references"))) + (define-key map [mouse-2] 'slime-lookup-reference-at-mouse) + (define-key map [return] 'slime-lookup-reference-at-point) + map)) + +(defun slime-reference-properties (reference) + "Return the properties for a reference. +Only add clickability to properties we actually know how to lookup." + (cl-destructuring-bind (where type what) reference + (if (or (and (eq where :sbcl) (eq type :node)) + (and (eq where :ansi-cl) + (memq type '(:function :special-operator :macro + :type :system-class + :section :glossary :issue)))) + `(slime-reference ,reference + font-lock-face sldb-reference-face + follow-link t + mouse-face highlight + help-echo "mouse-2: visit documentation." + keymap ,slime-references-local-keymap)))) + +(defun slime-insert-reference (reference) + "Insert documentation reference from a condition. +See SWANK-BACKEND:CONDITION-REFERENCES for the datatype." + (cl-destructuring-bind (where type what) reference + (insert "\n" (slime-format-reference-source where) ", ") + (slime-insert-propertized (slime-reference-properties reference) + (slime-format-reference-node what)) + (insert (format " [%s]" type)))) + +(defun slime-insert-references (references) + (when references + (insert "\nSee also:") + (slime-with-rigid-indentation 2 + (mapc #'slime-insert-reference references)))) + +(defun slime-format-reference-source (where) + (cl-case where + (:amop "The Art of the Metaobject Protocol") + (:ansi-cl "Common Lisp Hyperspec") + (:sbcl "SBCL Manual") + (t (format "%S" where)))) + +(defun slime-format-reference-node (what) + (if (listp what) + (mapconcat #'prin1-to-string what ".") + what)) + +(defun slime-lookup-reference-at-point () + "Browse the documentation reference at point." + (interactive) + (let ((refs (get-text-property (point) 'slime-reference))) + (if (null refs) + (error "No references at point") + (cl-destructuring-bind (where type what) refs + (cl-case where + (:ansi-cl + (cl-case type + (:section + (browse-url (funcall common-lisp-hyperspec-section-fun what))) + (:glossary + (browse-url (funcall common-lisp-hyperspec-glossary-function what))) + (:issue + (browse-url (common-lisp-issuex what))) + (:special-operator + (browse-url (common-lisp-special-operator (downcase name)))) + (t + (hyperspec-lookup what)))) + (t + (case slime-sbcl-manual-root + (:info + (info (format "(sbcl)%s" what))) + (t + (browse-url + (format "%s#%s" slime-sbcl-manual-root + (subst-char-in-string ?\ ?\- what))))))))))) + +(defun slime-lookup-reference-at-mouse (event) + "Invoke the action pointed at by the mouse." + (interactive "e") + (cl-destructuring-bind (mouse-1 (w pos . _) . _) event + (save-excursion + (goto-char pos) + (slime-lookup-reference-at-point)))) + +;;;;; Hook into *SLIME COMPILATION* + +(defun slime-note.references (note) + (plist-get note :references)) + +;;; FIXME: `compilation-mode' will swallow the `mouse-face' +;;; etc. properties. +(defadvice slime-note.message (after slime-note.message+references) + (setq ad-return-value + (concat ad-return-value + (with-temp-buffer + (slime-insert-references + (slime-note.references (ad-get-arg 0))) + (buffer-string))))) + +;;;;; Hook into slime-compiler-notes-tree + +(defun slime-tree-print-with-references (tree) + ;; for SBCL-style references + (slime-tree-default-printer tree) + (let ((note (plist-get (slime-tree.plist tree) 'note))) + (when note + (let ((references (slime-note.references note))) + (when references + (terpri (current-buffer)) + (slime-insert-references references)))))) + +;;;;; Hook into SLDB + +(defun sldb-maybe-insert-references (extra) + (slime-dcase extra + ((:references references) (slime-insert-references references) t) + (t nil))) + +(provide 'slime-references) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-repl.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-repl.el new file mode 100644 index 0000000..91e7b61 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-repl.el @@ -0,0 +1,1770 @@ +;;; slime-repl.el --- +;; +;; Original Author: Helmut Eller +;; Contributors: too many to mention +;; License: GNU GPL (same license as Emacs) +;; +;;; Description: +;; + +;; +;;; Installation: +;; +;; Call slime-setup and include 'slime-repl as argument: +;; +;; (slime-setup '(slime-repl [others conribs ...])) +;; +(require 'slime) +(require 'slime-parse) +(require 'cl-lib) +(eval-when-compile (require 'cl)) ; slime-def-connection-var, which + ; expands to defsetf not in cl-lib + +(define-slime-contrib slime-repl + "Read-Eval-Print Loop written in Emacs Lisp. + +This contrib implements a Lisp Listener along with some niceties like +a persistent history and various \"shortcut\" commands. Nothing here +depends on comint.el; I/O is multiplexed over SLIME's socket. + +This used to be the default REPL for SLIME, but it was hard to +maintain." + (:authors "too many to mention") + (:license "GPL") + (:on-load + (slime-repl-add-hooks) + (setq slime-find-buffer-package-function 'slime-repl-find-buffer-package)) + (:on-unload (slime-repl-remove-hooks)) + (:swank-dependencies swank-repl)) + +;;;;; slime-repl + +(defgroup slime-repl nil + "The Read-Eval-Print Loop (*slime-repl* buffer)." + :prefix "slime-repl-" + :group 'slime) + +(defcustom slime-repl-shortcut-dispatch-char ?\, + "Character used to distinguish repl commands from lisp forms." + :type '(character) + :group 'slime-repl) + +(defcustom slime-repl-only-save-lisp-buffers t + "When T we only attempt to save lisp-mode file buffers. When + NIL slime will attempt to save all buffers (as per + save-some-buffers). This applies to all ASDF related repl + shortcuts." + :type '(boolean) + :group 'slime-repl) + +(defcustom slime-repl-auto-right-margin nil + "When T we bind CL:*PRINT-RIGHT-MARGIN* to the width of the +current repl's (as per slime-output-buffer) window." + :type '(boolean) + :group 'slime-repl) + +(defface slime-repl-prompt-face + '((t (:inherit font-lock-keyword-face))) + "Face for the prompt in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-output-face + '((t (:inherit font-lock-string-face))) + "Face for Lisp output in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-input-face + '((t (:bold t))) + "Face for previous input in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-result-face + '((t ())) + "Face for the result of an evaluation in the SLIME REPL." + :group 'slime-repl) + +(defcustom slime-repl-history-file "~/.slime-history.eld" + "File to save the persistent REPL history to." + :type 'string + :group 'slime-repl) + +(defcustom slime-repl-history-size 200 + "*Maximum number of lines for persistent REPL history." + :type 'integer + :group 'slime-repl) + +(defcustom slime-repl-history-file-coding-system + (cond ((slime-find-coding-system 'utf-8-unix) 'utf-8-unix) + (t slime-net-coding-system)) + "*The coding system for the history file." + :type 'symbol + :group 'slime-repl) + + +;; dummy defvar for compiler +(defvar slime-repl-read-mode) + +(defun slime-reading-p () + "True if Lisp is currently reading input from the REPL." + (with-current-buffer (slime-output-buffer) + slime-repl-read-mode)) + + +;;;; Stream output + +(slime-def-connection-var slime-connection-output-buffer nil + "The buffer for the REPL. May be nil or a dead buffer.") + +(make-variable-buffer-local + (defvar slime-output-start nil + "Marker for the start of the output for the evaluation.")) + +(make-variable-buffer-local + (defvar slime-output-end nil + "Marker for end of output. New output is inserted at this mark.")) + +;; dummy definitions for the compiler +(defvar slime-repl-package-stack) +(defvar slime-repl-directory-stack) +(defvar slime-repl-input-start-mark) +(defvar slime-repl-prompt-start-mark) + +(defun slime-output-buffer (&optional noprompt) + "Return the output buffer, create it if necessary." + (let ((buffer (slime-connection-output-buffer))) + (or (if (buffer-live-p buffer) buffer) + (setf (slime-connection-output-buffer) + (let ((connection (slime-connection))) + (with-current-buffer (slime-repl-buffer t connection) + (unless (eq major-mode 'slime-repl-mode) + (slime-repl-mode)) + (setq slime-buffer-connection connection) + (setq slime-buffer-package (slime-lisp-package connection)) + (slime-reset-repl-markers) + (unless noprompt + (slime-repl-insert-prompt)) + (current-buffer))))))) + +(defvar slime-repl-banner-function 'slime-repl-insert-banner) + +(defun slime-repl-update-banner () + (funcall slime-repl-banner-function) + (slime-move-point (point-max)) + (slime-mark-output-start) + (slime-mark-input-start) + (slime-repl-insert-prompt)) + +(defun slime-repl-insert-banner () + (when (zerop (buffer-size)) + (let ((welcome (concat "; SLIME " slime-version))) + (insert welcome)))) + +(defun slime-init-output-buffer (connection) + (with-current-buffer (slime-output-buffer t) + (setq slime-buffer-connection connection + slime-repl-directory-stack '() + slime-repl-package-stack '()) + (slime-repl-update-banner))) + +(defun slime-display-output-buffer () + "Display the output buffer and scroll to bottom." + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (unless (get-buffer-window (current-buffer) t) + (display-buffer (current-buffer) t)) + (slime-repl-show-maximum-output))) + +(defun slime-output-filter (process string) + (with-current-buffer (process-buffer process) + (when (and (plusp (length string)) + (eq (process-status slime-buffer-connection) 'open)) + (slime-write-string string)))) + +(defvar slime-open-stream-hooks) + +(defun slime-open-stream-to-lisp (port coding-system) + (let ((stream (open-network-stream "*lisp-output-stream*" + (slime-with-connection-buffer () + (current-buffer)) + (car (process-contact (slime-connection))) + port)) + (emacs-coding-system (car (cl-find coding-system + slime-net-valid-coding-systems + :key #'cl-third)))) + (slime-set-query-on-exit-flag stream) + (set-process-filter stream 'slime-output-filter) + (set-process-coding-system stream emacs-coding-system emacs-coding-system) + (let ((secret (slime-secret))) + (when secret + (slime-net-send secret stream))) + (run-hook-with-args 'slime-open-stream-hooks stream) + stream)) + +(defun slime-io-speed-test (&optional profile) + "A simple minded benchmark for stream performance. +If a prefix argument is given, instrument the slime package for +profiling before running the benchmark." + (interactive "P") + (eval-and-compile + (require 'elp)) + (elp-reset-all) + (elp-restore-all) + (load "slime.el") + ;;(byte-compile-file "slime-net.el" t) + ;;(setq slime-log-events nil) + (setq slime-enable-evaluate-in-emacs t) + ;;(setq slime-repl-enable-presentations nil) + (when profile + (elp-instrument-package "slime-")) + (kill-buffer (slime-output-buffer)) + (switch-to-buffer (slime-output-buffer)) + (delete-other-windows) + (sit-for 0) + (slime-repl-send-string "(swank:io-speed-test 4000 1)") + (let ((proc (slime-inferior-process))) + (when proc + (display-buffer (process-buffer proc) t) + (goto-char (point-max))))) + +(defvar slime-write-string-function 'slime-repl-write-string) + +(defun slime-write-string (string &optional target) + "Insert STRING in the REPL buffer or some other TARGET. +If TARGET is nil, insert STRING as regular process +output. If TARGET is :repl-result, insert STRING as the result of the +evaluation. Other values of TARGET map to an Emacs marker via the +hashtable `slime-output-target-to-marker'; output is inserted at this marker." + (funcall slime-write-string-function string target)) + +(defun slime-repl-write-string (string &optional target) + (case target + ((nil) (slime-repl-emit string)) + (:repl-result (slime-repl-emit-result string t)) + (t (slime-repl-emit-to-target string target)))) + +(defvar slime-repl-popup-on-output nil + "Display the output buffer when some output is written. +This is set to nil after displaying the buffer.") + +(defmacro slime-save-marker (marker &rest body) + (declare (debug (sexp &rest form))) + (let ((pos (cl-gensym "pos"))) + `(let ((,pos (marker-position ,marker))) + (prog1 (progn . ,body) + (set-marker ,marker ,pos))))) + +(put 'slime-save-marker 'lisp-indent-function 1) + +(defun slime-repl-emit (string) + ;; insert the string STRING in the output buffer + (with-current-buffer (slime-output-buffer) + (save-excursion + (goto-char slime-output-end) + (slime-save-marker slime-output-start + (slime-propertize-region '(face slime-repl-output-face + slime-repl-output t + rear-nonsticky (face)) + (let ((inhibit-read-only t)) + (insert-before-markers string) + (when (and (= (point) slime-repl-prompt-start-mark) + (not (bolp))) + (insert-before-markers "\n") + (set-marker slime-output-end (1- (point)))))))) + (when slime-repl-popup-on-output + (setq slime-repl-popup-on-output nil) + (display-buffer (current-buffer))) + (slime-repl-show-maximum-output))) + +(defun slime-repl-emit-result (string &optional bol) + ;; insert STRING and mark it as evaluation result + (with-current-buffer (slime-output-buffer) + (save-excursion + (goto-char slime-repl-input-start-mark) + (slime-save-marker slime-output-start + (goto-char slime-repl-input-start-mark) + (when (and bol (not (bolp))) (insert-before-markers-and-inherit "\n")) + (slime-save-marker slime-output-end + (slime-propertize-region `(face slime-repl-result-face + rear-nonsticky (face)) + (insert-before-markers string))) + (set-marker slime-output-end (point)))) + (slime-repl-show-maximum-output))) + +(defvar slime-last-output-target-id 0 + "The last integer we used as a TARGET id.") + +(defun slime-repl-emit-to-target (string target) + "Insert STRING at target TARGET. +See `slime-output-target-to-marker'." + (let* ((marker (slime-repl-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (when buffer + (with-current-buffer buffer + (save-excursion + ;; Insert STRING at MARKER, then move MARKER behind + ;; the insertion. + (goto-char marker) + (insert-before-markers string) + (set-marker marker (point))))))) + +(defun slime-repl-output-target-marker (target) + (case target + ((nil) + (with-current-buffer (slime-output-buffer) + slime-output-end)) + (:repl-result + (with-current-buffer (slime-output-buffer) + slime-repl-input-start-mark)) + (t + (slime-output-target-marker target)))) + + +(defun slime-switch-to-output-buffer () + "Select the output buffer, when possible in an existing window. + +Hint: You can use `display-buffer-reuse-frames' and +`special-display-buffer-names' to customize the frame in which +the buffer should appear." + (interactive) + (pop-to-buffer (slime-output-buffer)) + (goto-char (point-max))) + + +;;;; REPL +;; +;; The REPL uses some markers to separate input from output. The +;; usual configuration is as follows: +;; +;; ... output ... ... result ... prompt> ... input ... +;; ^ ^ ^ ^ ^ +;; output-start output-end prompt-start input-start point-max +;; +;; input-start is a right inserting marker, because +;; we want it to stay behind when the user inserts text. +;; +;; We maintain the following invariant: +;; +;; output-start <= output-end <= input-start. +;; +;; This invariant is important, because we must be prepared for +;; asynchronous output and asynchronous reads. ("Asynchronous" means, +;; triggered by Lisp and not by Emacs.) +;; +;; All output is inserted at the output-end marker. Some care must be +;; taken when output-end and input-start are at the same position: if +;; we insert at that point, we must move the right markers. We should +;; also not leave (window-)point in the middle of the new output. The +;; idiom we use is a combination to slime-save-marker, +;; insert-before-markers, and manually updating window-point +;; afterwards. +;; +;; A "synchronous" evaluation request proceeds as follows: the user +;; inserts some text between input-start and point-max and then hits +;; return. We send that region to Lisp, move the output and input +;; makers to the line after the input and wait. When we receive the +;; result, we insert it together with a prompt between the output-end +;; and input-start mark. See `slime-repl-insert-prompt'. +;; +;; It is possible that some output for such an evaluation request +;; arrives after the result. This output is inserted before the +;; result (and before the prompt). +;; +;; If we are in "reading" state, e.g., during a call to Y-OR-N-P, +;; there is no prompt between output-end and input-start. +;; + +;; FIXME: slime-lisp-package should be local in a REPL buffer +(slime-def-connection-var slime-lisp-package + "COMMON-LISP-USER" + "The current package name of the Superior lisp. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-lisp-package-prompt-string + "CL-USER" + "The current package name of the Superior lisp. +This is automatically synchronized from Lisp.") + +(slime-make-variables-buffer-local + (defvar slime-repl-package-stack nil + "The stack of packages visited in this repl.") + + (defvar slime-repl-directory-stack nil + "The stack of default directories associated with this repl.") + + (defvar slime-repl-prompt-start-mark) + (defvar slime-repl-input-start-mark) + (defvar slime-repl-old-input-counter 0 + "Counter used to generate unique `slime-repl-old-input' properties. +This property value must be unique to avoid having adjacent inputs be +joined together.")) + +(defun slime-reset-repl-markers () + (dolist (markname '(slime-output-start + slime-output-end + slime-repl-prompt-start-mark + slime-repl-input-start-mark)) + (set markname (make-marker)) + (set-marker (symbol-value markname) (point)))) + +;;;;; REPL mode setup + +(defvar slime-repl-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-mode-map) + map)) + +(slime-define-keys slime-prefix-map + ("\C-z" 'slime-switch-to-output-buffer) + ("\M-p" 'slime-repl-set-package)) + +(slime-define-keys slime-mode-map + ("\C-c~" 'slime-sync-package-and-default-directory) + ("\C-c\C-y" 'slime-call-defun) + ("\C-c\C-j" 'slime-eval-last-expression-in-repl)) + +(slime-define-keys slime-connection-list-mode-map + ((kbd "RET") 'slime-goto-connection) + ([return] 'slime-goto-connection)) + +(slime-define-keys slime-repl-mode-map + ("\C-m" 'slime-repl-return) + ([return] 'slime-repl-return) + ("\C-j" 'slime-repl-newline-and-indent) + ("\C-\M-m" 'slime-repl-closing-return) + ([(control return)] 'slime-repl-closing-return) + ("\M-p" 'slime-repl-previous-input) + ((kbd "C-") 'slime-repl-backward-input) + ("\M-n" 'slime-repl-next-input) + ((kbd "C-") 'slime-repl-forward-input) + ("\M-r" 'slime-repl-previous-matching-input) + ("\M-s" 'slime-repl-next-matching-input) + ("\C-c\C-c" 'slime-interrupt) + (" " 'slime-space) + ((string slime-repl-shortcut-dispatch-char) 'slime-handle-repl-shortcut) + ("\C-c\C-o" 'slime-repl-clear-output) + ("\C-c\M-o" 'slime-repl-clear-buffer) + ("\C-c\C-u" 'slime-repl-kill-input) + ("\C-c\C-n" 'slime-repl-next-prompt) + ("\C-c\C-p" 'slime-repl-previous-prompt) + ("\C-c\C-z" 'slime-nop) + ("\C-cI" 'slime-repl-inspect) + ("\C-x\C-e" 'slime-eval-last-expression)) + +(slime-define-keys slime-inspector-mode-map + ((kbd "M-RET") 'slime-inspector-copy-down-to-repl)) + +(slime-define-keys sldb-mode-map + ("\C-y" 'sldb-insert-frame-call-to-repl) + ((kbd "M-RET") 'sldb-copy-down-to-repl)) + +(def-slime-selector-method ?r + "SLIME Read-Eval-Print-Loop." + (slime-output-buffer)) + +(define-minor-mode slime-repl-map-mode + "Minor mode which makes slime-repl-mode-map available. +\\{slime-repl-mode-map}" + nil + nil + slime-repl-mode-map) + +(defun slime-repl-mode () + "Major mode for interacting with a superior Lisp. +\\{slime-repl-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'slime-repl-mode) + (slime-editing-mode 1) + (slime-repl-map-mode 1) + (lisp-mode-variables t) + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function) + (slime-setup-completion) + (set (make-local-variable 'tab-always-indent) 'complete) + (setq font-lock-defaults nil) + (setq mode-name "REPL") + (setq slime-current-thread :repl-thread) + (set (make-local-variable 'scroll-conservatively) 20) + (set (make-local-variable 'scroll-margin) 0) + (when slime-repl-history-file + (slime-repl-safe-load-history) + (add-hook 'kill-buffer-hook + 'slime-repl-safe-save-merged-history + 'append t)) + (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories) + ;; At the REPL, we define beginning-of-defun and end-of-defun to be + ;; the start of the previous prompt or next prompt respectively. + ;; Notice the interplay with SLIME-REPL-BEGINNING-OF-DEFUN. + (set (make-local-variable 'beginning-of-defun-function) + 'slime-repl-mode-beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) + 'slime-repl-mode-end-of-defun) + (run-mode-hooks 'slime-repl-mode-hook)) + +(defun slime-repl-buffer (&optional create connection) + "Get the REPL buffer for the current connection; optionally create." + (funcall (if create #'get-buffer-create #'get-buffer) + (format "*slime-repl %s*" (slime-connection-name connection)))) + +(defun slime-repl () + (interactive) + (slime-switch-to-output-buffer) + (current-buffer)) + +(defun slime-repl-mode-beginning-of-defun (&optional arg) + (if (and arg (< arg 0)) + (slime-repl-mode-end-of-defun (- arg)) + (dotimes (i (or arg 1)) + (slime-repl-previous-prompt)))) + +(defun slime-repl-mode-end-of-defun (&optional arg) + (if (and arg (< arg 0)) + (slime-repl-mode-beginning-of-defun (- arg)) + (dotimes (i (or arg 1)) + (slime-repl-next-prompt)))) + +(defun slime-repl-send-string (string &optional command-string) + (cond (slime-repl-read-mode + (slime-repl-return-string string)) + (t (slime-repl-eval-string string)))) + +(defun slime-repl-eval-string (string) + (slime-rex () + ((if slime-repl-auto-right-margin + `(swank-repl:listener-eval + ,string + :window-width + ,(with-current-buffer (slime-output-buffer) + (window-width))) + `(swank-repl:listener-eval ,string)) + (slime-lisp-package)) + ((:ok result) + (slime-repl-insert-result result)) + ((:abort condition) + (slime-repl-show-abort condition)))) + +(defun slime-repl-insert-result (result) + (with-current-buffer (slime-output-buffer) + (save-excursion + (when result + (slime-dcase result + ((:values &rest strings) + (cond ((null strings) + (slime-repl-emit-result "; No value\n" t)) + (t + (dolist (s strings) + (slime-repl-emit-result s t))))))) + (slime-repl-insert-prompt)) + (slime-repl-show-maximum-output))) + +(defun slime-repl-show-abort (condition) + (with-current-buffer (slime-output-buffer) + (save-excursion + (slime-save-marker slime-output-start + (slime-save-marker slime-output-end + (goto-char slime-output-end) + (insert-before-markers (format "; Evaluation aborted on %s.\n" + condition)) + (slime-repl-insert-prompt)))) + (slime-repl-show-maximum-output))) + +(defvar slime-repl-suppress-prompt nil + "Supresses Slime REPL prompt when bound to T.") + +(defun slime-repl-insert-prompt () + "Insert the prompt (before markers!). +Set point after the prompt. +Return the position of the prompt beginning. + +If `slime-repl-suppress-prompt' is true, does nothing and returns nil." + (goto-char slime-repl-input-start-mark) + (unless slime-repl-suppress-prompt + (slime-save-marker slime-output-start + (slime-save-marker slime-output-end + (unless (bolp) (insert-before-markers "\n")) + (let ((prompt-start (point)) + (prompt (format "%s> " (slime-lisp-package-prompt-string)))) + (slime-propertize-region + '(face slime-repl-prompt-face + read-only t slime-repl-prompt t + rear-nonsticky t front-sticky (read-only) + inhibit-line-move-field-capture t + field output) + (insert-before-markers prompt)) + (set-marker slime-repl-prompt-start-mark prompt-start) + (setq buffer-undo-list nil) + prompt-start))))) + +(defun slime-repl-show-maximum-output () + "Put the end of the buffer at the bottom of the window." + (when (eobp) + (let ((win (if (eq (window-buffer) (current-buffer)) + (selected-window) + (get-buffer-window (current-buffer) t)))) + (when win + (with-selected-window win + (set-window-point win (point-max)) + (recenter -1)))))) + +(defvar slime-repl-current-input-hooks) + +(defun slime-repl-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." + (or (run-hook-with-args-until-success 'slime-repl-current-input-hooks + until-point-p) + (buffer-substring-no-properties slime-repl-input-start-mark + (if until-point-p + (point) + (point-max))))) + +(defun slime-property-position (text-property &optional object) + "Return the first position of TEXT-PROPERTY, or nil." + (if (get-text-property 0 text-property object) + 0 + (next-single-property-change 0 text-property object))) + +(defun slime-mark-input-start () + (set-marker slime-repl-input-start-mark (point) (current-buffer))) + +(defun slime-mark-output-start () + (set-marker slime-output-start (point)) + (set-marker slime-output-end (point))) + +(defun slime-mark-output-end () + ;; Don't put slime-repl-output-face again; it would remove the + ;; special presentation face, for instance in the SBCL inspector. + (add-text-properties slime-output-start slime-output-end + '(;;face slime-repl-output-face + rear-nonsticky (face)))) + +(defun slime-preserve-zmacs-region () + "In XEmacs, ensure that the zmacs-region stays active after this command." + (when (boundp 'zmacs-region-stays) + (set 'zmacs-region-stays t))) + +(defun slime-repl-in-input-area-p () + (<= slime-repl-input-start-mark (point))) + +(defun slime-repl-at-prompt-start-p () + ;; This will not work on non-current prompts. + (= (point) slime-repl-input-start-mark)) + +(defun slime-repl-beginning-of-defun () + "Move to beginning of defun." + (interactive) + ;; We call BEGINNING-OF-DEFUN if we're at the start of a prompt + ;; already, to trigger SLIME-REPL-MODE-BEGINNING-OF-DEFUN by means + ;; of the locally bound BEGINNING-OF-DEFUN-FUNCTION, in order to + ;; jump to the start of the previous prompt. + (if (and (not (slime-repl-at-prompt-start-p)) + (slime-repl-in-input-area-p)) + (goto-char slime-repl-input-start-mark) + (beginning-of-defun)) + t) + +;; FIXME: this looks very strange +(defun slime-repl-end-of-defun () + "Move to next of defun." + (interactive) + ;; C.f. SLIME-REPL-BEGINNING-OF-DEFUN. + (if (and (not (= (point) (point-max))) + (slime-repl-in-input-area-p)) + (goto-char (point-max)) + (end-of-defun)) + t) + +(defun slime-repl-previous-prompt () + "Move backward to the previous prompt." + (interactive) + (slime-repl-find-prompt t)) + +(defun slime-repl-next-prompt () + "Move forward to the next prompt." + (interactive) + (slime-repl-find-prompt)) + +(defun slime-repl-find-prompt (&optional backward) + (let ((origin (point)) + (prop 'slime-repl-prompt)) + (while (progn + (slime-search-property-change prop backward) + (not (or (slime-end-of-proprange-p prop) (bobp) (eobp))))) + (unless (slime-end-of-proprange-p prop) + (goto-char origin)))) + +(defun slime-search-property-change (prop &optional backward) + (cond (backward + (goto-char (or (previous-single-char-property-change (point) prop) + (point-min)))) + (t + (goto-char (or (next-single-char-property-change (point) prop) + (point-max)))))) + +(defun slime-end-of-proprange-p (property) + (and (get-char-property (max 1 (1- (point))) property) + (not (get-char-property (point) property)))) + +(defvar slime-repl-return-hooks) + +(defun slime-repl-return (&optional end-of-input) + "Evaluate the current input string, or insert a newline. +Send the current input only if a whole expression has been entered, +i.e. the parenthesis are matched. + +With prefix argument send the input even if the parenthesis are not +balanced." + (interactive "P") + (slime-check-connected) + (cond (end-of-input + (slime-repl-send-input)) + (slime-repl-read-mode ; bad style? + (slime-repl-send-input t)) + ((and (get-text-property (point) 'slime-repl-old-input) + (< (point) slime-repl-input-start-mark)) + (slime-repl-grab-old-input end-of-input) + (slime-repl-recenter-if-needed)) + ((run-hook-with-args-until-success 'slime-repl-return-hooks end-of-input)) + ((slime-input-complete-p slime-repl-input-start-mark (point-max)) + (slime-repl-send-input t)) + (t + (slime-repl-newline-and-indent) + (message "[input not complete]")))) + +(defun slime-repl-recenter-if-needed () + "Make sure that (point) is visible." + (unless (pos-visible-in-window-p (point-max)) + (save-excursion + (goto-char (point-max)) + (recenter -1)))) + +(defun slime-repl-send-input (&optional newline) + "Goto to the end of the input and send the current input. +If NEWLINE is true then add a newline at the end of the input." + (unless (slime-repl-in-input-area-p) + (error "No input at point.")) + (goto-char (point-max)) + (let ((end (point))) ; end of input, without the newline + (slime-repl-add-to-input-history + (buffer-substring slime-repl-input-start-mark end)) + (when newline + (insert "\n") + (slime-repl-show-maximum-output)) + (let ((inhibit-modification-hooks t)) + (add-text-properties slime-repl-input-start-mark + (point) + `(slime-repl-old-input + ,(incf slime-repl-old-input-counter)))) + (let ((overlay (make-overlay slime-repl-input-start-mark end))) + ;; These properties are on an overlay so that they won't be taken + ;; by kill/yank. + (overlay-put overlay 'face 'slime-repl-input-face))) + (let ((input (slime-repl-current-input))) + (goto-char (point-max)) + (slime-mark-input-start) + (slime-mark-output-start) + (slime-repl-send-string input))) + +(defun slime-repl-grab-old-input (replace) + "Resend the old REPL input at point. +If replace is non-nil the current input is replaced with the old +input; otherwise the new input is appended. The old input has the +text property `slime-repl-old-input'." + (multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-input) + (let ((old-input (buffer-substring beg end)) ;;preserve + ;;properties, they will be removed later + (offset (- (point) beg))) + ;; 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)) + (save-excursion + (insert old-input) + (when (equal (char-before) ?\n) + (delete-char -1))) + (forward-char offset)))) + +(defun slime-repl-closing-return () + "Evaluate the current input string after closing all open lists." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region slime-repl-input-start-mark (point)) + (while (ignore-errors (save-excursion (backward-up-list 1)) t) + (insert ")"))) + (slime-repl-return)) + +(defun slime-repl-newline-and-indent () + "Insert a newline, then indent the next line. +Restrict the buffer from the prompt for indentation, to avoid being +confused by strange characters (like unmatched quotes) appearing +earlier in the buffer." + (interactive) + (save-restriction + (narrow-to-region slime-repl-prompt-start-mark (point-max)) + (insert "\n") + (lisp-indent-line))) + +(defun slime-repl-delete-current-input () + "Delete all text from the prompt." + (interactive) + (delete-region slime-repl-input-start-mark (point-max))) + +(defun slime-eval-last-expression-in-repl (prefix) + "Evaluates last expression in the Slime REPL. + +Switches REPL to current package of the source buffer for the duration. If +used with a prefix argument (C-u), doesn't switch back afterwards." + (interactive "P") + (let ((expr (slime-last-expression)) + (buffer-name (buffer-name (current-buffer))) + (new-package (slime-current-package)) + (old-package (slime-lisp-package)) + (slime-repl-suppress-prompt t) + (yank-back nil)) + (with-current-buffer (slime-output-buffer) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t)) + (goto-char (point-max)) + ;; Kill pending input in the REPL + (when (< (marker-position slime-repl-input-start-mark) (point)) + (kill-region slime-repl-input-start-mark (point)) + (setq yank-back t)) + (unwind-protect + (progn + (insert-before-markers (format "\n;;; from %s\n" buffer-name)) + (when new-package + (slime-repl-set-package new-package)) + (let ((slime-repl-suppress-prompt nil)) + (slime-repl-insert-prompt)) + (insert expr) + (slime-repl-return)) + (unless (or prefix (equal (slime-lisp-package) old-package)) + ;; Switch back. + (slime-repl-set-package old-package) + (let ((slime-repl-suppress-prompt nil)) + (slime-repl-insert-prompt)))) + ;; Put pending input back. + (when yank-back + (yank))))) + +(defun slime-repl-kill-input () + "Kill all text from the prompt to point." + (interactive) + (cond ((< (marker-position slime-repl-input-start-mark) (point)) + (kill-region slime-repl-input-start-mark (point))) + ((= (point) (marker-position slime-repl-input-start-mark)) + (slime-repl-delete-current-input)))) + +(defun slime-repl-replace-input (string) + (slime-repl-delete-current-input) + (insert-and-inherit string)) + +(defun slime-repl-input-line-beginning-position () + (save-excursion + (goto-char slime-repl-input-start-mark) + (let ((inhibit-field-text-motion t)) + (line-beginning-position)))) + +(defun slime-clear-repl-variables () + (interactive) + (slime-eval-async `(swank-repl:clear-repl-variables))) + +(defvar slime-repl-clear-buffer-hook) + +(add-hook 'slime-repl-clear-buffer-hook 'slime-clear-repl-variables) + +(defun slime-repl-clear-buffer () + "Delete the output generated by the Lisp process." + (interactive) + (let ((inhibit-read-only t)) + (delete-region (point-min) slime-repl-prompt-start-mark) + (delete-region slime-output-start slime-output-end) + (when (< (point) slime-repl-input-start-mark) + (goto-char slime-repl-input-start-mark)) + (recenter t)) + (run-hooks 'slime-repl-clear-buffer-hook)) + +(defun slime-repl-clear-output () + "Delete the output inserted since the last input." + (interactive) + (let ((start (save-excursion + (when (>= (point) slime-repl-input-start-mark) + (goto-char slime-repl-input-start-mark)) + (slime-repl-previous-prompt) + (ignore-errors (forward-sexp)) + (forward-line) + (point))) + (end (1- (slime-repl-input-line-beginning-position)))) + (when (< start end) + (let ((inhibit-read-only t)) + (delete-region start end) + (save-excursion + (goto-char start) + (insert ";;; output flushed")))))) + +(defun slime-repl-set-package (package) + "Set the package of the REPL buffer to PACKAGE." + (interactive (list (let* ((p (slime-current-package)) + (p (and p (slime-pretty-package-name p))) + (p (and (not (equal p (slime-lisp-package))) p))) + (slime-read-package-name "Package: " p)))) + (with-current-buffer (slime-output-buffer) + (let ((previouse-point (- (point) slime-repl-input-start-mark)) + (previous-prompt (slime-lisp-package-prompt-string))) + (destructuring-bind (name prompt-string) + (slime-repl-shortcut-eval `(swank:set-package ,package)) + (setf (slime-lisp-package) name) + (setf slime-buffer-package name) + (unless (equal previous-prompt prompt-string) + (setf (slime-lisp-package-prompt-string) prompt-string) + (slime-repl-insert-prompt)) + (when (plusp previouse-point) + (goto-char (+ previouse-point slime-repl-input-start-mark))))))) + + +;;;;; History + +(defcustom slime-repl-wrap-history nil + "*T to wrap history around when the end is reached." + :type 'boolean + :group 'slime-repl) + +(make-variable-buffer-local + (defvar slime-repl-input-history '() + "History list of strings read from the REPL buffer.")) + +(defun slime-repl-add-to-input-history (string) + "Add STRING to the input history. +Empty strings and duplicates are ignored." + (setq string (slime-trim-whitespace string)) + (unless (equal string "") + (setq slime-repl-input-history + (remove string slime-repl-input-history)) + (unless (equal string (car slime-repl-input-history)) + (push string slime-repl-input-history)))) + +;; These two vars contain the state of the last history search. We +;; only use them if `last-command' was 'slime-repl-history-replace, +;; otherwise we reinitialize them. + +(defvar slime-repl-input-history-position -1 + "Newer items have smaller indices.") + +(defvar slime-repl-history-pattern nil + "The regexp most recently used for finding input history.") + +(defun slime-repl-history-replace (direction &optional regexp) + "Replace the current input with the next line in DIRECTION. +DIRECTION is 'forward' or 'backward' (in the history list). +If REGEXP is non-nil, only lines matching REGEXP are considered." + (setq slime-repl-history-pattern regexp) + (let* ((min-pos -1) + (max-pos (length slime-repl-input-history)) + (pos0 (cond ((slime-repl-history-search-in-progress-p) + slime-repl-input-history-position) + (t min-pos))) + (pos (slime-repl-position-in-history pos0 direction (or regexp "") + (slime-repl-current-input))) + (msg nil)) + (cond ((and (< min-pos pos) (< pos max-pos)) + (slime-repl-replace-input (nth pos slime-repl-input-history)) + (setq msg (format "History item: %d" pos))) + ((not slime-repl-wrap-history) + (setq msg (cond ((= pos min-pos) "End of history") + ((= pos max-pos) "Beginning of history")))) + (slime-repl-wrap-history + (setq pos (if (= pos min-pos) max-pos min-pos)) + (setq msg "Wrapped history"))) + (when (or (<= pos min-pos) (<= max-pos pos)) + (when regexp + (setq msg (concat msg "; no matching item")))) + ;;(message "%s [%d %d %s]" msg start-pos pos regexp) + (message "%s%s" msg (cond ((not regexp) "") + (t (format "; current regexp: %s" regexp)))) + (setq slime-repl-input-history-position pos) + (setq this-command 'slime-repl-history-replace))) + +(defun slime-repl-history-search-in-progress-p () + (eq last-command 'slime-repl-history-replace)) + +(defun slime-repl-terminate-history-search () + (setq last-command this-command)) + +(defun slime-repl-position-in-history (start-pos direction regexp + &optional exclude-string) + "Return the position of the history item matching REGEXP. +Return -1 resp. the length of the history if no item matches. +If EXCLUDE-STRING is specified then it's excluded from the search." + ;; Loop through the history list looking for a matching line + (let* ((step (ecase direction + (forward -1) + (backward 1))) + (history slime-repl-input-history) + (len (length history))) + (loop for pos = (+ start-pos step) then (+ pos step) + if (< pos 0) return -1 + if (<= len pos) return len + for history-item = (nth pos history) + if (and (string-match regexp history-item) + (not (equal history-item exclude-string))) + return pos))) + +(defun slime-repl-previous-input () + "Cycle backwards through input history. +If the `last-command' was a history navigation command use the +same search pattern for this command. +Otherwise use the current input as search pattern." + (interactive) + (slime-repl-history-replace 'backward (slime-repl-history-pattern t))) + +(defun slime-repl-next-input () + "Cycle forwards through input history. +See `slime-repl-previous-input'." + (interactive) + (slime-repl-history-replace 'forward (slime-repl-history-pattern t))) + +(defun slime-repl-forward-input () + "Cycle forwards through input history." + (interactive) + (slime-repl-history-replace 'forward (slime-repl-history-pattern))) + +(defun slime-repl-backward-input () + "Cycle backwards through input history." + (interactive) + (slime-repl-history-replace 'backward (slime-repl-history-pattern))) + +(defun slime-repl-previous-matching-input (regexp) + (interactive (list (slime-read-from-minibuffer + "Previous element matching (regexp): "))) + (slime-repl-terminate-history-search) + (slime-repl-history-replace 'backward regexp)) + +(defun slime-repl-next-matching-input (regexp) + (interactive (list (slime-read-from-minibuffer + "Next element matching (regexp): "))) + (slime-repl-terminate-history-search) + (slime-repl-history-replace 'forward regexp)) + +(defun slime-repl-history-pattern (&optional use-current-input) + "Return the regexp for the navigation commands." + (cond ((slime-repl-history-search-in-progress-p) + slime-repl-history-pattern) + (use-current-input + (goto-char (max slime-repl-input-start-mark (point))) + (let ((str (slime-repl-current-input t))) + (cond ((string-match "^[ \t\n]*$" str) nil) + (t (concat "^" (regexp-quote str)))))) + (t nil))) + +(defun slime-repl-delete-from-input-history (string) + "Delete STRING from the repl input history. + +When string is not provided then clear the current repl input and +use it as an input. This is useful to get rid of unwanted repl +history entries while navigating the repl history." + (interactive (list (slime-repl-current-input))) + (let ((merged-history + (slime-repl-merge-histories (slime-repl-read-history nil t) + slime-repl-input-history))) + (setq slime-repl-input-history + (cl-delete string merged-history :test #'string=)) + (slime-repl-save-history)) + (slime-repl-delete-current-input)) + +;;;;; Persistent History + +(defun slime-repl-merge-histories (old-hist new-hist) + "Merge entries from OLD-HIST and NEW-HIST." + ;; Newer items in each list are at the beginning. + (let* ((ht (make-hash-table :test #'equal)) + (test (lambda (entry) + (or (gethash entry ht) + (progn (setf (gethash entry ht) t) + nil))))) + (append (cl-remove-if test new-hist) + (cl-remove-if test old-hist)))) + +(defun slime-repl-load-history (&optional filename) + "Set the current SLIME REPL history. +It can be read either from FILENAME or `slime-repl-history-file' or +from a user defined filename." + (interactive (list (slime-repl-read-history-filename))) + (let ((file (or filename slime-repl-history-file))) + (setq slime-repl-input-history (slime-repl-read-history file t)))) + +(defun slime-repl-read-history (&optional filename noerrer) + "Read and return the history from FILENAME. +The default value for FILENAME is `slime-repl-history-file'. +If NOERROR is true return and the file doesn't exits return nil." + (let ((file (or filename slime-repl-history-file))) + (cond ((not (file-readable-p file)) '()) + (t (with-temp-buffer + (insert-file-contents file) + (read (current-buffer))))))) + +(defun slime-repl-read-history-filename () + (read-file-name "Use SLIME REPL history from file: " + slime-repl-history-file)) + +(defun slime-repl-save-merged-history (&optional filename) + "Read the history file, merge the current REPL history and save it. +This tries to be smart in merging the history from the file and the +current history in that it tries to detect the unique entries using +`slime-repl-merge-histories'." + (interactive (list (slime-repl-read-history-filename))) + (let ((file (or filename slime-repl-history-file))) + (with-temp-message "saving history..." + (let ((hist (slime-repl-merge-histories (slime-repl-read-history file t) + slime-repl-input-history))) + (slime-repl-save-history file hist))))) + +(defun slime-repl-save-history (&optional filename history) + "Simply save the current SLIME REPL history to a file. +When SLIME is setup to always load the old history and one uses only +one instance of slime all the time, there is no need to merge the +files and this function is sufficient. + +When the list is longer than `slime-repl-history-size' it will be +truncated. That part is untested, though!" + (interactive (list (slime-repl-read-history-filename))) + (let ((file (or filename slime-repl-history-file)) + (hist (or history slime-repl-input-history))) + (unless (file-writable-p file) + (error (format "History file not writable: %s" file))) + (let ((hist (cl-subseq hist 0 (min (length hist) slime-repl-history-size)))) + ;;(message "saving %s to %s\n" hist file) + (with-temp-file file + (let ((cs slime-repl-history-file-coding-system) + (print-length nil) (print-level nil)) + (setq buffer-file-coding-system cs) + (insert (format ";; -*- coding: %s -*-\n" cs)) + (insert ";; History for SLIME REPL. Automatically written.\n" + ";; Edit only if you know what you're doing\n") + (prin1 (mapcar #'substring-no-properties hist) (current-buffer))))))) + +(defun slime-repl-save-all-histories () + "Save the history in each repl buffer." + (dolist (b (buffer-list)) + (with-current-buffer b + (when (eq major-mode 'slime-repl-mode) + (slime-repl-safe-save-merged-history))))) + +(defun slime-repl-safe-save-merged-history () + (slime-repl-call-with-handler + #'slime-repl-save-merged-history + "%S while saving the history. Continue? ")) + +(defun slime-repl-safe-load-history () + (slime-repl-call-with-handler + #'slime-repl-load-history + "%S while loading the history. Continue? ")) + +(defun slime-repl-call-with-handler (fun query) + "Call FUN in the context of an error handler. +The handler will use qeuery to ask the use if the error should be ingored." + (condition-case err + (funcall fun) + (error + (if (y-or-n-p (format query (error-message-string err))) + nil + (signal (car err) (cdr err)))))) + + +;;;;; REPL Read Mode + +(defvar slime-repl-read-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-m" 'slime-repl-return) + (define-key map [return] 'slime-repl-return) + (define-key map (kbd "TAB") 'self-insert-command) + (define-key map "\C-c\C-b" 'slime-repl-read-break) + (define-key map "\C-c\C-c" 'slime-repl-read-break) + (define-key map [remap slime-indent-and-complete-symbol] 'ignore) + (define-key map [remap slime-handle-repl-shortcut] 'self-insert-command) + map)) + +(define-minor-mode slime-repl-read-mode + "Mode to read input from Emacs +\\{slime-repl-read-mode-map}" + nil + "[read]") + +(make-variable-buffer-local + (defvar slime-read-string-threads nil)) + +(make-variable-buffer-local + (defvar slime-read-string-tags nil)) + +(defun slime-repl-read-string (thread tag) + (slime-switch-to-output-buffer) + (push thread slime-read-string-threads) + (push tag slime-read-string-tags) + (goto-char (point-max)) + (slime-mark-output-end) + (slime-mark-input-start) + (slime-repl-read-mode 1)) + +(defun slime-repl-return-string (string) + (slime-dispatch-event `(:emacs-return-string + ,(pop slime-read-string-threads) + ,(pop slime-read-string-tags) + ,string)) + (slime-repl-read-mode -1)) + +(defun slime-repl-read-break () + (interactive) + (slime-dispatch-event `(:emacs-interrupt ,(car slime-read-string-threads)))) + +(defun slime-repl-abort-read (thread tag) + (with-current-buffer (slime-output-buffer) + (pop slime-read-string-threads) + (pop slime-read-string-tags) + (slime-repl-read-mode -1) + (message "Read aborted"))) + + +;;;;; REPL handlers + +(cl-defstruct (slime-repl-shortcut (:conc-name slime-repl-shortcut.)) + symbol names handler one-liner) + +(defvar slime-repl-shortcut-table nil + "A list of slime-repl-shortcuts") + +(defvar slime-repl-shortcut-history '() + "History list of shortcut command names.") + +(defvar slime-within-repl-shortcut-handler-p nil + "Bound to T if we're in a REPL shortcut handler invoked from the REPL.") + +(defun slime-handle-repl-shortcut () + (interactive) + (if (> (point) slime-repl-input-start-mark) + (insert (string slime-repl-shortcut-dispatch-char)) + (let ((shortcut (slime-lookup-shortcut + (completing-read "Command: " + (slime-bogus-completion-alist + (slime-list-all-repl-shortcuts)) + nil t nil + 'slime-repl-shortcut-history)))) + (with-struct (slime-repl-shortcut. handler) shortcut + (let ((slime-within-repl-shortcut-handler-p t)) + (call-interactively handler)))))) + +(defun slime-list-all-repl-shortcuts () + (loop for shortcut in slime-repl-shortcut-table + append (slime-repl-shortcut.names shortcut))) + +(defun slime-lookup-shortcut (name) + (cl-find-if (lambda (s) (member name (slime-repl-shortcut.names s))) + slime-repl-shortcut-table)) + +(defmacro defslime-repl-shortcut (elisp-name names &rest options) + "Define a new repl shortcut. ELISP-NAME is a symbol specifying +the name of the interactive function to create, or NIL if no +function should be created. + +NAMES is a list of \(full-name . aliases\). + +OPTIONS is an plist specifying the handler doing the actual work +of the shortcut \(`:handler'\), and a help text \(`:one-liner'\)." + `(progn + ,(when elisp-name + `(defun ,elisp-name () + (interactive) + (call-interactively ,(second (assoc :handler options))))) + (let ((new-shortcut (make-slime-repl-shortcut + :symbol ',elisp-name + :names (list ,@names) + ,@(apply #'append options)))) + (setq slime-repl-shortcut-table + (cl-remove-if (lambda (s) + (member ',(car names) (slime-repl-shortcut.names s))) + slime-repl-shortcut-table)) + (push new-shortcut slime-repl-shortcut-table) + ',elisp-name))) + +(defun slime-repl-shortcut-eval (sexp &optional package) + "This function should be used by REPL shortcut handlers instead +of `slime-eval' to evaluate their final expansion. (This +expansion will be added to the REPL's history.)" + (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo? + (slime-repl-add-to-input-history (prin1-to-string sexp))) + (slime-eval sexp package)) + +(defun slime-repl-shortcut-eval-async (sexp &optional cont package) + "This function should be used by REPL shortcut handlers instead +of `slime-eval-async' to evaluate their final expansion. (This +expansion will be added to the REPL's history.)" + (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo? + (slime-repl-add-to-input-history (prin1-to-string sexp))) + (slime-eval-async sexp cont package)) + +(defun slime-list-repl-short-cuts () + (interactive) + (slime-with-popup-buffer ((slime-buffer-name :repl-help)) + (let ((table (cl-sort (cl-copy-list slime-repl-shortcut-table) #'string< + :key (lambda (x) + (car (slime-repl-shortcut.names x)))))) + (save-excursion + (dolist (shortcut table) + (let ((names (slime-repl-shortcut.names shortcut))) + (insert (pop names)) ;; first print the "full" name + (when names + ;; we also have aliases + (insert " (aka ") + (while (cdr names) + (insert (pop names) ", ")) + (insert (car names) ")")) + (when (slime-repl-shortcut.one-liner shortcut) + (insert "\n " (slime-repl-shortcut.one-liner shortcut))) + (insert "\n"))))))) + +(defun slime-save-some-lisp-buffers () + (if slime-repl-only-save-lisp-buffers + (save-some-buffers nil (lambda () + (and (memq major-mode slime-lisp-modes) + (not (null buffer-file-name))))) + (save-some-buffers))) + +(defun slime-kill-all-buffers () + "Kill all the SLIME-related buffers." + (dolist (buf (buffer-list)) + (when (or (string= (buffer-name buf) slime-event-buffer-name) + (string-match "^\\*inferior-lisp*" (buffer-name buf)) + (string-match "^\\*slime-repl .*\\*$" (buffer-name buf)) + (string-match "^\\*sldb .*\\*$" (buffer-name buf)) + (string-match "^\\*SLIME.*\\*$" (buffer-name buf))) + (kill-buffer buf)))) + +(defslime-repl-shortcut slime-repl-shortcut-help ("help") + (:handler 'slime-list-repl-short-cuts) + (:one-liner "Display the help.")) + +(defslime-repl-shortcut nil ("change-directory" "!d" "cd") + (:handler 'slime-set-default-directory) + (:one-liner "Change the current directory.")) + +(defslime-repl-shortcut nil ("pwd") + (:handler (lambda () + (interactive) + (let ((dir (slime-eval `(swank:default-directory)))) + (message "Directory %s" dir)))) + (:one-liner "Show the current directory.")) + +(defslime-repl-shortcut slime-repl-push-directory + ("push-directory" "+d" "pushd") + (:handler (lambda (directory) + (interactive + (list (read-directory-name + "Push directory: " + (slime-eval '(swank:default-directory)) + nil nil ""))) + (push (slime-eval '(swank:default-directory)) + slime-repl-directory-stack) + (slime-set-default-directory directory))) + (:one-liner "Save the current directory and set it to a new one.")) + +(defslime-repl-shortcut slime-repl-pop-directory + ("pop-directory" "-d" "popd") + (:handler (lambda () + (interactive) + (if (null slime-repl-directory-stack) + (message "Directory stack is empty.") + (slime-set-default-directory + (pop slime-repl-directory-stack))))) + (:one-liner "Restore the last saved directory.")) + +(defslime-repl-shortcut nil ("change-package" "!p" "in-package" "in") + (:handler 'slime-repl-set-package) + (:one-liner "Change the current package.")) + +(defslime-repl-shortcut slime-repl-push-package ("push-package" "+p") + (:handler (lambda (package) + (interactive (list (slime-read-package-name "Package: "))) + (push (slime-lisp-package) slime-repl-package-stack) + (slime-repl-set-package package))) + (:one-liner "Save the current package and set it to a new one.")) + +(defslime-repl-shortcut slime-repl-pop-package ("pop-package" "-p") + (:handler (lambda () + (interactive) + (if (null slime-repl-package-stack) + (message "Package stack is empty.") + (slime-repl-set-package + (pop slime-repl-package-stack))))) + (:one-liner "Restore the last saved package.")) + +(defslime-repl-shortcut slime-repl-resend ("resend-form") + (:handler (lambda () + (interactive) + (insert (car slime-repl-input-history)) + (insert "\n") + (slime-repl-send-input))) + (:one-liner "Resend the last form.")) + +(defslime-repl-shortcut slime-repl-disconnect ("disconnect") + (:handler 'slime-disconnect) + (:one-liner "Disconnect the current connection.")) + +(defslime-repl-shortcut slime-repl-disconnect-all ("disconnect-all") + (:handler 'slime-disconnect-all) + (:one-liner "Disconnect all connections.")) + +(defslime-repl-shortcut slime-repl-sayoonara ("sayoonara") + (:handler (lambda () + (interactive) + (when (slime-connected-p) + (slime-quit-lisp)) + (slime-kill-all-buffers))) + (:one-liner "Quit all Lisps and close all SLIME buffers.")) + +(defslime-repl-shortcut slime-repl-quit ("quit") + (:handler (lambda () + (interactive) + ;; `slime-quit-lisp' determines the connection to quit + ;; on behalf of the REPL's `slime-buffer-connection'. + (let ((repl-buffer (slime-output-buffer))) + (slime-quit-lisp) + (kill-buffer repl-buffer)))) + (:one-liner "Quit the current Lisp.")) + +(defslime-repl-shortcut slime-repl-defparameter ("defparameter" "!") + (:handler (lambda (name value) + (interactive (list (slime-read-symbol-name "Name (symbol): " t) + (slime-read-from-minibuffer "Value: " "*"))) + (insert "(cl:defparameter " name " " value + " \"REPL generated global variable.\")") + (slime-repl-send-input t))) + (:one-liner "Define a new global, special, variable.")) + +(defslime-repl-shortcut slime-repl-compile-and-load ("compile-and-load" "cl") + (:handler (lambda (filename) + (interactive (list (expand-file-name + (read-file-name "File: " nil nil nil nil)))) + (slime-save-some-lisp-buffers) + (slime-repl-shortcut-eval-async + `(swank:compile-file-if-needed + ,(slime-to-lisp-filename filename) t) + #'slime-compilation-finished))) + (:one-liner "Compile (if neccessary) and load a lisp file.")) + +(defslime-repl-shortcut nil ("restart-inferior-lisp") + (:handler 'slime-restart-inferior-lisp) + (:one-liner "Restart *inferior-lisp* and reconnect SLIME.")) + +(defun slime-redirect-inferior-output (&optional noerror) + "Redirect output of the inferior-process to the REPL buffer." + (interactive) + (let ((proc (slime-inferior-process))) + (cond (proc + (let ((filter (slime-rcurry #'slime-inferior-output-filter + (slime-current-connection)))) + (set-process-filter proc filter))) + (noerror) + (t (error "No inferior lisp process"))))) + +(defun slime-inferior-output-filter (proc string conn) + (cond ((eq (process-status conn) 'closed) + (message "Connection closed. Removing inferior output filter.") + (message "Lost output: %S" string) + (set-process-filter proc nil)) + (t + (slime-output-filter conn string)))) + +(defun slime-redirect-trace-output () + "Redirect the trace output to a separate Emacs buffer." + (interactive) + (let ((buffer (get-buffer-create (slime-buffer-name :trace)))) + (with-current-buffer buffer + (let ((marker (copy-marker (buffer-size))) + (target (incf slime-last-output-target-id))) + (puthash target marker slime-output-target-to-marker) + (slime-eval `(swank-repl:redirect-trace-output ,target)))) + ;; Note: We would like the entries in + ;; slime-output-target-to-marker to disappear when the buffers are + ;; killed. We cannot just make the hash-table ":weakness 'value" + ;; -- there is no reference from the buffers to the markers in the + ;; buffer, so entries would disappear even though the buffers are + ;; alive. Best solution might be to make buffer-local variables + ;; that keep the markers. --mkoeppe + (pop-to-buffer buffer))) + +(defun slime-call-defun () + "Insert a call to the toplevel form defined around point into the REPL." + (interactive) + (cl-labels ((insert-call + (name &key (function t) + defclass) + (let* ((setf (and function + (consp name) + (= (length name) 2) + (eql (car name) 'setf))) + (symbol (if setf + (cadr name) + name)) + (qualified-symbol-name + (slime-qualify-cl-symbol-name symbol)) + (symbol-name (slime-cl-symbol-name qualified-symbol-name)) + (symbol-package (slime-cl-symbol-package + qualified-symbol-name)) + (call (if (cl-equalp (slime-lisp-package) symbol-package) + symbol-name + qualified-symbol-name))) + (slime-switch-to-output-buffer) + (goto-char slime-repl-input-start-mark) + (insert (if function + "(" + " ")) + (when setf + (insert "setf (")) + (if defclass + (insert "make-instance '")) + (insert call) + (cond (setf + (insert " ") + (save-excursion (insert ") )"))) + (function + (insert " ") + (save-excursion (insert ")")))) + (unless function + (goto-char slime-repl-input-start-mark))))) + (let ((toplevel (slime-parse-toplevel-form))) + (if (symbolp toplevel) + (error "Not in a function definition") + (slime-dcase toplevel + (((:defun :defgeneric :defmacro :define-compiler-macro) symbol) + (insert-call symbol)) + ((:defmethod symbol &rest args) + (declare (ignore args)) + (insert-call symbol)) + (((:defparameter :defvar :defconstant) symbol) + (insert-call symbol :function nil)) + (((:defclass) symbol) + (insert-call symbol :defclass t)) + (t + (error "Not in a function definition"))))))) + +(defun slime-repl-copy-down-to-repl (slimefun &rest args) + (slime-eval-async `(swank-repl:listener-save-value ',slimefun ,@args) + #'(lambda (_ignored) + (with-current-buffer (slime-repl) + (slime-eval-async '(swank-repl:listener-get-value) + #'(lambda (_ignored) + (slime-repl-insert-prompt))))))) + +(defun slime-inspector-copy-down-to-repl (number) + "Evaluate the inspector slot at point via the REPL (to set `*')." + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-repl-copy-down-to-repl 'swank:inspector-nth-part number)) + +(defun sldb-copy-down-to-repl (frame-id var-id) + "Evaluate the frame var at point via the REPL (to set `*')." + (interactive (list (sldb-frame-number-at-point) (sldb-var-number-at-point))) + (slime-repl-copy-down-to-repl 'swank/backend:frame-var-value frame-id var-id)) + +(defun sldb-insert-frame-call-to-repl () + "Insert a call to a frame at point." + (interactive) + (let ((call (slime-eval `(swank/backend::frame-call + ,(sldb-frame-number-at-point))))) + (slime-switch-to-output-buffer) + (if (>= (point) slime-repl-prompt-start-mark) + (insert call) + (save-excursion + (goto-char (point-max)) + (insert call)))) + (slime-repl)) + +(defun slime-set-default-directory (directory) + "Make DIRECTORY become Lisp's current directory." + (interactive (list (read-directory-name "Directory: " nil nil t))) + (let ((dir (expand-file-name directory))) + (message "default-directory: %s" + (slime-from-lisp-filename + (slime-repl-shortcut-eval `(swank:set-default-directory + ,(slime-to-lisp-filename dir))))) + (with-current-buffer (slime-output-buffer) + (setq default-directory dir)))) + +(defun slime-sync-package-and-default-directory () + "Set Lisp's package and directory to the values in current buffer." + (interactive) + (let* ((package (slime-current-package)) + (exists-p (or (null package) + (slime-eval `(cl:packagep + (swank::guess-package ,package))))) + (directory default-directory)) + (when (and package exists-p) + (slime-repl-set-package package)) + (slime-set-default-directory directory) + ;; Sync *inferior-lisp* dir + (let* ((proc (slime-process)) + (buffer (and proc (process-buffer proc)))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq default-directory directory)))) + (message "package: %s%s directory: %s" + (with-current-buffer (slime-output-buffer) + (slime-lisp-package)) + (if exists-p "" (format " (package %s doesn't exist)" package)) + directory))) + +(defun slime-goto-connection () + "Switch to the REPL buffer for the connection at point." + (interactive) + (let ((slime-dispatching-connection (slime-connection-at-point))) + (switch-to-buffer (slime-output-buffer)))) + +(defun slime-repl-inside-string-or-comment-p () + (save-restriction + (when (and (boundp 'slime-repl-input-start-mark) + slime-repl-input-start-mark + (>= (point) slime-repl-input-start-mark)) + (narrow-to-region slime-repl-input-start-mark (point))) + (slime-inside-string-or-comment-p))) + +(defvar slime-repl-easy-menu + (let ((C '(slime-connected-p))) + `("REPL" + [ "Send Input" slime-repl-return ,C ] + [ "Close and Send Input " slime-repl-closing-return ,C ] + [ "Interrupt Lisp process" slime-interrupt ,C ] + "--" + [ "Previous Input" slime-repl-previous-input t ] + [ "Next Input" slime-repl-next-input t ] + [ "Goto Previous Prompt " slime-repl-previous-prompt t ] + [ "Goto Next Prompt " slime-repl-next-prompt t ] + [ "Clear Last Output" slime-repl-clear-output t ] + [ "Clear Buffer " slime-repl-clear-buffer t ] + [ "Kill Current Input" slime-repl-kill-input t ]))) + +(defun slime-repl-add-easy-menu () + (easy-menu-define menubar-slime-repl slime-repl-mode-map + "REPL" slime-repl-easy-menu) + (easy-menu-define menubar-slime slime-repl-mode-map + "SLIME" slime-easy-menu) + (easy-menu-add slime-repl-easy-menu 'slime-repl-mode-map)) + +(add-hook 'slime-repl-mode-hook 'slime-repl-add-easy-menu) + +(defun slime-hide-inferior-lisp-buffer () + "Display the REPL buffer instead of the *inferior-lisp* buffer." + (let* ((buffer (if (slime-process) + (process-buffer (slime-process)))) + (window (if buffer (get-buffer-window buffer t))) + (repl-buffer (slime-output-buffer t)) + (repl-window (get-buffer-window repl-buffer))) + (when buffer + (bury-buffer buffer)) + (cond (repl-window + (when window + (delete-window window))) + (window + (set-window-buffer window repl-buffer)) + (t + (pop-to-buffer repl-buffer) + (goto-char (point-max)))))) + +(defun slime-repl-choose-coding-system () + (let ((candidates (slime-connection-coding-systems))) + (or (cl-find (symbol-name (car default-process-coding-system)) + candidates + :test (lambda (s1 s2) + (if (fboundp 'coding-system-equal) + (coding-system-equal (intern s1) (intern s2))))) + (car candidates) + (error "Can't find suitable coding-system")))) + +(defun slime-repl-connected-hook-function () + (destructuring-bind (package prompt) + (let ((slime-current-thread t) + (cs (slime-repl-choose-coding-system))) + (slime-eval `(swank-repl:create-repl nil :coding-system ,cs))) + (setf (slime-lisp-package) package) + (setf (slime-lisp-package-prompt-string) prompt)) + (slime-hide-inferior-lisp-buffer) + (slime-init-output-buffer (slime-connection))) + +(defun slime-repl-event-hook-function (event) + (slime-dcase event + ((:write-string output &optional target) + (slime-write-string output target) + t) + ((:read-string thread tag) + (assert thread) + (slime-repl-read-string thread tag) + t) + ((:read-aborted thread tag) + (slime-repl-abort-read thread tag) + t) + ((:open-dedicated-output-stream port coding-system) + (slime-open-stream-to-lisp port coding-system) + t) + ((:new-package package prompt-string) + (setf (slime-lisp-package) package) + (setf (slime-lisp-package-prompt-string) prompt-string) + (let ((buffer (slime-connection-output-buffer))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq slime-buffer-package package)))) + t) + (t nil))) + +(defun slime-change-repl-to-default-connection () + "Change current REPL to the REPL of the default connection. +If the current buffer is not a REPL, don't do anything." + (when (equal major-mode 'slime-repl-mode) + (let ((slime-buffer-connection slime-default-connection)) + (pop-to-buffer-same-window (slime-connection-output-buffer))))) + +(defun slime-repl-find-buffer-package () + (or (slime-search-buffer-package) + (slime-lisp-package))) + +(defun slime-repl-add-hooks () + (add-hook 'slime-event-hooks 'slime-repl-event-hook-function) + (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function) + (add-hook 'slime-cycle-connections-hook + 'slime-change-repl-to-default-connection)) + +(defun slime-repl-remove-hooks () + (remove-hook 'slime-event-hooks 'slime-repl-event-hook-function) + (remove-hook 'slime-connected-hook 'slime-repl-connected-hook-function) + (remove-hook 'slime-cycle-connections-hook + 'slime-change-repl-to-default-connection)) + +(defun slime-repl-sexp-at-point () + "Returns the current sexp at point (or NIL if none is found) +while ignoring the repl prompt text." + (if (<= slime-repl-input-start-mark (point)) + (save-restriction + (narrow-to-region slime-repl-input-start-mark (point-max)) + (slime-sexp-at-point)) + (slime-sexp-at-point))) + +(defun slime-repl-inspect (string) + (interactive + (list (slime-read-from-minibuffer "Inspect value (evaluated): " + (slime-repl-sexp-at-point)))) + (slime-inspect string)) + +(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-repl-event-hook-function +;; slime-write-string +;; slime-repl-write-string +;; slime-repl-emit +;; slime-repl-show-maximum-output)) + +(provide 'slime-repl) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-sbcl-exts.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-sbcl-exts.el new file mode 100644 index 0000000..ab1c524 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-sbcl-exts.el @@ -0,0 +1,34 @@ +(require 'slime) +(require 'cl-lib) + +(define-slime-contrib slime-sbcl-exts + "Misc extensions for SBCL" + (:authors "Tobias C. Rittweiler ") + (:license "GPL") + (:slime-dependencies slime-references) + (:swank-dependencies swank-sbcl-exts)) + +(defun slime-sbcl-bug-at-point () + (save-excursion + (save-match-data + (unless (looking-at "#[0-9]\\{6\\}") + (search-backward-regexp "#\\<" (line-beginning-position) t)) + (when (looking-at "#[0-9]\\{6\\}") + (buffer-substring-no-properties (match-beginning 0) (match-end 0)))))) + +(defun slime-read-sbcl-bug (prompt &optional query) + "Either read a sbcl bug or choose the one at point. +The user is prompted if a prefix argument is in effect, if there is no +symbol at point, or if QUERY is non-nil." + (let ((bug (slime-sbcl-bug-at-point))) + (cond ((or current-prefix-arg query (not bug)) + (slime-read-from-minibuffer prompt bug)) + (t bug)))) + +(defun slime-visit-sbcl-bug (bug) + "Visit the Launchpad site that describes `bug' (#nnnnnn)." + (interactive (list (slime-read-sbcl-bug "Bug number (#nnnnnn): "))) + (browse-url (format "http://bugs.launchpad.net/sbcl/+bug/%s" + (substring bug 1)))) + +(provide 'slime-sbcl-exts) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-scheme.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-scheme.el new file mode 100644 index 0000000..9b7abd6 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-scheme.el @@ -0,0 +1,40 @@ +;;; slime-scheme.el --- Support Scheme programs running under Common Lisp +;; +;; Authors: Matthias Koeppe +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-scheme))) +;; +(eval-and-compile + (require 'slime)) + +(defun slime-scheme-mode-hook () + (slime-mode 1)) + +(defun slime-scheme-indentation-update (symbol indent packages) + ;; Does the symbol have an indentation value that we set? + (when (equal (get symbol 'scheme-indent-function) + (get symbol 'slime-scheme-indent)) + (put symbol 'slime-scheme-indent indent) + (put symbol 'scheme-indent-function indent))) + + +;;; Initialization + +(defun slime-scheme-init () + (add-hook 'scheme-mode-hook 'slime-scheme-mode-hook) + (add-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update) + (add-to-list 'slime-lisp-modes 'scheme-mode)) + +(defun slime-scheme-unload () + (remove-hook 'scheme-mode-hook 'slime-scheme-mode-hook) + (remove-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update) + (setq slime-lisp-modes (remove 'scheme-mode slime-lisp-modes))) + +(provide 'slime-scheme) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-scratch.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-scratch.el new file mode 100644 index 0000000..113fae0 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-scratch.el @@ -0,0 +1,48 @@ +;;; slime-scratch.el + +(require 'slime) +(require 'cl-lib) + +(define-slime-contrib slime-scratch + "Imitate Emacs' *scratch* buffer" + (:authors "Helmut Eller ") + (:license "GPL") + (:on-load + (def-slime-selector-method ?s "*slime-scratch* buffer." + (slime-scratch-buffer)))) + + +;;; Code + +(defvar slime-scratch-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-mode-map) + map)) + +(defun slime-scratch () + (interactive) + (slime-switch-to-scratch-buffer)) + +(defun slime-switch-to-scratch-buffer () + (set-buffer (slime-scratch-buffer)) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t))) + +(defvar slime-scratch-file nil) + +(defun slime-scratch-buffer () + "Return the scratch buffer, create it if necessary." + (or (get-buffer (slime-buffer-name :scratch)) + (with-current-buffer (if slime-scratch-file + (find-file slime-scratch-file) + (get-buffer-create (slime-buffer-name :scratch))) + (rename-buffer (slime-buffer-name :scratch)) + (lisp-mode) + (use-local-map slime-scratch-mode-map) + (slime-mode t) + (current-buffer)))) + +(slime-define-keys slime-scratch-mode-map + ("\C-j" 'slime-eval-print-last-expression)) + +(provide 'slime-scratch) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-snapshot.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-snapshot.el new file mode 100644 index 0000000..1643ecc --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-snapshot.el @@ -0,0 +1,34 @@ +(eval-and-compile + (require 'slime)) + +(define-slime-contrib slime-snapshot + "Save&restore memory images without disconnecting" + (:authors "Helmut Eller ") + (:license "GPL v3") + (:swank-dependencies swank-snapshot)) + +(defun slime-snapshot (filename &optional background) + "Save a memory image to the file FILENAME." + (interactive (list (read-file-name "Image file: ") + current-prefix-arg)) + (let ((file (expand-file-name filename))) + (when (and (file-exists-p file) + (not (yes-or-no-p (format "File exists %s. Overwrite it? " + filename)))) + (signal 'quit nil)) + (slime-eval-with-transcript + `(,(if background + 'swank-snapshot:background-save-snapshot + 'swank-snapshot:save-snapshot) + ,file)))) + +(defun slime-restore (filename) + "Restore a memory image stored in file FILENAME." + (interactive (list (read-file-name "Image file: "))) + ;; bypass event dispatcher because we don't expect a reply. FIXME. + (slime-net-send `(:emacs-rex (swank-snapshot:restore-snapshot + ,(expand-file-name filename)) + nil t nil) + (slime-connection))) + +(provide 'slime-snapshot) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-sprof.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-sprof.el new file mode 100644 index 0000000..8233e7b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-sprof.el @@ -0,0 +1,224 @@ +(require 'slime) +(require 'cl-lib) +(eval-when-compile (require 'cl)) ; lexical-let* + +(define-slime-contrib slime-sprof + "Integration with SBCL's sb-sprof." + (:authors "Juho Snellman" + "Stas Boukarev") + (:license "MIT") + (:swank-dependencies swank-sprof) + (:on-load + (let ((C '(and (slime-connected-p) + (equal (slime-lisp-implementation-type) "SBCL")))) + (setf (cdr (last (assoc "Profiling" slime-easy-menu))) + `("--" + [ "Start sb-sprof" slime-sprof-start ,C ] + [ "Stop sb-sprof" slime-sprof-stop ,C ] + [ "Report sb-sprof" slime-sprof-report ,C ]))))) + +(defvar slime-sprof-exclude-swank nil + "*Display swank functions in the report.") + +(define-derived-mode slime-sprof-browser-mode fundamental-mode + "slprof" + "Mode for browsing profiler data\ +\\\ +\\{slime-sprof-browser-mode-map}" + :syntax-table lisp-mode-syntax-table + (setq buffer-read-only t)) + +(set-keymap-parent slime-sprof-browser-mode-map slime-parent-map) + +(slime-define-keys slime-sprof-browser-mode-map + ("h" 'describe-mode) + ("d" 'slime-sprof-browser-disassemble-function) + ("g" 'slime-sprof-browser-go-to) + ("v" 'slime-sprof-browser-view-source) + ("s" 'slime-sprof-toggle-swank-exclusion) + ((kbd "RET") 'slime-sprof-browser-toggle)) + +;; Start / stop profiling + +(cl-defun slime-sprof-start (&optional (mode :cpu)) + (interactive) + (slime-eval `(swank:swank-sprof-start :mode ,mode))) + +(defun slime-sprof-start-alloc () + (interactive) + (slime-sprof-start :alloc)) + +(defun slime-sprof-start-time () + (interactive) + (slime-sprof-start :time)) + +(defun slime-sprof-stop () + (interactive) + (slime-eval `(swank:swank-sprof-stop))) + +;; Reporting + +(defun slime-sprof-format (graph) + (with-current-buffer (slime-buffer-name :sprof) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (format "%4s %-54s %6s %6s %6s\n" + "Rank" + "Name" + "Self%" + "Cumul%" + "Total%")) + (dolist (data graph) + (slime-sprof-browser-insert-line data 54)))) + (forward-line 2)) + +(cl-defun slime-sprof-update (&optional (exclude-swank slime-sprof-exclude-swank)) + (slime-eval-async `(swank:swank-sprof-get-call-graph + :exclude-swank ,exclude-swank) + 'slime-sprof-format)) + +(defalias 'slime-sprof-browser 'slime-sprof-report) + +(defun slime-sprof-report () + (interactive) + (slime-with-popup-buffer ((slime-buffer-name :sprof) + :connection t + :select t + :mode 'slime-sprof-browser-mode) + (slime-sprof-update))) + +(defun slime-sprof-toggle-swank-exclusion () + (interactive) + (setq slime-sprof-exclude-swank + (not slime-sprof-exclude-swank)) + (slime-sprof-update)) + +(defun slime-sprof-browser-insert-line (data name-length) + (cl-destructuring-bind (index name self cumul total) + data + (if index + (insert (format "%-4d " index)) + (insert " ")) + (slime-insert-propertized + (slime-sprof-browser-name-properties) + (format (format "%%-%ds " name-length) + (slime-sprof-abbreviate-name name name-length))) + (insert (format "%6.2f " self)) + (when cumul + (insert (format "%6.2f " cumul)) + (when total + (insert (format "%6.2f" total)))) + (when index + (slime-sprof-browser-add-line-text-properties + `(profile-index ,index expanded nil))) + (insert "\n"))) + +(defun slime-sprof-abbreviate-name (name max-length) + (cl-subseq name 0 (min (length name) max-length))) + +;; Expanding / collapsing + +(defun slime-sprof-browser-toggle () + (interactive) + (let ((index (get-text-property (point) 'profile-index))) + (when index + (save-excursion + (if (slime-sprof-browser-line-expanded-p) + (slime-sprof-browser-collapse) + (slime-sprof-browser-expand)))))) + +(defun slime-sprof-browser-collapse () + (let ((inhibit-read-only t)) + (slime-sprof-browser-add-line-text-properties '(expanded nil)) + (forward-line) + (cl-loop until (or (eobp) + (get-text-property (point) 'profile-index)) + do + (delete-region (point-at-bol) (point-at-eol)) + (unless (eobp) + (delete-char 1))))) + +(defun slime-sprof-browser-expand () + (lexical-let* ((buffer (current-buffer)) + (point (point)) + (index (get-text-property point 'profile-index))) + (slime-eval-async `(swank:swank-sprof-expand-node ,index) + (lambda (data) + (with-current-buffer buffer + (save-excursion + (destructuring-bind (&key callers calls) + data + (slime-sprof-browser-add-expansion callers + "Callers" + 0) + (slime-sprof-browser-add-expansion calls + "Calls" + 0)))))))) + +(defun slime-sprof-browser-add-expansion (data type nesting) + (when data + (let ((inhibit-read-only t)) + (slime-sprof-browser-add-line-text-properties '(expanded t)) + (end-of-line) + (insert (format "\n %s" type)) + (dolist (node data) + (cl-destructuring-bind (index name cumul) node + (insert (format (format "\n%%%ds" (+ 7 (* 2 nesting))) "")) + (slime-insert-propertized + (slime-sprof-browser-name-properties) + (let ((len (- 59 (* 2 nesting)))) + (format (format "%%-%ds " len) + (slime-sprof-abbreviate-name name len)))) + (slime-sprof-browser-add-line-text-properties + `(profile-sub-index ,index)) + (insert (format "%6.2f" cumul))))))) + +(defun slime-sprof-browser-line-expanded-p () + (get-text-property (point) 'expanded)) + +(defun slime-sprof-browser-add-line-text-properties (properties) + (add-text-properties (point-at-bol) + (point-at-eol) + properties)) + +(defun slime-sprof-browser-name-properties () + '(face sldb-restart-number-face)) + +;; "Go to function" + +(defun slime-sprof-browser-go-to () + (interactive) + (let ((sub-index (get-text-property (point) 'profile-sub-index))) + (when sub-index + (let ((pos (text-property-any + (point-min) (point-max) 'profile-index sub-index))) + (when pos (goto-char pos)))))) + +;; Disassembly + +(defun slime-sprof-browser-disassemble-function () + (interactive) + (let ((index (or (get-text-property (point) 'profile-index) + (get-text-property (point) 'profile-sub-index)))) + (when index + (slime-eval-describe `(swank:swank-sprof-disassemble + ,index))))) + +;; View source + +(defun slime-sprof-browser-view-source () + (interactive) + (let ((index (or (get-text-property (point) 'profile-index) + (get-text-property (point) 'profile-sub-index)))) + (when index + (slime-eval-async + `(swank:swank-sprof-source-location ,index) + (lambda (source-location) + (slime-dcase source-location + ((:error message) + (message "%s" message) + (ding)) + (t + (slime-show-source-location source-location)))))))) + +(provide 'slime-sprof) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-trace-dialog.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-trace-dialog.el new file mode 100644 index 0000000..fd25c7b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-trace-dialog.el @@ -0,0 +1,837 @@ +;;; -*- coding: utf-8; lexical-binding: t -*- +;;; +;;; slime-trace-dialog.el -- a navigable dialog of inspectable trace entries +;;; +;;; TODO: implement better wrap interface for sbcl method, labels and such +;;; TODO: backtrace printing is very slow +;;; +(require 'slime) +(require 'slime-parse) +(require 'slime-repl) +(require 'cl-lib) + +(define-slime-contrib slime-trace-dialog + "Provide an interfactive trace dialog buffer for managing and +inspecting details of traced functions. Invoke this dialog with C-c T." + (:authors "João Távora ") + (:license "GPL") + (:swank-dependencies swank-trace-dialog) + (:on-load (add-hook 'slime-mode-hook 'slime-trace-dialog-enable) + (add-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable)) + (:on-unload (remove-hook 'slime-mode-hook 'slime-trace-dialog-enable) + (remove-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable))) + + +;;;; Variables +;;; +(defvar slime-trace-dialog-flash t + "Non-nil means flash the updated region of the SLIME Trace Dialog. ") + +(defvar slime-trace-dialog--specs-overlay nil) + +(defvar slime-trace-dialog--progress-overlay nil) + +(defvar slime-trace-dialog--tree-overlay nil) + +(defvar slime-trace-dialog--collapse-chars (cons "-" "+")) + + +;;;; Local trace entry model +(defvar slime-trace-dialog--traces nil) + +(cl-defstruct (slime-trace-dialog--trace + (:constructor slime-trace-dialog--make-trace)) + id + parent + spec + args + retlist + depth + beg + end + collapse-button-marker + summary-beg + children-end + collapsed-p) + +(defun slime-trace-dialog--find-trace (id) + (gethash id slime-trace-dialog--traces)) + + +;;;; Modes and mode maps +;;; +(defvar slime-trace-dialog-mode-map + (let ((map (make-sparse-keymap)) + (remaps '((slime-inspector-operate-on-point . nil) + (slime-inspector-operate-on-click . nil) + (slime-inspector-reinspect + . slime-trace-dialog-fetch-status) + (slime-inspector-next-inspectable-object + . slime-trace-dialog-next-button) + (slime-inspector-previous-inspectable-object + . slime-trace-dialog-prev-button)))) + (set-keymap-parent map slime-inspector-mode-map) + (cl-loop for (old . new) in remaps + do (substitute-key-definition old new map)) + (set-keymap-parent map slime-parent-map) + (define-key map (kbd "G") 'slime-trace-dialog-fetch-traces) + (define-key map (kbd "C-k") 'slime-trace-dialog-clear-fetched-traces) + (define-key map (kbd "g") 'slime-trace-dialog-fetch-status) + (define-key map (kbd "M-RET") 'slime-trace-dialog-copy-down-to-repl) + (define-key map (kbd "q") 'quit-window) + map)) + +(define-derived-mode slime-trace-dialog-mode fundamental-mode + "SLIME Trace Dialog" "Mode for controlling SLIME's Trace Dialog" + (set-syntax-table lisp-mode-syntax-table) + (read-only-mode 1) + (add-to-list (make-local-variable 'slime-trace-dialog-after-toggle-hook) + 'slime-trace-dialog-fetch-status)) + +(define-derived-mode slime-trace-dialog--detail-mode slime-inspector-mode + "SLIME Trace Detail" + "Mode for viewing a particular trace from SLIME's Trace Dialog") + +(setq slime-trace-dialog--detail-mode-map + (let ((map (make-sparse-keymap)) + (remaps '((slime-inspector-next-inspectable-object + . slime-trace-dialog-next-button) + (slime-inspector-previous-inspectable-object + . slime-trace-dialog-prev-button)))) + (set-keymap-parent map slime-trace-dialog-mode-map) + (cl-loop for (old . new) in remaps + do (substitute-key-definition old new map)) + map)) + +(defvar slime-trace-dialog-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c T") 'slime-trace-dialog) + (define-key map (kbd "C-c M-t") 'slime-trace-dialog-toggle-trace) + map)) + +(define-minor-mode slime-trace-dialog-minor-mode + "Add keybindings for accessing SLIME's Trace Dialog.") + +(defun slime-trace-dialog-enable () + (slime-trace-dialog-minor-mode 1)) + +(easy-menu-define slime-trace-dialog--menubar (list slime-trace-dialog-minor-mode-map + slime-trace-dialog-mode-map) + "A menu for accessing some features of SLIME's Trace Dialog" + (let* ((in-dialog '(eq major-mode 'slime-trace-dialog-mode)) + (dialog-live `(and ,in-dialog + (memq slime-buffer-connection slime-net-processes))) + (connected '(slime-connected-p))) + `("Trace" + ["Toggle trace" slime-trace-dialog-toggle-trace ,connected] + ["Trace complex spec" slime-trace-dialog-toggle-complex-trace ,connected] + ["Open Trace dialog" slime-trace-dialog (and ,connected (not ,in-dialog))] + "--" + [ "Refresh traces and progress" slime-trace-dialog-fetch-status ,dialog-live] + [ "Fetch next batch" slime-trace-dialog-fetch-traces ,dialog-live] + [ "Clear all fetched traces" slime-trace-dialog-clear-fetched-traces ,dialog-live] + [ "Toggle details" slime-trace-dialog-hide-details-mode ,in-dialog] + [ "Toggle autofollow" slime-trace-dialog-autofollow-mode ,in-dialog]))) + +(define-minor-mode slime-trace-dialog-hide-details-mode + "Hide details in `slime-trace-dialog-mode'" + nil " Brief" + :group 'slime-trace-dialog + (unless (derived-mode-p 'slime-trace-dialog-mode) + (error "Not a SLIME Trace Dialog buffer")) + (slime-trace-dialog--set-hide-details-mode)) + +(define-minor-mode slime-trace-dialog-autofollow-mode + "Automatically open buffers with trace details from `slime-trace-dialog-mode'" + nil " Autofollow" + :group 'slime-trace-dialog + (unless (derived-mode-p 'slime-trace-dialog-mode) + (error "Not a SLIME Trace Dialog buffer"))) + + +;;;; Helper functions +;;; +(defun slime-trace-dialog--call-refreshing (buffer + overlay + dont-erase + recover-point-p + fn) + (with-current-buffer buffer + (let ((inhibit-point-motion-hooks t) + (inhibit-read-only t) + (saved (point))) + (save-restriction + (when overlay + (narrow-to-region (overlay-start overlay) + (overlay-end overlay))) + (unwind-protect + (if dont-erase + (goto-char (point-max)) + (delete-region (point-min) (point-max))) + (funcall fn) + (when recover-point-p + (goto-char saved))) + (when slime-trace-dialog-flash + (slime-flash-region (point-min) (point-max))))) + buffer)) + +(cl-defmacro slime-trace-dialog--refresh ((&key + overlay + dont-erase + recover-point-p + buffer) + &rest body) + (declare (indent 1) + (debug (sexp &rest form))) + `(slime-trace-dialog--call-refreshing ,(or buffer + `(current-buffer)) + ,overlay + ,dont-erase + ,recover-point-p + #'(lambda () ,@body))) + +(defmacro slime-trace-dialog--insert-and-overlay (string overlay) + `(save-restriction + (let ((inhibit-read-only t)) + (narrow-to-region (point) (point)) + (insert ,string "\n") + (set (make-local-variable ',overlay) + (let ((overlay (make-overlay (point-min) + (point-max) + (current-buffer) + nil + t))) + (move-overlay overlay (overlay-start overlay) + (1- (overlay-end overlay))) + ;; (overlay-put overlay 'face '(:background "darkslategrey")) + overlay))))) + +(defun slime-trace-dialog--buffer-name () + (format "*traces for %s*" + (slime-connection-name slime-default-connection))) + +(defun slime-trace-dialog--live-dialog (&optional buffer-or-name) + (let ((buffer-or-name (or buffer-or-name + (slime-trace-dialog--buffer-name)))) + (and (buffer-live-p (get-buffer buffer-or-name)) + (with-current-buffer buffer-or-name + (memq slime-buffer-connection slime-net-processes)) + buffer-or-name))) + +(defun slime-trace-dialog--ensure-buffer () + (let ((name (slime-trace-dialog--buffer-name))) + (or (slime-trace-dialog--live-dialog name) + (with-current-buffer (get-buffer-create name) + (let ((inhibit-read-only t)) + (erase-buffer)) + (slime-trace-dialog-mode) + (save-excursion + (buffer-disable-undo) + (slime-trace-dialog--insert-and-overlay + "[waiting for the traced specs to be available]" + slime-trace-dialog--specs-overlay) + (slime-trace-dialog--insert-and-overlay + "[waiting for some info on trace download progress ]" + slime-trace-dialog--progress-overlay) + (slime-trace-dialog--insert-and-overlay + "[waiting for the actual traces to be available]" + slime-trace-dialog--tree-overlay) + (current-buffer)) + (setq slime-buffer-connection slime-default-connection) + (current-buffer))))) + +(defun slime-trace-dialog--make-autofollow-fn (id) + (let ((requested nil)) + #'(lambda (_before after) + (let ((inhibit-point-motion-hooks t) + (id-after (get-text-property after 'slime-trace-dialog--id))) + (when (and (= after (point)) + slime-trace-dialog-autofollow-mode + id-after + (= id-after id) + (not requested)) + (setq requested t) + (slime-eval-async `(swank-trace-dialog:report-trace-detail + ,id-after) + #'(lambda (detail) + (setq requested nil) + (when detail + (let ((inhibit-point-motion-hooks t)) + (slime-trace-dialog--open-detail detail + 'no-pop)))))))))) + +(defun slime-trace-dialog--set-collapsed (collapsed-p trace button) + (save-excursion + (setf (slime-trace-dialog--trace-collapsed-p trace) collapsed-p) + (slime-trace-dialog--go-replace-char-at + button + (if collapsed-p + (cdr slime-trace-dialog--collapse-chars) + (car slime-trace-dialog--collapse-chars))) + (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-summary-beg trace) + (slime-trace-dialog--trace-end trace) + (if collapsed-p 1 -1)) + (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-end trace) + (slime-trace-dialog--trace-children-end trace) + (if collapsed-p 1 -1)))) + +(defun slime-trace-dialog--hide-unhide (start-pos end-pos delta) + (cl-loop with inhibit-read-only = t + for pos = start-pos then next + for next = (next-single-property-change + pos + 'slime-trace-dialog--hidden-level + nil + end-pos) + for hidden-level = (+ (or (get-text-property + pos + 'slime-trace-dialog--hidden-level) + 0) + delta) + do (add-text-properties pos next + (list 'slime-trace-dialog--hidden-level + hidden-level + 'invisible + (cl-plusp hidden-level))) + while (< next end-pos))) + +(defun slime-trace-dialog--set-hide-details-mode () + (cl-loop for trace being the hash-values of slime-trace-dialog--traces + do (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-summary-beg trace) + (slime-trace-dialog--trace-end trace) + (if slime-trace-dialog-hide-details-mode 1 -1)))) + +(defun slime-trace-dialog--format-part (part-id part-text trace-id type) + (slime-trace-dialog--button + (format "%s" part-text) + #'(lambda (_button) + (slime-eval-async + `(swank-trace-dialog:inspect-trace-part ,trace-id ,part-id ,type) + #'slime-open-inspector)) + 'mouse-face 'highlight + 'slime-trace-dialog--part-id part-id + 'slime-trace-dialog--type type + 'face 'slime-inspector-value-face)) + +(defun slime-trace-dialog--format-trace-entry (id external) + (slime-trace-dialog--button + (format "%s" external) + #'(lambda (_button) + (slime-eval-async + `(swank::inspect-object (swank-trace-dialog::find-trace ,id)) + #'slime-open-inspector)) + 'face 'slime-inspector-value-face)) + +(defun slime-trace-dialog--format (fmt-string &rest args) + (let* ((string (apply #'format fmt-string args)) + (indent (make-string (max 2 + (- 50 (length string))) ? ))) + (format "%s%s" string indent))) + +(defun slime-trace-dialog--button (title lambda &rest props) + (let ((string (format "%s" title))) + (apply #'make-text-button string nil + 'action #'(lambda (button) + (funcall lambda button)) + 'mouse-face 'highlight + 'face 'slime-inspector-action-face + props) + string)) + +(defun slime-trace-dialog--call-maintaining-properties (pos fn) + (save-excursion + (goto-char pos) + (let* ((saved-props (text-properties-at pos)) + (saved-point (point)) + (inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (funcall fn) + (add-text-properties saved-point (point) saved-props) + (if (markerp pos) (set-marker pos saved-point))))) + +(cl-defmacro slime-trace-dialog--maintaining-properties (pos + &body body) + (declare (indent 1)) + `(slime-trace-dialog--call-maintaining-properties ,pos #'(lambda () ,@body))) + +(defun slime-trace-dialog--go-replace-char-at (pos char) + (slime-trace-dialog--maintaining-properties pos + (delete-char 1) + (insert char))) + + +;;;; Handlers for the *trace-dialog* and *trace-detail* buffers +;;; +(defun slime-trace-dialog--open-specs (traced-specs) + (cl-labels ((make-report-spec-fn + (&optional form) + #'(lambda (_button) + (slime-eval-async + `(cl:progn + ,form + (swank-trace-dialog:report-specs)) + #'(lambda (results) + (slime-trace-dialog--open-specs results)))))) + (slime-trace-dialog--refresh + (:overlay slime-trace-dialog--specs-overlay + :recover-point-p t) + (insert + (slime-trace-dialog--format "Traced specs (%s)" (length traced-specs)) + (slime-trace-dialog--button "[refresh]" + (make-report-spec-fn)) + "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[untrace all]" + (make-report-spec-fn `(swank-trace-dialog:dialog-untrace-all))) + "\n\n") + (cl-loop for spec in traced-specs + do (insert + " " + (slime-trace-dialog--button + "[untrace]" + (make-report-spec-fn + `(swank-trace-dialog:dialog-untrace ',spec))) + (format " %s" spec) + "\n"))))) + +(defvar slime-trace-dialog--fetch-key nil) + +(defvar slime-trace-dialog--stop-fetching nil) + +(defun slime-trace-dialog--update-progress (total &optional show-stop-p remaining-p) + ;; `remaining-p' indicates `total' is the number of remaining traces. + (slime-trace-dialog--refresh + (:overlay slime-trace-dialog--progress-overlay + :recover-point-p t) + (let* ((done (hash-table-count slime-trace-dialog--traces)) + (total (if remaining-p (+ done total) total))) + (insert + (slime-trace-dialog--format "Trace collection status (%d/%s)" + done + (or total "0")) + (slime-trace-dialog--button "[refresh]" + #'(lambda (_button) + (slime-trace-dialog-fetch-progress)))) + + (when (and total (cl-plusp (- total done))) + (insert "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[fetch next batch]" + #'(lambda (_button) + (slime-trace-dialog-fetch-traces nil))) + "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[fetch all]" + #'(lambda (_button) + (slime-trace-dialog-fetch-traces t))))) + (when total + (insert "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[clear]" + #'(lambda (_button) + (slime-trace-dialog-clear-fetched-traces))))) + (when show-stop-p + (insert "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[stop]" + #'(lambda (_button) + (setq slime-trace-dialog--stop-fetching t))))) + (insert "\n\n")))) + +(defun slime-trace-dialog--open-detail (trace-tuple &optional no-pop) + (slime-with-popup-buffer ("*trace-detail*" :select (not no-pop) + :mode 'slime-trace-dialog--detail-mode) + (cl-destructuring-bind (id _parent-id _spec args retlist backtrace external) + trace-tuple + (let ((headline (slime-trace-dialog--format-trace-entry id external))) + (setq headline (format "%s\n%s\n" + headline + (make-string (length headline) ?-))) + (insert headline)) + (cl-loop for (type objects label) + in `((:arg ,args "Called with args:") + (:retval ,retlist "Returned values:")) + do (insert (format "\n%s\n" label)) + (insert (cl-loop for object in objects + for i from 0 + concat (format " %s: %s\n" i + (slime-trace-dialog--format-part + (cl-first object) + (cl-second object) + id + type))))) + (when backtrace + (insert "\nBacktrace:\n" + (cl-loop for (i spec) in backtrace + concat (format " %s: %s\n" i spec))))))) + + +;;;; Rendering traces +;;; +(defun slime-trace-dialog--draw-tree-lines (start offset direction) + (save-excursion + (let ((inhibit-point-motion-hooks t)) + (goto-char start) + (cl-loop with replace-set = (if (eq direction 'down) + '(? ) + '(? ?`)) + for line-beginning = (line-beginning-position + (if (eq direction 'down) + 2 0)) + for pos = (+ line-beginning offset) + while (and (< (point-min) line-beginning) + (< line-beginning (point-max)) + (memq (char-after pos) replace-set)) + do + (slime-trace-dialog--go-replace-char-at pos "|") + (goto-char pos))))) + +(defun slime-trace-dialog--make-indent (depth suffix) + (concat (make-string (* 3 (max 0 (1- depth))) ? ) + (if (cl-plusp depth) suffix))) + +(defun slime-trace-dialog--make-collapse-button (trace) + (slime-trace-dialog--button (if (slime-trace-dialog--trace-collapsed-p trace) + (cdr slime-trace-dialog--collapse-chars) + (car slime-trace-dialog--collapse-chars)) + #'(lambda (button) + (slime-trace-dialog--set-collapsed + (not (slime-trace-dialog--trace-collapsed-p + trace)) + trace + button)))) + + +(defun slime-trace-dialog--insert-trace (trace) + (let* ((id (slime-trace-dialog--trace-id trace)) + (parent (slime-trace-dialog--trace-parent trace)) + (has-children-p (slime-trace-dialog--trace-children-end trace)) + (indent-spec (slime-trace-dialog--make-indent + (slime-trace-dialog--trace-depth trace) + "`--")) + (indent-summary (slime-trace-dialog--make-indent + (slime-trace-dialog--trace-depth trace) + " ")) + (autofollow-fn (slime-trace-dialog--make-autofollow-fn id)) + (id-string (slime-trace-dialog--button + (format "%4s" id) + #'(lambda (_button) + (slime-eval-async + `(swank-trace-dialog:report-trace-detail + ,id) + #'slime-trace-dialog--open-detail)))) + (spec (slime-trace-dialog--trace-spec trace)) + (summary (cl-loop for (type objects marker) in + `((:arg ,(slime-trace-dialog--trace-args trace) + " > ") + (:retval ,(slime-trace-dialog--trace-retlist trace) + " < ")) + concat (cl-loop for object in objects + concat " " + concat indent-summary + concat marker + concat (slime-trace-dialog--format-part + (cl-first object) + (cl-second object) + id + type) + concat "\n")))) + (puthash id trace slime-trace-dialog--traces) + ;; insert and propertize the text + ;; + (setf (slime-trace-dialog--trace-beg trace) (point-marker)) + (insert id-string " ") + (insert indent-spec) + (if has-children-p + (insert (slime-trace-dialog--make-collapse-button trace)) + (setf (slime-trace-dialog--trace-collapse-button-marker trace) + (point-marker)) + (insert "-")) + (insert (format " %s\n" spec)) + (setf (slime-trace-dialog--trace-summary-beg trace) (point-marker)) + (insert summary) + (setf (slime-trace-dialog--trace-end trace) (point-marker)) + (set-marker-insertion-type (slime-trace-dialog--trace-beg trace) t) + + (add-text-properties (slime-trace-dialog--trace-beg trace) + (slime-trace-dialog--trace-end trace) + (list 'slime-trace-dialog--id id + 'point-entered autofollow-fn + 'point-left autofollow-fn)) + ;; respect brief mode and collapsed state + ;; + (cl-loop for condition in (list slime-trace-dialog-hide-details-mode + (slime-trace-dialog--trace-collapsed-p trace)) + when condition + do (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-summary-beg + trace) + (slime-trace-dialog--trace-end trace) + 1)) + (cl-loop for tr = trace then parent + for parent = (slime-trace-dialog--trace-parent tr) + while parent + when (slime-trace-dialog--trace-collapsed-p parent) + do (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-beg trace) + (slime-trace-dialog--trace-end trace) + (+ 1 + (or (get-text-property (slime-trace-dialog--trace-beg parent) + 'slime-trace-dialog--hidden-level) + 0))) + (cl-return)) + ;; maybe add the collapse-button to the parent in case it didn't + ;; have one already + ;; + (when (and parent + (slime-trace-dialog--trace-collapse-button-marker parent)) + (slime-trace-dialog--maintaining-properties + (slime-trace-dialog--trace-collapse-button-marker parent) + (delete-char 1) + (insert (slime-trace-dialog--make-collapse-button parent)) + (setf (slime-trace-dialog--trace-collapse-button-marker parent) + nil))) + ;; draw the tree lines + ;; + (when parent + (slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace) + (+ 2 (length indent-spec)) + 'up)) + (when has-children-p + (slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace) + (+ 5 (length indent-spec)) + 'down)) + ;; set the "children-end" slot + ;; + (unless (slime-trace-dialog--trace-children-end trace) + (cl-loop for parent = trace + then (slime-trace-dialog--trace-parent parent) + while parent + do + (setf (slime-trace-dialog--trace-children-end parent) + (slime-trace-dialog--trace-end trace)))))) + +(defun slime-trace-dialog--render-trace (trace) + ;; Render the trace entry in the appropriate place. + ;; + ;; A trace becomes a few lines of slightly propertized text in the + ;; buffer, inserted by `slime-trace-dialog--insert-trace', bound by + ;; point markers that we use here. + ;; + ;; The new trace might be replacing an existing one, or otherwise + ;; must be placed under its existing parent which might or might not + ;; be the last entry inserted. + ;; + (let ((existing (slime-trace-dialog--find-trace + (slime-trace-dialog--trace-id trace))) + (parent (slime-trace-dialog--trace-parent trace))) + (cond (existing + ;; Other traces might already reference `existing' and with + ;; need to maintain that eqness. Best way to do that is + ;; destructively modify `existing' with the new retlist... + ;; + (setf (slime-trace-dialog--trace-retlist existing) + (slime-trace-dialog--trace-retlist trace)) + ;; Now, before deleting and re-inserting `existing' at an + ;; arbitrary point in the tree, note that it's + ;; "children-end" marker is already non-nil, and informs us + ;; about its parenthood status. We want to 1. leave it + ;; alone if it's already a parent, or 2. set it to nil if + ;; it's a leaf, thus forcing the needed update of the + ;; parents' "children-end" marker. + ;; + (when (= (slime-trace-dialog--trace-children-end existing) + (slime-trace-dialog--trace-end existing)) + (setf (slime-trace-dialog--trace-children-end existing) nil)) + (delete-region (slime-trace-dialog--trace-beg existing) + (slime-trace-dialog--trace-end existing)) + (goto-char (slime-trace-dialog--trace-end existing)) + ;; Remember to set `trace' to be `existing' + ;; + (setq trace existing)) + (parent + (goto-char (1+ (slime-trace-dialog--trace-children-end parent)))) + (;; top level trace + t + (goto-char (point-max)))) + (goto-char (line-beginning-position)) + (slime-trace-dialog--insert-trace trace))) + +(defun slime-trace-dialog--update-tree (tuples) + (save-excursion + (slime-trace-dialog--refresh + (:overlay slime-trace-dialog--tree-overlay + :dont-erase t) + (cl-loop for tuple in tuples + for parent = (slime-trace-dialog--find-trace (cl-second tuple)) + for trace = (slime-trace-dialog--make-trace + :id (cl-first tuple) + :parent parent + :spec (cl-third tuple) + :args (cl-fourth tuple) + :retlist (cl-fifth tuple) + :depth (if parent + (1+ (slime-trace-dialog--trace-depth + parent)) + 0)) + do (slime-trace-dialog--render-trace trace))))) + +(defun slime-trace-dialog--clear-local-tree () + (set (make-local-variable 'slime-trace-dialog--fetch-key) + (cl-gensym "slime-trace-dialog-fetch-key-")) + (set (make-local-variable 'slime-trace-dialog--traces) + (make-hash-table)) + (slime-trace-dialog--refresh + (:overlay slime-trace-dialog--tree-overlay)) + (slime-trace-dialog--update-progress nil)) + +(defun slime-trace-dialog--on-new-results (results &optional recurse) + (cl-destructuring-bind (tuples remaining reply-key) + results + (cond ((and slime-trace-dialog--fetch-key + (string= (symbol-name slime-trace-dialog--fetch-key) + (symbol-name reply-key))) + (slime-trace-dialog--update-tree tuples) + (slime-trace-dialog--update-progress + remaining + (and recurse + (cl-plusp remaining)) + t) + (when (and recurse + (not (prog1 slime-trace-dialog--stop-fetching + (setq slime-trace-dialog--stop-fetching nil))) + (cl-plusp remaining)) + (slime-eval-async `(swank-trace-dialog:report-partial-tree + ',reply-key) + #'(lambda (results) (slime-trace-dialog--on-new-results + results + recurse)))))))) + + +;;;; Interactive functions +;;; +(defun slime-trace-dialog-fetch-specs () + "Refresh just list of traced specs." + (interactive) + (slime-eval-async `(swank-trace-dialog:report-specs) + #'slime-trace-dialog--open-specs)) + +(defun slime-trace-dialog-fetch-progress () + (interactive) + (slime-eval-async + '(swank-trace-dialog:report-total) + #'(lambda (total) + (slime-trace-dialog--update-progress + total)))) + +(defun slime-trace-dialog-fetch-status () + "Refresh just the status part of the SLIME Trace Dialog" + (interactive) + (slime-trace-dialog-fetch-specs) + (slime-trace-dialog-fetch-progress)) + +(defun slime-trace-dialog-clear-fetched-traces (&optional interactive) + "Clear local and remote traces collected so far" + (interactive "p") + (when (or (not interactive) + (y-or-n-p "Clear all collected and fetched traces?")) + (slime-eval-async + '(swank-trace-dialog:clear-trace-tree) + #'(lambda (_ignored) + (slime-trace-dialog--clear-local-tree))))) + +(defun slime-trace-dialog-fetch-traces (&optional recurse) + (interactive "P") + (setq slime-trace-dialog--stop-fetching nil) + (slime-eval-async `(swank-trace-dialog:report-partial-tree + ',slime-trace-dialog--fetch-key) + #'(lambda (results) (slime-trace-dialog--on-new-results results + recurse)))) + +(defun slime-trace-dialog-next-button (&optional goback) + (interactive) + (let ((finder (if goback + #'previous-single-property-change + #'next-single-property-change))) + (cl-loop for pos = (funcall finder (point) 'action) + while pos + do (goto-char pos) + until (get-text-property pos 'action)))) + +(defun slime-trace-dialog-prev-button () + (interactive) + (slime-trace-dialog-next-button 'goback)) + +(defvar slime-trace-dialog-after-toggle-hook nil + "Hooks run after toggling a dialog-trace") + +(defun slime-trace-dialog-toggle-trace (&optional using-context-p) + "Toggle the dialog-trace of the spec at point. + +When USING-CONTEXT-P, attempt to decipher lambdas. methods and +other complicated function specs." + (interactive "P") + ;; Notice the use of "spec strings" here as opposed to the + ;; proper cons specs we use on the swank side. + ;; + ;; Notice the conditional use of `slime-trace-query' found in + ;; swank-fancy-trace.el + ;; + (let* ((spec-string (if using-context-p + (slime-extract-context) + (slime-symbol-at-point))) + (spec-string (if (fboundp 'slime-trace-query) + (slime-trace-query spec-string) + spec-string))) + (message "%s" (slime-eval `(swank-trace-dialog:dialog-toggle-trace + (swank::from-string ,spec-string)))) + (run-hooks 'slime-trace-dialog-after-toggle-hook))) + +(defun slime-trace-dialog--update-existing-dialog () + (let ((existing (slime-trace-dialog--live-dialog))) + (when existing + (with-current-buffer existing + (slime-trace-dialog-fetch-status))))) + +(add-hook 'slime-trace-dialog-after-toggle-hook + 'slime-trace-dialog--update-existing-dialog) + +(defun slime-trace-dialog-toggle-complex-trace () + "Toggle the dialog-trace of the complex spec at point. + +See `slime-trace-dialog-toggle-trace'." + (interactive) + (slime-trace-dialog-toggle-trace t)) + +(defun slime-trace-dialog (&optional clear-and-fetch) + "Show trace dialog and refresh trace collection status. + +With optional CLEAR-AND-FETCH prefix arg, clear the current tree +and fetch a first batch of traces." + (interactive "P") + (with-current-buffer + (pop-to-buffer (slime-trace-dialog--ensure-buffer)) + (slime-trace-dialog-fetch-status) + (when (or clear-and-fetch + (null slime-trace-dialog--fetch-key)) + (slime-trace-dialog--clear-local-tree)) + (when clear-and-fetch + (slime-trace-dialog-fetch-traces nil)))) + +(defun slime-trace-dialog-copy-down-to-repl (id part-id type) + "Eval the Trace Dialog entry under point in the REPL (to set *)" + (interactive (cl-loop for prop in '(slime-trace-dialog--id + slime-trace-dialog--part-id + slime-trace-dialog--type) + collect (get-text-property (point) prop))) + (unless (and id part-id type) (error "No trace part at point %s" (point))) + (slime-repl-send-string + (format "%s" `(nth-value 0 + (swank-trace-dialog::find-trace-part + ,id ,part-id ,type)))) + (slime-repl)) + +(provide 'slime-trace-dialog) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-tramp.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-tramp.el new file mode 100644 index 0000000..1e3f14c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-tramp.el @@ -0,0 +1,121 @@ +(require 'slime) +(require 'tramp) +(eval-when-compile (require 'cl)) ; lexical-let + +(define-slime-contrib slime-tramp + "Filename translations for tramp" + (:authors "Marco Baringer ") + (:license "GPL") + (:on-load + (setq slime-to-lisp-filename-function #'slime-tramp-to-lisp-filename) + (setq slime-from-lisp-filename-function #'slime-tramp-from-lisp-filename))) + +(defcustom slime-filename-translations nil + "Assoc list of hostnames and filename translation functions. +Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP). + +HOSTNAME-REGEXP is a regexp which is applied to the connection's +slime-machine-instance. If HOSTNAME-REGEXP maches then the +corresponding TO-LISP and FROM-LISP functions will be used to +translate emacs filenames and lisp filenames. + +TO-LISP will be passed the filename of an emacs buffer and must +return a string which the underlying lisp understandas as a +pathname. FROM-LISP will be passed a pathname as returned by the +underlying lisp and must return something that emacs will +understand as a filename (this string will be passed to +find-file). + +This list will be traversed in order, so multiple matching +regexps are possible. + +Example: + +Assuming you run emacs locally and connect to slime running on +the machine 'soren' and you can connect with the username +'animaliter': + + (push (list \"^soren$\" + (lambda (emacs-filename) + (subseq emacs-filename (length \"/ssh:animaliter@soren:\"))) + (lambda (lisp-filename) + (concat \"/ssh:animaliter@soren:\" lisp-filename))) + slime-filename-translations) + +See also `slime-create-filename-translator'." + :type '(repeat (list :tag "Host description" + (regexp :tag "Hostname regexp") + (function :tag "To lisp function") + (function :tag "From lisp function"))) + :group 'slime-lisp) + +(defun slime-find-filename-translators (hostname) + (cond ((cdr (cl-assoc-if (lambda (regexp) (string-match regexp hostname)) + slime-filename-translations))) + (t (list #'identity #'identity)))) + +(defun slime-make-tramp-file-name (username remote-host lisp-filename) + "Tramp compatability function. + +Handles the signature of `tramp-make-tramp-file-name' changing +over time." + (cond + ((>= emacs-major-version 26) + ;; Emacs 26 requires the method to be provided and the signature of + ;; `tramp-make-tramp-file-name' has changed. + (tramp-make-tramp-file-name (tramp-find-method nil username remote-host) + username + nil + remote-host + nil + lisp-filename)) + ((boundp 'tramp-multi-methods) + (tramp-make-tramp-file-name nil nil + username + remote-host + lisp-filename)) + (t + (tramp-make-tramp-file-name nil + username + remote-host + lisp-filename)))) + +(cl-defun slime-create-filename-translator (&key machine-instance + remote-host + username) + "Creates a three element list suitable for push'ing onto +slime-filename-translations which uses Tramp to load files on +hostname using username. MACHINE-INSTANCE is a required +parameter, REMOTE-HOST defaults to MACHINE-INSTANCE and USERNAME +defaults to (user-login-name). + +MACHINE-INSTANCE is the value returned by slime-machine-instance, +which is just the value returned by cl:machine-instance on the +remote lisp. REMOTE-HOST is the fully qualified domain name (or +just the IP) of the remote machine. USERNAME is the username we +should login with. +The functions created here expect your tramp-default-method or + tramp-default-method-alist to be setup correctly." + (lexical-let ((remote-host (or remote-host machine-instance)) + (username (or username (user-login-name)))) + (list (concat "^" machine-instance "$") + (lambda (emacs-filename) + (tramp-file-name-localname + (tramp-dissect-file-name emacs-filename))) + `(lambda (lisp-filename) + (slime-make-tramp-file-name + ,username + ,remote-host + lisp-filename))))) + +(defun slime-tramp-to-lisp-filename (filename) + (funcall (if (slime-connected-p) + (first (slime-find-filename-translators (slime-machine-instance))) + 'identity) + (expand-file-name filename))) + +(defun slime-tramp-from-lisp-filename (filename) + (funcall (second (slime-find-filename-translators (slime-machine-instance))) + filename)) + +(provide 'slime-tramp) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-typeout-frame.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-typeout-frame.el new file mode 100644 index 0000000..7979b19 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-typeout-frame.el @@ -0,0 +1,92 @@ +(require 'slime) +(require 'slime-autodoc) +(require 'cl-lib) + +(defvar slime-typeout-frame-unbind-stack ()) + +(define-slime-contrib slime-typeout-frame + "Display messages in a dedicated frame." + (:authors "Luke Gorrie ") + (:license "GPL") + (:on-load + (unless (slime-typeout-tty-only-p) + (add-hook 'slime-connected-hook 'slime-ensure-typeout-frame) + (add-hook 'slime-autodoc-mode-hook 'slime-typeout-wrap-autodoc) + (cl-loop for (var value) in + '((slime-message-function slime-typeout-message) + (slime-background-message-function slime-typeout-message)) + do (slime-typeout-frame-init-var var value)))) + (:on-unload + (remove-hook 'slime-connected-hook 'slime-ensure-typeout-frame) + (remove-hook 'slime-autodoc-mode-hook 'slime-typeout-wrap-autodoc) + (cl-loop for (var value) in slime-typeout-frame-unbind-stack + do (cond ((eq var 'slime-unbound) (makunbound var)) + (t (set var value)))) + (setq slime-typeout-frame-unbind-stack nil))) + +(defun slime-typeout-frame-init-var (var value) + (push (list var (if (boundp var) (symbol-value var) 'slime-unbound)) + slime-typeout-frame-unbind-stack) + (set var value)) + +(defun slime-typeout-tty-only-p () + (cond ((featurep 'xemacs) + (null (remove 'tty (mapcar #'device-type (console-device-list))))) + (t (not (window-system))))) + + +;;;; Typeout frame + +;; When a "typeout frame" exists it is used to display certain +;; messages instead of the echo area or pop-up windows. + +(defvar slime-typeout-window nil + "The current typeout window.") + +(defvar slime-typeout-frame-properties + '((height . 10) (minibuffer . nil)) + "The typeout frame properties (passed to `make-frame').") + +(defun slime-typeout-buffer () + (with-current-buffer (get-buffer-create (slime-buffer-name :typeout)) + (setq buffer-read-only t) + (current-buffer))) + +(defun slime-typeout-active-p () + (and slime-typeout-window + (window-live-p slime-typeout-window))) + +(defun slime-typeout-message-aux (format-string &rest format-args) + (slime-ensure-typeout-frame) + (with-current-buffer (slime-typeout-buffer) + (let ((inhibit-read-only t) + (msg (apply #'format format-string format-args))) + (unless (string= msg "") + (erase-buffer) + (insert msg))))) + +(defun slime-typeout-message (format-string &rest format-args) + (apply #'slime-typeout-message-aux format-string format-args)) + +(defun slime-make-typeout-frame () + "Create a frame for displaying messages (e.g. arglists)." + (interactive) + (let ((frame (make-frame slime-typeout-frame-properties))) + (save-selected-window + (select-window (frame-selected-window frame)) + (switch-to-buffer (slime-typeout-buffer)) + (setq slime-typeout-window (selected-window))))) + +(defun slime-ensure-typeout-frame () + "Create the typeout frame unless it already exists." + (interactive) + (if (slime-typeout-active-p) + (save-selected-window + (select-window slime-typeout-window) + (switch-to-buffer (slime-typeout-buffer))) + (slime-make-typeout-frame))) + +(defun slime-typeout-wrap-autodoc () + (setq eldoc-message-function 'slime-typeout-message-aux)) + +(provide 'slime-typeout-frame) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-xref-browser.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-xref-browser.el new file mode 100644 index 0000000..45a7ad8 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-xref-browser.el @@ -0,0 +1,99 @@ +(eval-and-compile + (require 'slime)) + +(define-slime-contrib slime-xref-browser + "Xref browsing with tree-widget" + (:authors "Rui Patrocínio ") + (:license "GPL")) + + +;;;; classes browser + +(defun slime-expand-class-node (widget) + (or (widget-get widget :args) + (let ((name (widget-get widget :tag))) + (cl-loop for kid in (slime-eval `(swank:mop :subclasses ,name)) + collect `(tree-widget :tag ,kid + :expander slime-expand-class-node + :has-children t))))) + +(defun slime-browse-classes (name) + "Read the name of a class and show its subclasses." + (interactive (list (slime-read-symbol-name "Class Name: "))) + (slime-call-with-browser-setup + (slime-buffer-name :browser) (slime-current-package) "Class Browser" + (lambda () + (widget-create 'tree-widget :tag name + :expander 'slime-expand-class-node + :has-echildren t)))) + +(defvar slime-browser-map nil + "Keymap for tree widget browsers") + +(require 'tree-widget) +(unless slime-browser-map + (setq slime-browser-map (make-sparse-keymap)) + (set-keymap-parent slime-browser-map widget-keymap) + (define-key slime-browser-map "q" 'bury-buffer)) + +(defun slime-call-with-browser-setup (buffer package title fn) + (switch-to-buffer buffer) + (kill-all-local-variables) + (setq slime-buffer-package package) + (let ((inhibit-read-only t)) (erase-buffer)) + (widget-insert title "\n\n") + (save-excursion + (funcall fn)) + (lisp-mode-variables t) + (slime-mode t) + (use-local-map slime-browser-map) + (widget-setup)) + + +;;;; Xref browser + +(defun slime-fetch-browsable-xrefs (type name) + "Return a list ((LABEL DSPEC)). +LABEL is just a string for display purposes. +DSPEC can be used to expand the node." + (let ((xrefs '())) + (cl-loop for (_file . specs) in (slime-eval `(swank:xref ,type ,name)) do + (cl-loop for (dspec . _location) in specs do + (let ((exp (ignore-errors (read (downcase dspec))))) + (cond ((and (consp exp) (eq 'flet (car exp))) + ;; we can't expand FLET references so they're useless + ) + ((and (consp exp) (eq 'method (car exp))) + ;; this isn't quite right, but good enough for now + (push (list dspec (string (cl-second exp))) xrefs)) + (t + (push (list dspec dspec) xrefs)))))) + xrefs)) + +(defun slime-expand-xrefs (widget) + (or (widget-get widget :args) + (let* ((type (widget-get widget :xref-type)) + (dspec (widget-get widget :xref-dspec)) + (xrefs (slime-fetch-browsable-xrefs type dspec))) + (cl-loop for (label dspec) in xrefs + collect `(tree-widget :tag ,label + :xref-type ,type + :xref-dspec ,dspec + :expander slime-expand-xrefs + :has-children t))))) + +(defun slime-browse-xrefs (name type) + "Show the xref graph of a function in a tree widget." + (interactive + (list (slime-read-from-minibuffer "Name: " + (slime-symbol-at-point)) + (read (completing-read "Type: " (slime-bogus-completion-alist + '(":callers" ":callees" ":calls")) + nil t ":")))) + (slime-call-with-browser-setup + (slime-buffer-name :xref) (slime-current-package) "Xref Browser" + (lambda () + (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name + :expander 'slime-expand-xrefs :has-echildren t)))) + +(provide 'slime-xref-browser) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-arglists.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-arglists.lisp new file mode 100644 index 0000000..9e35add --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-arglists.lisp @@ -0,0 +1,1620 @@ +;;; swank-arglists.lisp --- arglist related code ?? +;; +;; Authors: Matthias Koeppe +;; Tobias C. Rittweiler +;; and others +;; +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-c-p-c)) + +;;;; Utilities + +(defun compose (&rest functions) + "Compose FUNCTIONS right-associatively, returning a function" + #'(lambda (x) + (reduce #'funcall functions :initial-value x :from-end t))) + +(defun length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list (do ((i n (1- i)) + (list seq (cdr list))) + ((or (<= i 0) (null list)) + (and (zerop i) (null list))))) + (sequence (= (length seq) n)))) + +(declaim (inline memq)) +(defun memq (item list) + (member item list :test #'eq)) + +(defun exactly-one-p (&rest values) + "If exactly one value in VALUES is non-NIL, this value is returned. +Otherwise NIL is returned." + (let ((found nil)) + (dolist (v values) + (when v (if found + (return-from exactly-one-p nil) + (setq found v)))) + found)) + +(defun valid-operator-symbol-p (symbol) + "Is SYMBOL the name of a function, a macro, or a special-operator?" + (or (fboundp symbol) + (macro-function symbol) + (special-operator-p symbol) + (member symbol '(declare declaim)))) + +(defun function-exists-p (form) + (and (valid-function-name-p form) + (fboundp form) + t)) + +(defmacro multiple-value-or (&rest forms) + (if (null forms) + nil + (let ((first (first forms)) + (rest (rest forms))) + `(let* ((values (multiple-value-list ,first)) + (primary-value (first values))) + (if primary-value + (values-list values) + (multiple-value-or ,@rest)))))) + +(defun arglist-available-p (arglist) + (not (eql arglist :not-available))) + +(defmacro with-available-arglist ((var &rest more-vars) form &body body) + `(multiple-value-bind (,var ,@more-vars) ,form + (if (eql ,var :not-available) + :not-available + (progn ,@body)))) + + +;;;; Arglist Definition + +(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p)) + provided-args ; list of the provided actual arguments + required-args ; list of the required arguments + optional-args ; list of the optional arguments + key-p ; whether &key appeared + keyword-args ; list of the keywords + rest ; name of the &rest or &body argument (if any) + body-p ; whether the rest argument is a &body + allow-other-keys-p ; whether &allow-other-keys appeared + aux-args ; list of &aux variables + any-p ; whether &any appeared + any-args ; list of &any arguments [*] + known-junk ; &whole, &environment + unknown-junk) ; unparsed stuff + +;;; +;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp, +;;; and is only used to describe certain arglists that cannot be +;;; described in another way. +;;; +;;; &ANY is very similiar to &KEY but while &KEY is based upon +;;; the idea of a plist (key1 value1 key2 value2), &ANY is a +;;; cross between &OPTIONAL, &KEY and *FEATURES* lists: +;;; +;;; a) (&ANY :A :B :C) means that you can provide any (non-null) +;;; set consisting of the keywords `:A', `:B', or `:C' in +;;; the arglist. E.g. (:A) or (:C :B :A). +;;; +;;; (This is not restricted to keywords only, but any self-evaluating +;;; expression is allowed.) +;;; +;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can +;;; provide any (non-null) set consisting of lists where +;;; the CAR of the list is one of `key1', `key2', or `key3'. +;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23)) +;;; +;;; +;;; For example, a) let us describe the situations of EVAL-WHEN as +;;; +;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body) +;;; +;;; and b) let us describe the optimization qualifiers that are valid +;;; in the declaration specifier `OPTIMIZE': +;;; +;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...)) +;;; + +;; This is a wrapper object around anything that came from Slime and +;; could not reliably be read. +(defstruct (arglist-dummy + (:conc-name #:arglist-dummy.) + (:constructor make-arglist-dummy (string-representation))) + string-representation) + +(defun empty-arg-p (dummy) + (and (arglist-dummy-p dummy) + (zerop (length (arglist-dummy.string-representation dummy))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter +lambda-list-keywords+ + '(&provided &required &optional &rest &key &any))) + +(defmacro do-decoded-arglist (decoded-arglist &body clauses) + (assert (loop for clause in clauses + thereis (member (car clause) +lambda-list-keywords+))) + (flet ((parse-clauses (clauses) + (let* ((size (length +lambda-list-keywords+)) + (initial (make-hash-table :test #'eq :size size)) + (main (make-hash-table :test #'eq :size size)) + (final (make-hash-table :test #'eq :size size))) + (loop for clause in clauses + for lambda-list-keyword = (first clause) + for clause-parameter = (second clause) + do + (case clause-parameter + (:initially + (setf (gethash lambda-list-keyword initial) clause)) + (:finally + (setf (gethash lambda-list-keyword final) clause)) + (t + (setf (gethash lambda-list-keyword main) clause))) + finally + (return (values initial main final))))) + (generate-main-clause (clause arglist) + (dcase clause + ((&provided (&optional arg) . body) + (let ((gensym (gensym "PROVIDED-ARG+"))) + `(dolist (,gensym (arglist.provided-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body)))) + ((&required (&optional arg) . body) + (let ((gensym (gensym "REQUIRED-ARG+"))) + `(dolist (,gensym (arglist.required-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body)))) + ((&optional (&optional arg init) . body) + (let ((optarg (gensym "OPTIONAL-ARG+"))) + `(dolist (,optarg (arglist.optional-args ,arglist)) + (declare (ignorable ,optarg)) + (let (,@(when arg + `((,arg (optional-arg.arg-name ,optarg)))) + ,@(when init + `((,init (optional-arg.default-arg ,optarg))))) + ,@body)))) + ((&key (&optional keyword arg init) . body) + (let ((keyarg (gensym "KEY-ARG+"))) + `(dolist (,keyarg (arglist.keyword-args ,arglist)) + (declare (ignorable ,keyarg)) + (let (,@(when keyword + `((,keyword (keyword-arg.keyword ,keyarg)))) + ,@(when arg + `((,arg (keyword-arg.arg-name ,keyarg)))) + ,@(when init + `((,init (keyword-arg.default-arg ,keyarg))))) + ,@body)))) + ((&rest (&optional arg body-p) . body) + `(when (arglist.rest ,arglist) + (let (,@(when arg `((,arg (arglist.rest ,arglist)))) + ,@(when body-p `((,body-p (arglist.body-p ,arglist))))) + ,@body))) + ((&any (&optional arg) . body) + (let ((gensym (gensym "REQUIRED-ARG+"))) + `(dolist (,gensym (arglist.any-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body))))))) + (let ((arglist (gensym "DECODED-ARGLIST+"))) + (multiple-value-bind (initially-clauses main-clauses finally-clauses) + (parse-clauses clauses) + `(let ((,arglist ,decoded-arglist)) + (block do-decoded-arglist + ,@(loop for keyword in '(&provided &required + &optional &rest &key &any) + append (cddr (gethash keyword initially-clauses)) + collect (let ((clause (gethash keyword main-clauses))) + (when clause + (generate-main-clause clause arglist))) + append (cddr (gethash keyword finally-clauses))))))))) + +;;;; Arglist Printing + +(defun undummy (x) + (if (typep x 'arglist-dummy) + (arglist-dummy.string-representation x) + (prin1-to-string x))) + +(defun print-decoded-arglist (arglist &key operator provided-args highlight) + (let ((first-space-after-operator (and operator t))) + (macrolet ((space () + ;; Kludge: When OPERATOR is not given, we don't want to + ;; print a space for the first argument. + `(if (not operator) + (setq operator t) + (progn (write-char #\space) + (if first-space-after-operator + (setq first-space-after-operator nil) + (pprint-newline :fill))))) + (with-highlighting ((&key index) &body body) + `(if (eql ,index (car highlight)) + (progn (princ "===> ") ,@body (princ " <===")) + (progn ,@body))) + (print-arglist-recursively (argl &key index) + `(if (eql ,index (car highlight)) + (print-decoded-arglist ,argl :highlight (cdr highlight)) + (print-decoded-arglist ,argl)))) + (let ((index 0)) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (when operator + (print-arg operator) + (pprint-indent :current 1)) ; 1 due to possibly added space + (do-decoded-arglist (remove-given-args arglist provided-args) + (&provided (arg) + (space) + (print-arg arg :literal-strings t) + (incf index)) + (&required (arg) + (space) + (if (arglist-p arg) + (print-arglist-recursively arg :index index) + (with-highlighting (:index index) + (print-arg arg))) + (incf index)) + (&optional :initially + (when (arglist.optional-args arglist) + (space) + (princ '&optional))) + (&optional (arg init-value) + (space) + (if (arglist-p arg) + (print-arglist-recursively arg :index index) + (with-highlighting (:index index) + (if (null init-value) + (print-arg arg) + (format t "~:@<~A ~A~@:>" + (undummy arg) (undummy init-value))))) + (incf index)) + (&key :initially + (when (arglist.key-p arglist) + (space) + (princ '&key))) + (&key (keyword arg init) + (space) + (if (arglist-p arg) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (prin1 keyword) (space) + (print-arglist-recursively arg :index keyword)) + (with-highlighting (:index keyword) + (cond ((and init (keywordp keyword)) + (format t "~:@<~A ~A~@:>" keyword (undummy init))) + (init + (format t "~:@<(~A ..) ~A~@:>" + (undummy keyword) (undummy init))) + ((not (keywordp keyword)) + (format t "~:@<(~S ..)~@:>" keyword)) + (t + (princ keyword)))))) + (&key :finally + (when (arglist.allow-other-keys-p arglist) + (space) + (princ '&allow-other-keys))) + (&any :initially + (when (arglist.any-p arglist) + (space) + (princ '&any))) + (&any (arg) + (space) + (print-arg arg)) + (&rest (args bodyp) + (space) + (princ (if bodyp '&body '&rest)) + (space) + (if (arglist-p args) + (print-arglist-recursively args :index index) + (with-highlighting (:index index) + (print-arg args)))) + ;; FIXME: add &UNKNOWN-JUNK? + )))))) + +(defun print-arg (arg &key literal-strings) + (let ((arg (if (arglist-dummy-p arg) + (arglist-dummy.string-representation arg) + arg))) + (if (or + (and literal-strings + (stringp arg)) + (keywordp arg)) + (prin1 arg) + (princ arg)))) + +(defun print-decoded-arglist-as-template (decoded-arglist &key + (prefix "(") (suffix ")")) + (let ((first-p t)) + (flet ((space () + (unless first-p + (write-char #\space)) + (setq first-p nil)) + (print-arg-or-pattern (arg) + (etypecase arg + (symbol (if (keywordp arg) (prin1 arg) (princ arg))) + (string (princ arg)) + (list (princ arg)) + (arglist-dummy (princ + (arglist-dummy.string-representation arg))) + (arglist (print-decoded-arglist-as-template arg))) + (pprint-newline :fill))) + (pprint-logical-block (nil nil :prefix prefix :suffix suffix) + (do-decoded-arglist decoded-arglist + (&provided ()) ; do nothing; provided args are in the buffer already. + (&required (arg) + (space) (print-arg-or-pattern arg)) + (&optional (arg) + (space) (princ "[") (print-arg-or-pattern arg) (princ "]")) + (&key (keyword arg) + (space) + (prin1 (if (keywordp keyword) keyword `',keyword)) + (space) + (print-arg-or-pattern arg) + (pprint-newline :linear)) + (&any (arg) + (space) (print-arg-or-pattern arg)) + (&rest (args) + (when (or (not (arglist.keyword-args decoded-arglist)) + (arglist.allow-other-keys-p decoded-arglist)) + (space) + (format t "~A..." args)))))))) + +(defvar *arglist-pprint-bindings* + '((*print-case* . :downcase) + (*print-pretty* . t) + (*print-circle* . nil) + (*print-readably* . nil) + (*print-level* . 10) + (*print-length* . 20) + (*print-escape* . nil))) + +(defvar *arglist-show-packages* t) + +(defmacro with-arglist-io-syntax (&body body) + (let ((package (gensym))) + `(let ((,package *package*)) + (with-standard-io-syntax + (let ((*package* (if *arglist-show-packages* + *package* + ,package))) + (with-bindings *arglist-pprint-bindings* + ,@body)))))) + +(defun decoded-arglist-to-string (decoded-arglist + &key operator highlight + print-right-margin) + (with-output-to-string (*standard-output*) + (with-arglist-io-syntax + (let ((*print-right-margin* print-right-margin)) + (print-decoded-arglist decoded-arglist + :operator operator + :highlight highlight))))) + +(defun decoded-arglist-to-template-string (decoded-arglist + &key (prefix "(") (suffix ")")) + (with-output-to-string (*standard-output*) + (with-arglist-io-syntax + (print-decoded-arglist-as-template decoded-arglist + :prefix prefix + :suffix suffix)))) + +;;;; Arglist Decoding / Encoding + +(defun decode-required-arg (arg) + "ARG can be a symbol or a destructuring pattern." + (etypecase arg + (symbol arg) + (arglist-dummy arg) + (list (decode-arglist arg)))) + +(defun encode-required-arg (arg) + (etypecase arg + (symbol arg) + (arglist (encode-arglist arg)))) + +(defstruct (keyword-arg + (:conc-name keyword-arg.) + (:constructor %make-keyword-arg)) + keyword + arg-name + default-arg) + +(defun canonicalize-default-arg (form) + (if (equalp ''nil form) + nil + form)) + +(defun make-keyword-arg (keyword arg-name default-arg) + (%make-keyword-arg :keyword keyword + :arg-name arg-name + :default-arg (canonicalize-default-arg default-arg))) + +(defun decode-keyword-arg (arg) + "Decode a keyword item of formal argument list. +Return three values: keyword, argument name, default arg." + (flet ((intern-as-keyword (arg) + (intern (etypecase arg + (symbol (symbol-name arg)) + (arglist-dummy (arglist-dummy.string-representation arg))) + keyword-package))) + (cond ((or (symbolp arg) (arglist-dummy-p arg)) + (make-keyword-arg (intern-as-keyword arg) arg nil)) + ((and (consp arg) + (consp (car arg))) + (make-keyword-arg (caar arg) + (decode-required-arg (cadar arg)) + (cadr arg))) + ((consp arg) + (make-keyword-arg (intern-as-keyword (car arg)) + (car arg) (cadr arg))) + (t + (error "Bad keyword item of formal argument list"))))) + +(defun encode-keyword-arg (arg) + (cond + ((arglist-p (keyword-arg.arg-name arg)) + ;; Destructuring pattern + (let ((keyword/name (list (keyword-arg.keyword arg) + (encode-required-arg + (keyword-arg.arg-name arg))))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))) + ((eql (intern (symbol-name (keyword-arg.arg-name arg)) + keyword-package) + (keyword-arg.keyword arg)) + (if (keyword-arg.default-arg arg) + (list (keyword-arg.arg-name arg) + (keyword-arg.default-arg arg)) + (keyword-arg.arg-name arg))) + (t + (let ((keyword/name (list (keyword-arg.keyword arg) + (keyword-arg.arg-name arg)))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))))) + +(progn + (assert (equalp (decode-keyword-arg 'x) + (make-keyword-arg :x 'x nil))) + (assert (equalp (decode-keyword-arg '(x t)) + (make-keyword-arg :x 'x t))) + (assert (equalp (decode-keyword-arg '((:x y))) + (make-keyword-arg :x 'y nil))) + (assert (equalp (decode-keyword-arg '((:x y) t)) + (make-keyword-arg :x 'y t)))) + +;;; FIXME suppliedp? +(defstruct (optional-arg + (:conc-name optional-arg.) + (:constructor %make-optional-arg)) + arg-name + default-arg) + +(defun make-optional-arg (arg-name default-arg) + (%make-optional-arg :arg-name arg-name + :default-arg (canonicalize-default-arg default-arg))) + +(defun decode-optional-arg (arg) + "Decode an optional item of a formal argument list. +Return an OPTIONAL-ARG structure." + (etypecase arg + (symbol (make-optional-arg arg nil)) + (arglist-dummy (make-optional-arg arg nil)) + (list (make-optional-arg (decode-required-arg (car arg)) + (cadr arg))))) + +(defun encode-optional-arg (optional-arg) + (if (or (optional-arg.default-arg optional-arg) + (arglist-p (optional-arg.arg-name optional-arg))) + (list (encode-required-arg + (optional-arg.arg-name optional-arg)) + (optional-arg.default-arg optional-arg)) + (optional-arg.arg-name optional-arg))) + +(progn + (assert (equalp (decode-optional-arg 'x) + (make-optional-arg 'x nil))) + (assert (equalp (decode-optional-arg '(x t)) + (make-optional-arg 'x t)))) + +(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.") + +(defun decode-arglist (arglist) + "Parse the list ARGLIST and return an ARGLIST structure." + (etypecase arglist + ((eql :not-available) (return-from decode-arglist + :not-available)) + (list)) + (loop + with mode = nil + with result = (make-arglist) + for arg = (if (consp arglist) + (pop arglist) + (progn + (prog1 arglist + (setf mode '&rest + arglist nil)))) + do (cond + ((eql mode '&unknown-junk) + ;; don't leave this mode -- we don't know how the arglist + ;; after unknown lambda-list keywords is interpreted + (push arg (arglist.unknown-junk result))) + ((eql arg '&allow-other-keys) + (setf (arglist.allow-other-keys-p result) t)) + ((eql arg '&key) + (setf (arglist.key-p result) t + mode arg)) + ((memq arg '(&optional &rest &body &aux)) + (setq mode arg)) + ((memq arg '(&whole &environment)) + (setq mode arg) + (push arg (arglist.known-junk result))) + ((and (symbolp arg) + (string= (symbol-name arg) (string '#:&any))) ; may be interned + (setf (arglist.any-p result) t) ; in any *package*. + (setq mode '&any)) + ((memq arg lambda-list-keywords) + (setq mode '&unknown-junk) + (push arg (arglist.unknown-junk result))) + (t + (ecase mode + (&key + (push (decode-keyword-arg arg) + (arglist.keyword-args result))) + (&optional + (push (decode-optional-arg arg) + (arglist.optional-args result))) + (&body + (setf (arglist.body-p result) t + (arglist.rest result) arg)) + (&rest + (setf (arglist.rest result) arg)) + (&aux + (push (decode-optional-arg arg) + (arglist.aux-args result))) + ((nil) + (push (decode-required-arg arg) + (arglist.required-args result))) + ((&whole &environment) + (setf mode nil) + (push arg (arglist.known-junk result))) + (&any + (push arg (arglist.any-args result)))))) + until (null arglist) + finally (nreversef (arglist.required-args result)) + finally (nreversef (arglist.optional-args result)) + finally (nreversef (arglist.keyword-args result)) + finally (nreversef (arglist.aux-args result)) + finally (nreversef (arglist.any-args result)) + finally (nreversef (arglist.known-junk result)) + finally (nreversef (arglist.unknown-junk result)) + finally (assert (or (and (not (arglist.key-p result)) + (not (arglist.any-p result))) + (exactly-one-p (arglist.key-p result) + (arglist.any-p result)))) + finally (return result))) + +(defun encode-arglist (decoded-arglist) + (append (mapcar #'encode-required-arg + (arglist.required-args decoded-arglist)) + (when (arglist.optional-args decoded-arglist) + '(&optional)) + (mapcar #'encode-optional-arg + (arglist.optional-args decoded-arglist)) + (when (arglist.key-p decoded-arglist) + '(&key)) + (mapcar #'encode-keyword-arg + (arglist.keyword-args decoded-arglist)) + (when (arglist.allow-other-keys-p decoded-arglist) + '(&allow-other-keys)) + (when (arglist.any-args decoded-arglist) + `(&any ,@(arglist.any-args decoded-arglist))) + (cond ((not (arglist.rest decoded-arglist)) + '()) + ((arglist.body-p decoded-arglist) + `(&body ,(arglist.rest decoded-arglist))) + (t + `(&rest ,(arglist.rest decoded-arglist)))) + (when (arglist.aux-args decoded-arglist) + `(&aux ,(arglist.aux-args decoded-arglist))) + (arglist.known-junk decoded-arglist) + (arglist.unknown-junk decoded-arglist))) + +;;;; Arglist Enrichment + +(defun arglist-keywords (lambda-list) + "Return the list of keywords in ARGLIST. +As a secondary value, return whether &allow-other-keys appears." + (let ((decoded-arglist (decode-arglist lambda-list))) + (values (arglist.keyword-args decoded-arglist) + (arglist.allow-other-keys-p decoded-arglist)))) + + +(defun methods-keywords (methods) + "Collect all keywords in the arglists of METHODS. +As a secondary value, return whether &allow-other-keys appears somewhere." + (let ((keywords '()) + (allow-other-keys nil)) + (dolist (method methods) + (multiple-value-bind (kw aok) + (arglist-keywords + (swank-mop:method-lambda-list method)) + (setq keywords (remove-duplicates (append keywords kw) + :key #'keyword-arg.keyword) + allow-other-keys (or allow-other-keys aok)))) + (values keywords allow-other-keys))) + +(defun generic-function-keywords (generic-function) + "Collect all keywords in the methods of GENERIC-FUNCTION. +As a secondary value, return whether &allow-other-keys appears somewhere." + (methods-keywords + (swank-mop:generic-function-methods generic-function))) + +(defun applicable-methods-keywords (generic-function arguments) + "Collect all keywords in the methods of GENERIC-FUNCTION that are +applicable for argument of CLASSES. As a secondary value, return +whether &allow-other-keys appears somewhere." + (methods-keywords + (multiple-value-bind (amuc okp) + (swank-mop:compute-applicable-methods-using-classes + generic-function (mapcar #'class-of arguments)) + (if okp + amuc + (compute-applicable-methods generic-function arguments))))) + +(defgeneric extra-keywords (operator args) + (:documentation "Return a list of extra keywords of OPERATOR (a +symbol) when applied to the (unevaluated) ARGS. +As a secondary value, return whether other keys are allowed. +As a tertiary value, return the initial sublist of ARGS that was needed +to determine the extra keywords.")) + +;;; We make sure that symbol-from-KEYWORD-using keywords come before +;;; symbol-from-arbitrary-package-using keywords. And we sort the +;;; latter according to how their home-packages relate to *PACKAGE*. +;;; +;;; Rationale is to show those key parameters first which make most +;;; sense in the current context. And in particular: to put +;;; implementation-internal stuff last. +;;; +;;; This matters tremendeously on Allegro in combination with +;;; AllegroCache as that does some evil tinkering with initargs, +;;; obfuscating the arglist of MAKE-INSTANCE. +;;; + +(defmethod extra-keywords :around (op args) + (declare (ignorable op args)) + (multiple-value-bind (keywords aok enrichments) (call-next-method) + (values (sort-extra-keywords keywords) aok enrichments))) + +(defun make-package-comparator (reference-packages) + "Returns a two-argument test function which compares packages +according to their used-by relation with REFERENCE-PACKAGES. Packages +will be sorted first which appear first in the PACKAGE-USE-LIST of the +reference packages." + (let ((package-use-table (make-hash-table :test 'eq))) + ;; Walk the package dependency graph breadth-fist, and fill + ;; PACKAGE-USE-TABLE accordingly. + (loop with queue = (copy-list reference-packages) + with bfn = 0 ; Breadth-First Number + for p = (pop queue) + unless (gethash p package-use-table) + do (setf (gethash p package-use-table) (shiftf bfn (1+ bfn))) + and do (setf queue (nconc queue (copy-list (package-use-list p)))) + while queue) + #'(lambda (p1 p2) + (let ((bfn1 (gethash p1 package-use-table)) + (bfn2 (gethash p2 package-use-table))) + (cond ((and bfn1 bfn2) (<= bfn1 bfn2)) + (bfn1 bfn1) + (bfn2 nil) ; p2 is used, p1 not + (t (string<= (package-name p1) (package-name p2)))))))) + +(defun sort-extra-keywords (kwds) + (stable-sort kwds (make-package-comparator (list keyword-package *package*)) + :key (compose #'symbol-package #'keyword-arg.keyword))) + +(defun keywords-of-operator (operator) + "Return a list of KEYWORD-ARGs that OPERATOR accepts. +This function is useful for writing EXTRA-KEYWORDS methods for +user-defined functions which are declared &ALLOW-OTHER-KEYS and which +forward keywords to OPERATOR." + (with-available-arglist (arglist) (arglist-from-form (ensure-list operator)) + (values (arglist.keyword-args arglist) + (arglist.allow-other-keys-p arglist)))) + +(defmethod extra-keywords (operator args) + ;; default method + (declare (ignore args)) + (let ((symbol-function (symbol-function operator))) + (if (typep symbol-function 'generic-function) + (generic-function-keywords symbol-function) + nil))) + +(defun class-from-class-name-form (class-name-form) + (when (and (listp class-name-form) + (= (length class-name-form) 2) + (eq (car class-name-form) 'quote)) + (let* ((class-name (cadr class-name-form)) + (class (find-class class-name nil))) + (when (and class + (not (swank-mop:class-finalized-p class))) + ;; Try to finalize the class, which can fail if + ;; superclasses are not defined yet + (ignore-errors (swank-mop:finalize-inheritance class))) + class))) + +(defun extra-keywords/slots (class) + (multiple-value-bind (slots allow-other-keys-p) + (if (swank-mop:class-finalized-p class) + (values (swank-mop:class-slots class) nil) + (values (swank-mop:class-direct-slots class) t)) + (let ((slot-init-keywords + (loop for slot in slots append + (mapcar (lambda (initarg) + (make-keyword-arg + initarg + (swank-mop:slot-definition-name slot) + (and (swank-mop:slot-definition-initfunction slot) + (swank-mop:slot-definition-initform slot)))) + (swank-mop:slot-definition-initargs slot))))) + (values slot-init-keywords allow-other-keys-p)))) + +(defun extra-keywords/make-instance (operator args) + (declare (ignore operator)) + (unless (null args) + (let* ((class-name-form (car args)) + (class (class-from-class-name-form class-name-form))) + (when class + (multiple-value-bind (slot-init-keywords class-aokp) + (extra-keywords/slots class) + (multiple-value-bind (allocate-instance-keywords ai-aokp) + (applicable-methods-keywords + #'allocate-instance (list class)) + (multiple-value-bind (initialize-instance-keywords ii-aokp) + (ignore-errors + (applicable-methods-keywords + #'initialize-instance + (list (swank-mop:class-prototype class)))) + (multiple-value-bind (shared-initialize-keywords si-aokp) + (ignore-errors + (applicable-methods-keywords + #'shared-initialize + (list (swank-mop:class-prototype class) t))) + (values (append slot-init-keywords + allocate-instance-keywords + initialize-instance-keywords + shared-initialize-keywords) + (or class-aokp ai-aokp ii-aokp si-aokp) + (list class-name-form)))))))))) + +(defun extra-keywords/change-class (operator args) + (declare (ignore operator)) + (unless (null args) + (let* ((class-name-form (car args)) + (class (class-from-class-name-form class-name-form))) + (when class + (multiple-value-bind (slot-init-keywords class-aokp) + (extra-keywords/slots class) + (declare (ignore class-aokp)) + (multiple-value-bind (shared-initialize-keywords si-aokp) + (ignore-errors + (applicable-methods-keywords + #'shared-initialize + (list (swank-mop:class-prototype class) t))) + ;; FIXME: much as it would be nice to include the + ;; applicable keywords from + ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see + ;; how to do it: so we punt, always declaring + ;; &ALLOW-OTHER-KEYS. + (declare (ignore si-aokp)) + (values (append slot-init-keywords shared-initialize-keywords) + t + (list class-name-form)))))))) + +(defmethod extra-keywords ((operator (eql 'make-instance)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'make-condition)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'error)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'signal)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'warn)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'cerror)) + args) + (multiple-value-bind (keywords aok determiners) + (extra-keywords/make-instance operator (cdr args)) + (if keywords + (values keywords aok + (cons (car args) determiners)) + (call-next-method)))) + +(defmethod extra-keywords ((operator (eql 'change-class)) + args) + (multiple-value-bind (keywords aok determiners) + (extra-keywords/change-class operator (cdr args)) + (if keywords + (values keywords aok + (cons (car args) determiners)) + (call-next-method)))) + +(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords + allow-other-keys-p) + "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P." + (when keywords + (setf (arglist.key-p decoded-arglist) t) + (setf (arglist.keyword-args decoded-arglist) + (remove-duplicates + (append (arglist.keyword-args decoded-arglist) + keywords) + :key #'keyword-arg.keyword))) + (setf (arglist.allow-other-keys-p decoded-arglist) + (or (arglist.allow-other-keys-p decoded-arglist) + allow-other-keys-p))) + +(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form) + "Determine extra keywords from the function call FORM, and modify +DECODED-ARGLIST to include them. As a secondary return value, return +the initial sublist of ARGS that was needed to determine the extra +keywords. As a tertiary return value, return whether any enrichment +was done." + (multiple-value-bind (extra-keywords extra-aok determining-args) + (extra-keywords (car form) (cdr form)) + ;; enrich the list of keywords with the extra keywords + (enrich-decoded-arglist-with-keywords decoded-arglist + extra-keywords extra-aok) + (values decoded-arglist + determining-args + (or extra-keywords extra-aok)))) + +(defgeneric compute-enriched-decoded-arglist (operator-form argument-forms) + (:documentation + "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and +ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords. +If the arglist is not available, return :NOT-AVAILABLE.")) + +(defmethod compute-enriched-decoded-arglist (operator-form argument-forms) + (with-available-arglist (decoded-arglist) + (decode-arglist (arglist operator-form)) + (enrich-decoded-arglist-with-extra-keywords decoded-arglist + (cons operator-form + argument-forms)))) + +(defmethod compute-enriched-decoded-arglist + ((operator-form (eql 'with-open-file)) argument-forms) + (declare (ignore argument-forms)) + (multiple-value-bind (decoded-arglist determining-args) + (call-next-method) + (let ((first-arg (first (arglist.required-args decoded-arglist))) + (open-arglist (compute-enriched-decoded-arglist 'open nil))) + (when (and (arglist-p first-arg) (arglist-p open-arglist)) + (enrich-decoded-arglist-with-keywords + first-arg + (arglist.keyword-args open-arglist) + nil))) + (values decoded-arglist determining-args t))) + +(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply)) + argument-forms) + (let ((function-name-form (car argument-forms))) + (when (and (listp function-name-form) + (length= function-name-form 2) + (memq (car function-name-form) '(quote function))) + (let ((function-name (cadr function-name-form))) + (when (valid-operator-symbol-p function-name) + (let ((function-arglist + (compute-enriched-decoded-arglist function-name + (cdr argument-forms)))) + (return-from compute-enriched-decoded-arglist + (values + (make-arglist :required-args + (list 'function) + :optional-args + (append + (mapcar #'(lambda (arg) + (make-optional-arg arg nil)) + (arglist.required-args function-arglist)) + (arglist.optional-args function-arglist)) + :key-p + (arglist.key-p function-arglist) + :keyword-args + (arglist.keyword-args function-arglist) + :rest + 'args + :allow-other-keys-p + (arglist.allow-other-keys-p function-arglist)) + (list function-name-form) + t))))))) + (call-next-method)) + +(defmethod compute-enriched-decoded-arglist + ((operator-form (eql 'multiple-value-call)) argument-forms) + (compute-enriched-decoded-arglist 'apply argument-forms)) + +(defun delete-given-args (decoded-arglist args) + "Delete given ARGS from DECODED-ARGLIST." + (macrolet ((pop-or-return (list) + `(if (null ,list) + (return-from do-decoded-arglist) + (pop ,list)))) + (do-decoded-arglist decoded-arglist + (&provided () + (assert (eq (pop-or-return args) + (pop (arglist.provided-args decoded-arglist))))) + (&required () + (pop-or-return args) + (pop (arglist.required-args decoded-arglist))) + (&optional () + (pop-or-return args) + (pop (arglist.optional-args decoded-arglist))) + (&key (keyword) + ;; N.b. we consider a keyword to be given only when the keyword + ;; _and_ a value has been given for it. + (loop for (key value) on args by #'cddr + when (and (eq keyword key) value) + do (setf (arglist.keyword-args decoded-arglist) + (remove keyword (arglist.keyword-args decoded-arglist) + :key #'keyword-arg.keyword)))))) + decoded-arglist) + +(defun remove-given-args (decoded-arglist args) + ;; FIXME: We actually needa deep copy here. + (delete-given-args (copy-arglist decoded-arglist) args)) + +;;;; Arglist Retrieval + +(defun arglist-from-form (form) + (if (null form) + :not-available + (arglist-dispatch (car form) (cdr form)))) + +(export 'arglist-dispatch) +(defgeneric arglist-dispatch (operator arguments) + ;; Default method + (:method (operator arguments) + (unless (and (symbolp operator) (valid-operator-symbol-p operator)) + (return-from arglist-dispatch :not-available)) + (when (equalp (package-name (symbol-package operator)) "closer-mop") + (let ((standard-symbol (or (find-symbol (symbol-name operator) :cl) + (find-symbol (symbol-name operator) :swank-mop)))) + (when standard-symbol + (return-from arglist-dispatch + (arglist-dispatch standard-symbol arguments))))) + + (multiple-value-bind (decoded-arglist determining-args) + (compute-enriched-decoded-arglist operator arguments) + (with-available-arglist (arglist) decoded-arglist + ;; replace some formal args by determining actual args + (setf arglist (delete-given-args arglist determining-args)) + (setf (arglist.provided-args arglist) determining-args) + arglist)))) + +(defmethod arglist-dispatch ((operator (eql 'defmethod)) arguments) + (match (cons operator arguments) + (('defmethod (#'function-exists-p gf-name) . rest) + (let ((gf (fdefinition gf-name))) + (when (typep gf 'generic-function) + (with-available-arglist (arglist) (decode-arglist (arglist gf)) + (let ((qualifiers (loop for x in rest + until (or (listp x) (empty-arg-p x)) + collect x))) + (return-from arglist-dispatch + (make-arglist :provided-args (cons gf-name qualifiers) + :required-args (list arglist) + :rest "body" :body-p t))))))) + (_)) ; Fall through + (call-next-method)) + +(defmethod arglist-dispatch ((operator (eql 'define-compiler-macro)) arguments) + (match (cons operator arguments) + (('define-compiler-macro (#'function-exists-p gf-name) . _) + (let ((gf (fdefinition gf-name))) + (with-available-arglist (arglist) (decode-arglist (arglist gf)) + (return-from arglist-dispatch + (make-arglist :provided-args (list gf-name) + :required-args (list arglist) + :rest "body" :body-p t))))) + (_)) ; Fall through + (call-next-method)) + + +(defmethod arglist-dispatch ((operator (eql 'eval-when)) arguments) + (declare (ignore arguments)) + (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute))) + (make-arglist + :required-args (list (make-arglist :any-p t :any-args eval-when-args)) + :rest '#:body :body-p t))) + + +(defmethod arglist-dispatch ((operator (eql 'declare)) arguments) + (let* ((declaration (cons operator (last arguments))) + (typedecl-arglist (arglist-for-type-declaration declaration))) + (if (arglist-available-p typedecl-arglist) + typedecl-arglist + (match declaration + (('declare ((#'consp typespec) . decl-args)) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :required-args (list typespec-arglist) + :rest '#:variables))))) + (('declare (decl-identifier . decl-args)) + (decoded-arglist-for-declaration decl-identifier decl-args)) + (_ (make-arglist :rest '#:declaration-specifiers)))))) + +(defmethod arglist-dispatch ((operator (eql 'declaim)) arguments) + (arglist-dispatch 'declare arguments)) + + +(defun arglist-for-type-declaration (declaration) + (flet ((%arglist-for-type-declaration (identifier typespec rest-var-name) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :provided-args (list identifier) + :required-args (list typespec-arglist) + :rest rest-var-name)))))) + (match declaration + (('declare ('type (#'consp typespec) . decl-args)) + (%arglist-for-type-declaration 'type typespec '#:variables)) + (('declare ('ftype (#'consp typespec) . decl-args)) + (%arglist-for-type-declaration 'ftype typespec '#:function-names)) + (('declare ((#'consp typespec) . decl-args)) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :required-args (list typespec-arglist) + :rest '#:variables))))) + (_ :not-available)))) + +(defun decoded-arglist-for-declaration (decl-identifier decl-args) + (declare (ignore decl-args)) + (with-available-arglist (arglist) + (decode-arglist (declaration-arglist decl-identifier)) + (setf (arglist.provided-args arglist) (list decl-identifier)) + (make-arglist :required-args (list arglist)))) + +(defun decoded-arglist-for-type-specifier (type-specifier) + (etypecase type-specifier + (arglist-dummy :not-available) + (cons (decoded-arglist-for-type-specifier (car type-specifier))) + (symbol + (with-available-arglist (arglist) + (decode-arglist (type-specifier-arglist type-specifier)) + (setf (arglist.provided-args arglist) (list type-specifier)) + arglist)))) + +;;; Slimefuns + +;;; We work on a RAW-FORM, or BUFFER-FORM, which represent the form at +;;; user's point in Emacs. A RAW-FORM looks like +;;; +;;; ("FOO" ("BAR" ...) "QUUX" ("ZURP" SWANK::%CURSOR-MARKER%)) +;;; +;;; The expression before the cursor marker is the expression where +;;; user's cursor points at. An explicit marker is necessary to +;;; disambiguate between +;;; +;;; ("IF" ("PRED") +;;; ("F" "X" "Y" %CURSOR-MARKER%)) +;;; +;;; and +;;; ("IF" ("PRED") +;;; ("F" "X" "Y") %CURSOR-MARKER%) + +;;; Notice that for a form like (FOO (BAR |) QUUX), where | denotes +;;; user's point, the following should be sent ("FOO" ("BAR" "" +;;; %CURSOR-MARKER%)). Only the forms up to point should be +;;; considered. + +(defslimefun autodoc (raw-form &key print-right-margin) + "Return a list of two elements. +First, a string representing the arglist for the deepest subform in +RAW-FORM that does have an arglist. The highlighted parameter is +wrapped in ===> X <===. + +Second, a boolean value telling whether the returned string can be cached." + (handler-bind ((serious-condition + #'(lambda (c) + (unless (debug-on-swank-error) + (let ((*print-right-margin* print-right-margin)) + (return-from autodoc + (format nil "Arglist Error: \"~A\"" c))))))) + (with-buffer-syntax () + (multiple-value-bind (form arglist obj-at-cursor form-path) + (find-subform-with-arglist (parse-raw-form raw-form)) + (cond ((boundp-and-interesting obj-at-cursor) + (list (print-variable-to-string obj-at-cursor) nil)) + (t + (list + (with-available-arglist (arglist) arglist + (decoded-arglist-to-string + arglist + :print-right-margin print-right-margin + :operator (car form) + :highlight (form-path-to-arglist-path form-path + form + arglist))) + t))))))) + +(defun boundp-and-interesting (symbol) + (and symbol + (symbolp symbol) + (boundp symbol) + (not (memq symbol '(cl:t cl:nil))) + (not (keywordp symbol)))) + +(defun print-variable-to-string (symbol) + "Return a short description of VARIABLE-NAME, or NIL." + (let ((*print-pretty* t) (*print-level* 4) + (*print-length* 10) (*print-lines* 1) + (*print-readably* nil) + (value (symbol-value symbol))) + (call/truncated-output-to-string + 75 (lambda (s) + (without-printing-errors (:object value :stream s) + (format s "~A ~A~S" symbol *echo-area-prefix* value)))))) + + +(defslimefun complete-form (raw-form) + "Read FORM-STRING in the current buffer package, then complete it + by adding a template for the missing arguments." + ;; We do not catch errors here because COMPLETE-FORM is an + ;; interactive command, not automatically run in the background like + ;; ARGLIST-FOR-ECHO-AREA. + (with-buffer-syntax () + (multiple-value-bind (arglist provided-args) + (find-immediately-containing-arglist (parse-raw-form raw-form)) + (with-available-arglist (arglist) arglist + (decoded-arglist-to-template-string + (delete-given-args arglist + (remove-if #'empty-arg-p provided-args + :from-end t :count 1)) + :prefix "" :suffix ""))))) + +(defslimefun completions-for-keyword (keyword-string raw-form) + "Return a list of possible completions for KEYWORD-STRING relative +to the context provided by RAW-FORM." + (with-buffer-syntax () + (let ((arglist (find-immediately-containing-arglist + (parse-raw-form raw-form)))) + (when (arglist-available-p arglist) + ;; It would be possible to complete keywords only if we are in + ;; a keyword position, but it is not clear if we want that. + (let* ((keywords + (append (mapcar #'keyword-arg.keyword + (arglist.keyword-args arglist)) + (remove-if-not #'keywordp (arglist.any-args arglist)))) + (keyword-name + (tokenize-symbol keyword-string)) + (matching-keywords + (find-matching-symbols-in-list + keyword-name keywords (make-compound-prefix-matcher #\-))) + (converter (completion-output-symbol-converter keyword-string)) + (strings + (mapcar converter + (mapcar #'symbol-name matching-keywords))) + (completion-set + (format-completion-set strings nil ""))) + (list completion-set + (longest-compound-prefix completion-set))))))) + +(defparameter +cursor-marker+ '%cursor-marker%) + +(defun find-subform-with-arglist (form) + "Returns four values: + + The appropriate subform of `form' which is closest to the + +CURSOR-MARKER+ and whose operator is valid and has an + arglist. The +CURSOR-MARKER+ is removed from that subform. + + Second value is the arglist. Local function and macro definitions + appearing in `form' into account. + + Third value is the object in front of +CURSOR-MARKER+. + + Fourth value is a form path to that object." + (labels + ((yield-success (form local-ops) + (multiple-value-bind (form obj-at-cursor form-path) + (extract-cursor-marker form) + (values form + (let ((entry (assoc (car form) local-ops :test #'op=))) + (if entry + (decode-arglist (cdr entry)) + (arglist-from-form form))) + obj-at-cursor + form-path))) + (yield-failure () + (values nil :not-available)) + (operator-p (operator local-ops) + (or (and (symbolp operator) (valid-operator-symbol-p operator)) + (assoc operator local-ops :test #'op=))) + (op= (op1 op2) + (cond ((and (symbolp op1) (symbolp op2)) + (eq op1 op2)) + ((and (arglist-dummy-p op1) (arglist-dummy-p op2)) + (string= (arglist-dummy.string-representation op1) + (arglist-dummy.string-representation op2))))) + (grovel-form (form local-ops) + "Descend FORM top-down, always taking the rightest branch, + until +CURSOR-MARKER+." + (assert (listp form)) + (destructuring-bind (operator . args) form + ;; N.b. the user's cursor is at the rightmost, deepest + ;; subform right before +CURSOR-MARKER+. + (let ((last-subform (car (last form))) + (new-ops)) + (cond + ((eq last-subform +cursor-marker+) + (if (operator-p operator local-ops) + (yield-success form local-ops) + (yield-failure))) + ((not (operator-p operator local-ops)) + (grovel-form last-subform local-ops)) + ;; Make sure to pick up the arglists of local + ;; function/macro definitions. + ((setq new-ops (extract-local-op-arglists operator args)) + (multiple-value-or (grovel-form last-subform + (nconc new-ops local-ops)) + (yield-success form local-ops))) + ;; Some typespecs clash with function names, so we make + ;; sure to bail out early. + ((member operator '(cl:declare cl:declaim)) + (yield-success form local-ops)) + ;; Mostly uninteresting, hence skip. + ((memq operator '(cl:quote cl:function)) + (yield-failure)) + (t + (multiple-value-or (grovel-form last-subform local-ops) + (yield-success form local-ops)))))))) + (if (null form) + (yield-failure) + (grovel-form form '())))) + +(defun extract-cursor-marker (form) + "Returns three values: normalized `form' without +CURSOR-MARKER+, +the object in front of +CURSOR-MARKER+, and a form path to that +object." + (labels ((grovel (form last path) + (let ((result-form)) + (loop for (car . cdr) on form do + (cond ((eql car +cursor-marker+) + (decf (first path)) + (return-from grovel + (values (nreconc result-form cdr) + last + (nreverse path)))) + ((consp car) + (multiple-value-bind (new-car new-last new-path) + (grovel car last (cons 0 path)) + (when new-path ; CAR contained cursor-marker? + (return-from grovel + (values (nreconc + (cons new-car result-form) cdr) + new-last + new-path)))))) + (push car result-form) + (setq last car) + (incf (first path)) + finally + (return-from grovel + (values (nreverse result-form) nil nil)))))) + (grovel form nil (list 0)))) + +(defgeneric extract-local-op-arglists (operator args) + (:documentation + "If the form `(OPERATOR ,@ARGS) is a local operator binding form, + return a list of pairs (OP . ARGLIST) for each locally bound op.") + (:method (operator args) + (declare (ignore operator args)) + nil) + ;; FLET + (:method ((operator (eql 'cl:flet)) args) + (let ((defs (first args)) + (body (rest args))) + (cond ((null body) nil) ; `(flet ((foo (x) |' + ((atom defs) nil) ; `(flet ,foo (|' + (t (%collect-op/argl-alist defs))))) + ;; LABELS + (:method ((operator (eql 'cl:labels)) args) + ;; Notice that we only have information to "look backward" and + ;; show arglists of previously occuring local functions. + (destructuring-bind (defs . body) args + (unless (or (atom defs) (null body)) ; `(labels ,foo (|' + (let ((current-def (car (last defs)))) + (cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|' + ((not (null body)) + (extract-local-op-arglists 'cl:flet args)) + (t + (let ((def.body (cddr current-def))) + (when def.body + (%collect-op/argl-alist defs))))))))) + ;; MACROLET + (:method ((operator (eql 'cl:macrolet)) args) + (extract-local-op-arglists 'cl:labels args))) + +(defun %collect-op/argl-alist (defs) + (setq defs (remove-if-not #'(lambda (x) + ;; Well-formed FLET/LABELS def? + (and (consp x) (second x))) + defs)) + (loop for (name arglist . nil) in defs + collect (cons name arglist))) + +(defun find-immediately-containing-arglist (form) + "Returns the arglist of the subform _immediately_ containing ++CURSOR-MARKER+ in `form'. Notice, however, that +CURSOR-MARKER+ may +be in a nested arglist \(e.g. `(WITH-OPEN-FILE ('\), and the +arglist of the appropriate parent form \(WITH-OPEN-FILE\) will be +returned in that case." + (flet ((try (form-path form arglist) + (let* ((arglist-path (form-path-to-arglist-path form-path + form + arglist)) + (argl (apply #'arglist-ref + arglist + arglist-path)) + (args (apply #'provided-arguments-ref + (cdr form) + arglist + arglist-path))) + (when (and (arglist-p argl) (listp args)) + (values argl args))))) + (multiple-value-bind (form arglist obj form-path) + (find-subform-with-arglist form) + (declare (ignore obj)) + (with-available-arglist (arglist) arglist + ;; First try the form the cursor is in (in case of a normal + ;; form), then try the surrounding form (in case of a nested + ;; macro form). + (multiple-value-or (try form-path form arglist) + (try (butlast form-path) form arglist) + :not-available))))) + +(defun form-path-to-arglist-path (form-path form arglist) + "Convert a form path to an arglist path consisting of arglist +indices." + (labels ((convert (path args arglist) + (if (null path) + nil + (let* ((idx (car path)) + (idx* (arglist-index idx args arglist)) + (arglist* (and idx* (arglist-ref arglist idx*))) + (args* (and idx* (provided-arguments-ref args + arglist + idx*)))) + ;; The FORM-PATH may be more detailed than ARGLIST; + ;; consider (defun foo (x y) ...), a form path may + ;; point into the function's lambda-list, but the + ;; arglist of DEFUN won't contain as much information. + ;; So we only recurse if possible. + (cond ((null idx*) + nil) + ((arglist-p arglist*) + (cons idx* (convert (cdr path) args* arglist*))) + (t + (list idx*))))))) + (convert + ;; FORM contains irrelevant operator. Adjust FORM-PATH. + (cond ((null form-path) nil) + ((equal form-path '(0)) nil) + (t + (destructuring-bind (car . cdr) form-path + (cons (1- car) cdr)))) + (cdr form) + arglist))) + +(defun arglist-index (provided-argument-index provided-arguments arglist) + "Return the arglist index into `arglist' for the parameter belonging +to the argument (NTH `provided-argument-index' `provided-arguments')." + (let ((positional-args# (positional-args-number arglist)) + (arg-index provided-argument-index)) + (with-struct (arglist. key-p rest) arglist + (cond + ((< arg-index positional-args#) ; required + optional + arg-index) + ((and (not key-p) (not rest)) ; more provided than allowed + nil) + ((not key-p) ; rest + body + (assert (arglist.rest arglist)) + positional-args#) + (t ; key + ;; Find last provided &key parameter + (let* ((argument (nth arg-index provided-arguments)) + (provided-keys (subseq provided-arguments positional-args#))) + (loop for (key value) on provided-keys by #'cddr + when (eq value argument) + return (match key + (('quote symbol) symbol) + (_ key))))))))) + +(defun arglist-ref (arglist &rest indices) + "Returns the parameter in ARGLIST along the INDICIES path. Numbers +represent positional parameters (required, optional), keywords +represent key parameters." + (flet ((ref-positional-arg (arglist index) + (check-type index (integer 0 *)) + (with-struct (arglist. provided-args required-args + optional-args rest) + arglist + (loop for args in (list provided-args required-args + (mapcar #'optional-arg.arg-name + optional-args)) + for args# = (length args) + if (< index args#) + return (nth index args) + else + do (decf index args#) + finally (return (or rest nil))))) + (ref-keyword-arg (arglist keyword) + ;; keyword argument may be any symbol, + ;; not only from the KEYWORD package. + (let ((keyword (match keyword + (('quote symbol) symbol) + (_ keyword)))) + (do-decoded-arglist arglist + (&key (kw arg) (when (eq kw keyword) + (return-from ref-keyword-arg arg))))) + nil)) + (dolist (index indices) + (assert (arglist-p arglist)) + (setq arglist (if (numberp index) + (ref-positional-arg arglist index) + (ref-keyword-arg arglist index)))) + arglist)) + +(defun provided-arguments-ref (provided-args arglist &rest indices) + "Returns the argument in PROVIDED-ARGUMENT along the INDICES path +relative to ARGLIST." + (check-type arglist arglist) + (flet ((ref (provided-args arglist index) + (if (numberp index) + (nth index provided-args) + (let ((provided-keys (subseq provided-args + (positional-args-number arglist)))) + (loop for (key value) on provided-keys + when (eq key index) + return value))))) + (dolist (idx indices) + (setq provided-args (ref provided-args arglist idx)) + (setq arglist (arglist-ref arglist idx))) + provided-args)) + +(defun positional-args-number (arglist) + (+ (length (arglist.provided-args arglist)) + (length (arglist.required-args arglist)) + (length (arglist.optional-args arglist)))) + +(defun parse-raw-form (raw-form) + "Parse a RAW-FORM into a Lisp form. I.e. substitute strings by +symbols if already interned. For strings not already interned, use +ARGLIST-DUMMY." + (unless (null raw-form) + (loop for element in raw-form + collect (etypecase element + (string (read-conversatively element)) + (list (parse-raw-form element)) + (symbol (prog1 element + ;; Comes after list, so ELEMENT can't be NIL. + (assert (eq element +cursor-marker+)))))))) + +(defun read-conversatively (string) + "Tries to find the symbol that's represented by STRING. + +If it can't, this either means that STRING does not represent a +symbol, or that the symbol behind STRING would have to be freshly +interned. Because this function is supposed to be called from the +automatic arglist display stuff from Slime, interning freshly +symbols is a big no-no. + +In such a case (that no symbol could be found), an object of type +ARGLIST-DUMMY is returned instead, which works as a placeholder +datum for subsequent logics to rely on." + (let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string)) + (length (length string)) + (type (cond ((zerop length) nil) + ((eql (aref string 0) #\') + :quoted-symbol) + ((search "#'" string :end2 (min length 2)) + :sharpquoted-symbol) + ((char= (char string 0) (char string (1- length)) + #\") + :string) + (t + :symbol)))) + (multiple-value-bind (symbol found?) + (case type + (:symbol (parse-symbol string)) + (:quoted-symbol (parse-symbol (subseq string 1))) + (:sharpquoted-symbol (parse-symbol (subseq string 2))) + (:string (values string t)) + (t (values string nil))) + (if found? + (ecase type + (:symbol symbol) + (:quoted-symbol `(quote ,symbol)) + (:sharpquoted-symbol `(function ,symbol)) + (:string (if (> length 1) + (subseq string 1 (1- length)) + string))) + (make-arglist-dummy string))))) + +(defun test-print-arglist () + (flet ((test (arglist &rest strings) + (let* ((*package* (find-package :swank)) + (actual (decoded-arglist-to-string + (decode-arglist arglist) + :print-right-margin 1000))) + (unless (loop for string in strings + thereis (string= actual string)) + (warn "Test failed: ~S => ~S~% Expected: ~A" + arglist actual + (if (cdr strings) + (format nil "One of: ~{~S~^, ~}" strings) + (format nil "~S" (first strings)))))))) + (test '(function cons) "(function cons)") + (test '(quote cons) "(quote cons)") + (test '(&key (function #'+)) + "(&key (function #'+))" "(&key (function (function +)))") + (test '(&whole x y z) "(y z)") + (test '(x &aux y z) "(x)") + (test '(x &environment env y) "(x y)") + (test '(&key ((function f))) "(&key ((function ..)))") + (test + '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) + "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)") + (test '(declare (optimize &any (speed 1) (safety 1))) + "(declare (optimize &any (speed 1) (safety 1)))"))) + +(defun test-arglist-ref () + (macrolet ((soft-assert (form) + `(unless ,form + (warn "Assertion failed: ~S~%" ',form)))) + (let ((sample (decode-arglist '(x &key ((:k (y z))))))) + (soft-assert (eq (arglist-ref sample 0) 'x)) + (soft-assert (eq (arglist-ref sample :k 0) 'y)) + (soft-assert (eq (arglist-ref sample :k 1) 'z)) + + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample 0) + 'a)) + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 0) + 'b)) + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 1) + 'c))))) + +(test-print-arglist) +(test-arglist-ref) + +(provide :swank-arglists) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-asdf.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-asdf.lisp new file mode 100644 index 0000000..0fdd901 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-asdf.lisp @@ -0,0 +1,541 @@ +;;; swank-asdf.lisp -- ASDF support +;; +;; Authors: Daniel Barlow +;; Marco Baringer +;; Edi Weitz +;; Francois-Rene Rideau +;; and others +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) +;;; The best way to load ASDF is from an init file of an +;;; implementation. If ASDF is not loaded at the time swank-asdf is +;;; loaded, it will be tried first with (require "asdf"), if that +;;; doesn't help and *asdf-path* is set, it will be loaded from that +;;; file. +;;; To set *asdf-path* put the following into ~/.swank.lisp: +;;; (defparameter swank::*asdf-path* #p"/path/to/asdf/asdf.lisp") + (defvar *asdf-path* nil + "Path to asdf.lisp file, to be loaded in case (require \"asdf\") fails.")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (ignore-errors (funcall 'require "asdf")))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (handler-bind ((warning #'muffle-warning)) + (when *asdf-path* + (load *asdf-path* :if-does-not-exist nil))))) + +;; If still not found, error out. +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (member :asdf *features*) + (error "Could not load ASDF. +Please update your implementation or +install a recent release of ASDF and in your ~~/.swank.lisp specify: + (defparameter swank::*asdf-path* #p\"/path/containing/asdf/asdf.lisp\")"))) + +;;; If ASDF is too old, punt. +;; As of January 2014, Quicklisp has been providing 2.26 for a year +;; (and previously had 2.014.6 for over a year), whereas +;; all SLIME-supported implementations provide ASDF3 (i.e. 2.27 or later) +;; except LispWorks (stuck with 2.019) and SCL (which hasn't been released +;; in years and doesn't provide ASDF at all, but is fully supported by ASDF). +;; If your implementation doesn't provide ASDF, or provides an old one, +;; install an upgrade yourself and configure *asdf-path*. +;; It's just not worth the hassle supporting something +;; that doesn't even have COERCE-PATHNAME. +;; +;; NB: this version check is duplicated in swank-loader.lisp so that we don't +;; try to load this contrib when ASDF is too old since that will abort the SLIME +;; connection. +#-asdf3 +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (and #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "2.14.6")) + (error "Your ASDF is too old. ~ + The oldest version supported by swank-asdf is 2.014.6."))) +;;; Import functionality from ASDF that isn't available in all ASDF versions. +;;; Please do NOT depend on any of the below as reference: +;;; they are sometimes stripped down versions, for compatibility only. +;;; Indeed, they are supposed to work on *OLDER*, not *NEWER* versions of ASDF. +;;; +;;; The way I got these is usually by looking at the current definition, +;;; using git blame in one screen to locate which commit last modified it, +;;; and git log in another to determine which release that made it in. +;;; It is OK for some of the below definitions to be or become obsolete, +;;; as long as it will make do with versions older than the tagged version: +;;; if ASDF is more recent, its more recent version will win. +;;; +;;; If your software is hacking ASDF, use its internals. +;;; If you want ASDF utilities in user software, please use ASDF-UTILS. + +(defun asdf-at-least (version) + (asdf:version-satisfies (asdf:asdf-version) version)) + +(defmacro asdefs (version &rest defs) + (flet ((defun* (version name aname rest) + `(progn + (defun ,name ,@rest) + (declaim (notinline ,name)) + (when (asdf-at-least ,version) + (setf (fdefinition ',name) (fdefinition ',aname))))) + (defmethod* (version aname rest) + `(unless (asdf-at-least ,version) + (defmethod ,aname ,@rest))) + (defvar* (name aname rest) + `(progn + (define-symbol-macro ,name ,aname) + (defvar ,aname ,@rest)))) + `(progn + ,@(loop :for (def name . args) :in defs + :for aname = (intern (string name) :asdf) + :collect + (ecase def + ((defun) (defun* version name aname args)) + ((defmethod) (defmethod* version aname args)) + ((defvar) (defvar* name aname args))))))) + +(asdefs "2.15" + (defvar *wild* #-cormanlisp :wild #+cormanlisp "*") + + (defun collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) + + (defun register-asd-directory (directory &key recurse exclude collect) + (if (not recurse) + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files + directory :exclude exclude :collect collect)))) + +(asdefs "2.16" + (defun load-sysdef (name pathname) + (declare (ignore name)) + (let ((package (asdf::make-temporary-package))) + (unwind-protect + (let ((*package* package) + (*default-pathname-defaults* + (asdf::pathname-directory-pathname + (translate-logical-pathname pathname)))) + (asdf::asdf-message + "~&; Loading system definition from ~A into ~A~%" ; + pathname package) + (load pathname)) + (delete-package package)))) + + (defun directory* (pathname-spec &rest keys &key &allow-other-keys) + (apply 'directory pathname-spec + (append keys + '#.(or #+allegro + '(:directories-are-files nil + :follow-symbolic-links nil) + #+clozure + '(:follow-links nil) + #+clisp + '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) + '(:follow-links nil :truenamep nil) + #+sbcl + (when (find-symbol "RESOLVE-SYMLINKS" '#:sb-impl) + '(:resolve-symlinks nil))))))) +(asdefs "2.17" + (defun collect-sub*directories-asd-files + (directory &key + (exclude asdf::*default-source-registry-exclusions*) + collect) + (asdf::collect-sub*directories + directory + (constantly t) + (lambda (x) (not (member (car (last (pathname-directory x))) + exclude :test #'equal))) + (lambda (dir) (collect-asds-in-directory dir collect)))) + + (defun system-source-directory (system-designator) + (asdf::pathname-directory-pathname + (asdf::system-source-file system-designator))) + + (defun filter-logical-directory-results (directory entries merger) + (if (typep directory 'logical-pathname) + (loop for f in entries + when + (if (typep f 'logical-pathname) + f + (let ((u (ignore-errors (funcall merger f)))) + (and u + (equal (ignore-errors (truename u)) + (truename f)) + u))) + collect it) + entries)) + + (defun directory-asd-files (directory) + (directory-files directory asdf::*wild-asd*))) + +(asdefs "2.19" + (defun subdirectories (directory) + (let* ((directory (asdf::ensure-directory-pathname directory)) + #-(or abcl cormanlisp xcl) + (wild (asdf::merge-pathnames* + #-(or abcl allegro cmu lispworks sbcl scl xcl) + asdf::*wild-directory* + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #-(or abcl cormanlisp xcl) + (ignore-errors + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory)) + #+(or abcl allegro cmu lispworks sbcl scl xcl) + (dirs (loop for x in dirs + for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu sbcl scl) (asdf::directory-pathname-p x) + #+lispworks (lw:file-directory-p x) + when d collect #+(or abcl allegro xcl) d + #+(or cmu lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component + (pathname-directory directory)) + ;; because allegro 8.x returns NIL for #p"FOO:" + '(:absolute)))) + (lambda (d) + (let ((dir (normalize-pathname-directory-component + (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory + (append prefix + (make-pathname-component-logical + (last dir)))))))))))) + +(asdefs "2.21" + (defun component-loaded-p (c) + (and (gethash 'load-op (asdf::component-operation-times + (asdf::find-component c nil))) t)) + + (defun normalize-pathname-directory-component (directory) + (cond + #-(or cmu sbcl scl) + ((stringp directory) `(:absolute ,directory) directory) + ((or (null directory) + (and (consp directory) + (member (first directory) '(:absolute :relative)))) + directory) + (t + (error "Unrecognized pathname directory component ~S" directory)))) + + (defun make-pathname-component-logical (x) + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + + (defun make-pathname-logical (pathname host) + (make-pathname + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname))))) + +(asdefs "2.22" + (defun directory-files (directory &optional (pattern asdf::*wild-file*)) + (let ((dir (pathname directory))) + (when (typep dir 'logical-pathname) + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) + '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" + pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let ((entries (ignore-errors + (directory* (asdf::merge-pathnames* pattern dir))))) + (filter-logical-directory-results + directory entries + (lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical + (pathname-name f)) + :type (make-pathname-component-logical + (pathname-type f)) + :version (make-pathname-component-logical + (pathname-version f))))))))) + +(asdefs "2.26.149" + (defmethod component-relative-pathname ((system asdf:system)) + (asdf::coerce-pathname + (and (slot-boundp system 'asdf::relative-pathname) + (slot-value system 'asdf::relative-pathname)) + :type :directory + :defaults (system-source-directory system))) + (defun load-asd (pathname &key name &allow-other-keys) + (asdf::load-sysdef (or name (string-downcase (pathname-name pathname))) + pathname))) + + +;;; Taken from ASDF 1.628 +(defmacro while-collecting ((&rest collectors) &body body) + `(asdf::while-collecting ,collectors ,@body)) + +;;; Now for SLIME-specific stuff + +(defun asdf-operation (operation) + (or (asdf::find-symbol* operation :asdf) + (error "Couldn't find ASDF operation ~S" operation))) + +(defun map-system-components (fn system) + (map-component-subcomponents fn (asdf:find-system system))) + +(defun map-component-subcomponents (fn component) + (when component + (funcall fn component) + (when (typep component 'asdf:module) + (dolist (c (asdf:module-components component)) + (map-component-subcomponents fn c))))) + +;;; Maintaining a pathname to component table + +(defvar *pathname-component* (make-hash-table :test 'equal)) + +(defun clear-pathname-component-table () + (clrhash *pathname-component*)) + +(defun register-system-pathnames (system) + (map-system-components 'register-component-pathname system)) + +(defun recompute-pathname-component-table () + (clear-pathname-component-table) + (asdf::map-systems 'register-system-pathnames)) + +(defun pathname-component (x) + (gethash (pathname x) *pathname-component*)) + +(defmethod asdf:component-pathname :around ((component asdf:component)) + (let ((p (call-next-method))) + (when (pathnamep p) + (setf (gethash p *pathname-component*) component)) + p)) + +(defun register-component-pathname (component) + (asdf:component-pathname component)) + +(recompute-pathname-component-table) + +;;; This is a crude hack, see ASDF's LP #481187. +(defslimefun who-depends-on (system) + (flet ((system-dependencies (op system) + (mapcar (lambda (dep) + (asdf::coerce-name (if (consp dep) (second dep) dep))) + (cdr (assoc op (asdf:component-depends-on op system)))))) + (let ((system-name (asdf::coerce-name system)) + (result)) + (asdf::map-systems + (lambda (system) + (when (member system-name + (system-dependencies 'asdf:load-op system) + :test #'string=) + (push (asdf:component-name system) result)))) + result))) + +(defmethod xref-doit ((type (eql :depends-on)) thing) + (when (typep thing '(or string symbol)) + (loop for dependency in (who-depends-on thing) + for asd-file = (asdf:system-definition-pathname dependency) + when asd-file + collect (list dependency + (swank/backend:make-location + `(:file ,(namestring asd-file)) + `(:position 1) + `(:snippet ,(format nil "(defsystem :~A" dependency) + :align t)))))) + +(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords) + "Compile and load SYSTEM using ASDF. +Record compiler notes signalled as `compiler-condition's." + (collect-notes + (lambda () + (apply #'operate-on-system system-name operation keywords)))) + +(defun operate-on-system (system-name operation-name &rest keyword-args) + "Perform OPERATION-NAME on SYSTEM-NAME using ASDF. +The KEYWORD-ARGS are passed on to the operation. +Example: +\(operate-on-system \"cl-ppcre\" 'compile-op :force t)" + (handler-case + (with-compilation-hooks () + (apply #'asdf:operate (asdf-operation operation-name) + system-name keyword-args) + t) + ((or asdf:compile-error #+asdf3 asdf/lisp-build:compile-file-error) + () nil))) + +(defun unique-string-list (&rest lists) + (sort (delete-duplicates (apply #'append lists) :test #'string=) #'string<)) + +(defslimefun list-all-systems-in-central-registry () + "Returns a list of all systems in ASDF's central registry +AND in its source-registry. (legacy name)" + (unique-string-list + (mapcar + #'pathname-name + (while-collecting (c) + (loop for dir in asdf:*central-registry* + for defaults = (eval dir) + when defaults + do (collect-asds-in-directory defaults #'c)) + (asdf:ensure-source-registry) + (if (or #+asdf3 t + #-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15")) + (loop :for k :being :the :hash-keys :of asdf::*source-registry* + :do (c k)) + #-asdf3 + (dolist (entry (asdf::flatten-source-registry)) + (destructuring-bind (directory &key recurse exclude) entry + (register-asd-directory + directory + :recurse recurse :exclude exclude :collect #'c)))))))) + +(defslimefun list-all-systems-known-to-asdf () + "Returns a list of all systems ASDF knows already." + (while-collecting (c) + (asdf::map-systems (lambda (system) (c (asdf:component-name system)))))) + +(defslimefun list-asdf-systems () + "Returns the systems in ASDF's central registry and those which ASDF +already knows." + (unique-string-list + (list-all-systems-known-to-asdf) + (list-all-systems-in-central-registry))) + +(defun asdf-component-source-files (component) + (while-collecting (c) + (labels ((f (x) + (typecase x + (asdf:source-file (c (asdf:component-pathname x))) + (asdf:module (map () #'f (asdf:module-components x)))))) + (f component)))) + +(defun make-operation (x) + #+#.(swank/backend:with-symbol 'make-operation 'asdf) + (asdf:make-operation x) + #-#.(swank/backend:with-symbol 'make-operation 'asdf) + (make-instance x)) + +(defun asdf-component-output-files (component) + (while-collecting (c) + (labels ((f (x) + (typecase x + (asdf:source-file + (map () #'c + (asdf:output-files (make-operation 'asdf:compile-op) x))) + (asdf:module (map () #'f (asdf:module-components x)))))) + (f component)))) + +(defslimefun asdf-system-files (name) + (let* ((system (asdf:find-system name)) + (files (mapcar #'namestring + (cons + (asdf:system-definition-pathname system) + (asdf-component-source-files system)))) + (main-file (find name files + :test #'equalp :key #'pathname-name :start 1))) + (if main-file + (cons main-file (remove main-file files + :test #'equal :count 1)) + files))) + +(defslimefun asdf-system-loaded-p (name) + (component-loaded-p name)) + +(defslimefun asdf-system-directory (name) + (namestring (translate-logical-pathname (asdf:system-source-directory name)))) + +(defun pathname-system (pathname) + (let ((component (pathname-component pathname))) + (when component + (asdf:component-name (asdf:component-system component))))) + +(defslimefun asdf-determine-system (file buffer-package-name) + (or + (and file + (pathname-system file)) + (and file + (progn + ;; If not found, let's rebuild the table first + (recompute-pathname-component-table) + (pathname-system file))) + ;; If we couldn't find an already defined system, + ;; try finding a system that's named like BUFFER-PACKAGE-NAME. + (loop with package = (guess-buffer-package buffer-package-name) + for name in (package-names package) + for system = (asdf:find-system (asdf::coerce-name name) nil) + when (and system + (or (not file) + (pathname-system file))) + return (asdf:component-name system)))) + +(defslimefun delete-system-fasls (name) + (let ((removed-count + (loop for file in (asdf-component-output-files + (asdf:find-system name)) + when (probe-file file) + count it + and + do (delete-file file)))) + (format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count))) + +(defvar *recompile-system* nil) + +(defmethod asdf:operation-done-p :around + ((operation asdf:compile-op) + component) + (unless (eql *recompile-system* + (asdf:component-system component)) + (call-next-method))) + +(defslimefun reload-system (name) + (let ((*recompile-system* (asdf:find-system name))) + (operate-on-system-for-emacs name 'asdf:load-op))) + +;; Doing list-all-systems-in-central-registry might be quite slow +;; since it accesses a file-system, so run it once at the background +;; to initialize caches. +(when (eql *communication-style* :spawn) + (spawn (lambda () + (ignore-errors (list-all-systems-in-central-registry))) + :name "init-asdf-fs-caches")) + +;;; Hook for compile-file-for-emacs + +(defun try-compile-file-with-asdf (pathname load-p &rest options) + (declare (ignore options)) + (let ((component (pathname-component pathname))) + (when component + ;;(format t "~&Compiling ASDF component ~S~%" component) + (let ((op (make-operation 'asdf:compile-op))) + (with-compilation-hooks () + (asdf:perform op component)) + (when load-p + (asdf:perform (make-operation 'asdf:load-op) component)) + (values t t nil (first (asdf:output-files op component))))))) + +(defun try-compile-asd-file (pathname load-p &rest options) + (declare (ignore load-p options)) + (when (equalp (pathname-type pathname) "asd") + (load-asd pathname) + (values t t nil pathname))) + +(pushnew 'try-compile-asd-file *compile-file-for-emacs-hook*) + +;;; (pushnew 'try-compile-file-with-asdf *compile-file-for-emacs-hook*) + +(provide :swank-asdf) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-buffer-streams.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-buffer-streams.lisp new file mode 100644 index 0000000..4d901e2 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-buffer-streams.lisp @@ -0,0 +1,39 @@ +;;; swank-buffer-streams.lisp --- Streams that output to a buffer +;;; +;;; Authors: Ed Langley +;;; +;;; License: This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(in-package :swank) + +(defpackage :swank-buffer-streams + (:use :cl) + (:import-from :swank + defslimefun + add-hook + encode-message + send-event + find-thread + dcase + current-socket-io + send-to-emacs + current-thread-id + wait-for-event + + *emacs-connection* + *event-hook*) + (:export make-buffer-output-stream)) + +(in-package :swank-buffer-streams) + +(defun get-temporary-identifier () + (intern (symbol-name (gensym "BUFFER")) + :keyword)) + +(defun make-buffer-output-stream (&optional (target-identifier (get-temporary-identifier))) + (swank:ed-rpc '#:slime-make-buffer-stream-target (current-thread-id) target-identifier) + (values (swank:make-output-stream-for-target *emacs-connection* target-identifier) + target-identifier)) + +(provide :swank-buffer-streams) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-c-p-c.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-c-p-c.lisp new file mode 100644 index 0000000..6a766fb --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-c-p-c.lisp @@ -0,0 +1,298 @@ +;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion +;; +;; Author: Luke Gorrie +;; Edi Weitz +;; Matthias Koeppe +;; Tobias C. Rittweiler +;; and others +;; +;; License: Public Domain +;; + + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-util)) + +(defslimefun completions (string default-package-name) + "Return a list of completions for a symbol designator STRING. + +The result is the list (COMPLETION-SET COMPLETED-PREFIX), where +COMPLETION-SET is the list of all matching completions, and +COMPLETED-PREFIX is the best (partial) completion of the input +string. + +Simple compound matching is supported on a per-hyphen basis: + + (completions \"m-v-\" \"COMMON-LISP\") + ==> ((\"multiple-value-bind\" \"multiple-value-call\" + \"multiple-value-list\" \"multiple-value-prog1\" + \"multiple-value-setq\" \"multiple-values-limit\") + \"multiple-value\") + +\(For more advanced compound matching, see FUZZY-COMPLETIONS.) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +The way symbols are matched depends on the symbol designator's +format. The cases are as follows: + FOO - Symbols with matching prefix and accessible in the buffer package. + PKG:FOO - Symbols with matching prefix and external in package PKG. + PKG::FOO - Symbols with matching prefix and accessible in package PKG. +" + (multiple-value-bind (name package-name package internal-p) + (parse-completion-arguments string default-package-name) + (let* ((symbol-set (symbol-completion-set + name package-name package internal-p + (make-compound-prefix-matcher #\-))) + (package-set (package-completion-set + name package-name package internal-p + (make-compound-prefix-matcher '(#\. #\-)))) + (completion-set + (format-completion-set (nconc symbol-set package-set) + internal-p package-name))) + (when completion-set + (list completion-set (longest-compound-prefix completion-set)))))) + + +;;;;; Find completion set + +(defun symbol-completion-set (name package-name package internal-p matchp) + "Return the set of completion-candidates as strings." + (mapcar (completion-output-symbol-converter name) + (and package + (mapcar #'symbol-name + (find-matching-symbols name + package + (and (not internal-p) + package-name) + matchp))))) + +(defun package-completion-set (name package-name package internal-p matchp) + (declare (ignore package internal-p)) + (mapcar (completion-output-package-converter name) + (and (not package-name) + (find-matching-packages name matchp)))) + +(defun find-matching-symbols (string package external test) + "Return a list of symbols in PACKAGE matching STRING. +TEST is called with two strings. If EXTERNAL is true, only external +symbols are returned." + (let ((completions '()) + (converter (completion-output-symbol-converter string))) + (flet ((symbol-matches-p (symbol) + (and (or (not external) + (symbol-external-p symbol package)) + (funcall test string + (funcall converter (symbol-name symbol)))))) + (do-symbols* (symbol package) + (when (symbol-matches-p symbol) + (push symbol completions)))) + completions)) + +(defun find-matching-symbols-in-list (string list test) + "Return a list of symbols in LIST matching STRING. +TEST is called with two strings." + (let ((completions '()) + (converter (completion-output-symbol-converter string))) + (flet ((symbol-matches-p (symbol) + (funcall test string + (funcall converter (symbol-name symbol))))) + (dolist (symbol list) + (when (symbol-matches-p symbol) + (push symbol completions)))) + (remove-duplicates completions))) + +(defun find-matching-packages (name matcher) + "Return a list of package names matching NAME with MATCHER. +MATCHER is a two-argument predicate." + (let ((converter (completion-output-package-converter name))) + (remove-if-not (lambda (x) + (funcall matcher name (funcall converter x))) + (mapcar (lambda (pkgname) + (concatenate 'string pkgname ":")) + (loop for package in (list-all-packages) + nconcing (package-names package)))))) + + +;; PARSE-COMPLETION-ARGUMENTS return table: +;; +;; user behaviour | NAME | PACKAGE-NAME | PACKAGE +;; ----------------+--------+--------------+----------------------------------- +;; asdf [tab] | "asdf" | NIL | # +;; | | | or *BUFFER-PACKAGE* +;; asdf: [tab] | "" | "asdf" | # +;; | | | +;; asdf:foo [tab] | "foo" | "asdf" | # +;; | | | +;; as:fo [tab] | "fo" | "as" | NIL +;; | | | +;; : [tab] | "" | "" | # +;; | | | +;; :foo [tab] | "foo" | "" | # +;; +(defun parse-completion-arguments (string default-package-name) + "Parse STRING as a symbol designator. +Return these values: + SYMBOL-NAME + PACKAGE-NAME, or nil if the designator does not include an explicit package. + PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is + NIL, return the respective package of DEFAULT-PACKAGE-NAME instead; + if PACKAGE is non-NIL but a package cannot be found under that name, + return NIL.) + INTERNAL-P, if the symbol is qualified with `::'." + (multiple-value-bind (name package-name internal-p) + (tokenize-symbol string) + (flet ((default-package () + (or (guess-package default-package-name) *buffer-package*))) + (let ((package (cond + ((not package-name) + (default-package)) + ((equal package-name "") + (guess-package (symbol-name :keyword))) + ((find-locally-nicknamed-package + package-name (default-package))) + (t + (guess-package package-name))))) + (values name package-name package internal-p))))) + +(defun completion-output-case-converter (input &optional with-escaping-p) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case." + (ecase (readtable-case *readtable*) + (:upcase (cond ((or with-escaping-p + (and (plusp (length input)) + (not (some #'lower-case-p input)))) + #'identity) + (t #'string-downcase))) + (:invert (lambda (output) + (multiple-value-bind (lower upper) (determine-case output) + (cond ((and lower upper) output) + (lower (string-upcase output)) + (upper (string-downcase output)) + (t output))))) + (:downcase (cond ((or with-escaping-p + (and (zerop (length input)) + (not (some #'upper-case-p input)))) + #'identity) + (t #'string-upcase))) + (:preserve #'identity))) + +(defun completion-output-package-converter (input) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case." + (completion-output-case-converter input)) + +(defun completion-output-symbol-converter (input) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case. Escape symbols when needed." + (let ((case-converter (completion-output-case-converter input)) + (case-converter-with-escaping (completion-output-case-converter input t))) + (lambda (str) + (if (or (multiple-value-bind (lowercase uppercase) + (determine-case str) + ;; In these readtable cases, symbols with letters from + ;; the wrong case need escaping + (case (readtable-case *readtable*) + (:upcase lowercase) + (:downcase uppercase) + (t nil))) + (some (lambda (el) + (or (member el '(#\: #\Space #\Newline #\Tab)) + (multiple-value-bind (macrofun nonterminating) + (get-macro-character el) + (and macrofun + (not nonterminating))))) + str)) + (concatenate 'string "|" (funcall case-converter-with-escaping str) "|") + (funcall case-converter str))))) + + +(defun determine-case (string) + "Return two booleans LOWER and UPPER indicating whether STRING +contains lower or upper case characters." + (values (some #'lower-case-p string) + (some #'upper-case-p string))) + + +;;;;; Compound-prefix matching + +(defun make-compound-prefix-matcher (delimiter &key (test #'char=)) + "Returns a matching function that takes a `prefix' and a +`target' string and which returns T if `prefix' is a +compound-prefix of `target', and otherwise NIL. + +Viewing each of `prefix' and `target' as a series of substrings +delimited by DELIMITER, if each substring of `prefix' is a prefix +of the corresponding substring in `target' then we call `prefix' +a compound-prefix of `target'. + +DELIMITER may be a character, or a list of characters." + (let ((delimiters (etypecase delimiter + (character (list delimiter)) + (cons (assert (every #'characterp delimiter)) + delimiter)))) + (lambda (prefix target) + (declare (type simple-string prefix target)) + (loop with tpos = 0 + for ch across prefix + always (and (< tpos (length target)) + (let ((delimiter (car (member ch delimiters :test test)))) + (if delimiter + (setf tpos (position delimiter target :start tpos)) + (funcall test ch (aref target tpos))))) + do (incf tpos))))) + + +;;;;; Extending the input string by completion + +(defun longest-compound-prefix (completions &optional (delimiter #\-)) + "Return the longest compound _prefix_ for all COMPLETIONS." + (flet ((tokenizer (string) (tokenize-completion string delimiter))) + (untokenize-completion + (loop for token-list in (transpose-lists (mapcar #'tokenizer completions)) + if (notevery #'string= token-list (rest token-list)) + ;; Note that we possibly collect the "" here as well, so that + ;; UNTOKENIZE-COMPLETION will append a delimiter for us. + collect (longest-common-prefix token-list) + and do (loop-finish) + else collect (first token-list)) + delimiter))) + +(defun tokenize-completion (string delimiter) + "Return all substrings of STRING delimited by DELIMITER." + (loop with end + for start = 0 then (1+ end) + until (> start (length string)) + do (setq end (or (position delimiter string :start start) (length string))) + collect (subseq string start end))) + +(defun untokenize-completion (tokens &optional (delimiter #\-)) + (format nil (format nil "~~{~~A~~^~a~~}" delimiter) tokens)) + +(defun transpose-lists (lists) + "Turn a list-of-lists on its side. +If the rows are of unequal length, truncate uniformly to the shortest. + +For example: +\(transpose-lists '((ONE TWO THREE) (1 2))) + => ((ONE 1) (TWO 2))" + (cond ((null lists) '()) + ((some #'null lists) '()) + (t (cons (mapcar #'car lists) + (transpose-lists (mapcar #'cdr lists)))))) + + +;;;; Completion for character names + +(defslimefun completions-for-character (prefix) + (let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal)) + (completion-set (character-completion-set prefix matcher)) + (completions (sort completion-set #'string<))) + (list completions (longest-compound-prefix completions #\_)))) + +(provide :swank-c-p-c) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-clipboard.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-clipboard.lisp new file mode 100644 index 0000000..52b1085 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-clipboard.lisp @@ -0,0 +1,71 @@ +;;; swank-clipboard.lisp --- Object clipboard +;; +;; Written by Helmut Eller in 2008. +;; License: Public Domain + +(defpackage :swank-clipboard + (:use :cl) + (:import-from :swank :defslimefun :with-buffer-syntax :dcase) + (:export :add :delete-entry :entries :entry-to-ref :ref)) + +(in-package :swank-clipboard) + +(defstruct clipboard entries (counter 0)) + +(defvar *clipboard* (make-clipboard)) + +(defslimefun add (datum) + (let ((value (dcase datum + ((:string string package) + (with-buffer-syntax (package) + (eval (read-from-string string)))) + ((:inspector part) + (swank:inspector-nth-part part)) + ((:sldb frame var) + (swank/backend:frame-var-value frame var))))) + (clipboard-add value) + (format nil "Added: ~a" + (entry-to-string (1- (length (clipboard-entries *clipboard*))))))) + +(defslimefun entries () + (loop for (ref . value) in (clipboard-entries *clipboard*) + collect `(,ref . ,(to-line value)))) + +(defslimefun delete-entry (entry) + (let ((msg (format nil "Deleted: ~a" (entry-to-string entry)))) + (clipboard-delete-entry entry) + msg)) + +(defslimefun entry-to-ref (entry) + (destructuring-bind (ref . value) (clipboard-entry entry) + (list ref (to-line value 5)))) + +(defun clipboard-add (value) + (setf (clipboard-entries *clipboard*) + (append (clipboard-entries *clipboard*) + (list (cons (incf (clipboard-counter *clipboard*)) + value))))) + +(defun clipboard-ref (ref) + (let ((tail (member ref (clipboard-entries *clipboard*) :key #'car))) + (cond (tail (cdr (car tail))) + (t (error "Invalid clipboard ref: ~s" ref))))) + +(defun clipboard-entry (entry) + (elt (clipboard-entries *clipboard*) entry)) + +(defun clipboard-delete-entry (index) + (let* ((list (clipboard-entries *clipboard*)) + (tail (nthcdr index list))) + (setf (clipboard-entries *clipboard*) + (append (ldiff list tail) (cdr tail))))) + +(defun entry-to-string (entry) + (destructuring-bind (ref . value) (clipboard-entry entry) + (format nil "#@~d(~a)" ref (to-line value)))) + +(defun to-line (object &optional (width 75)) + (with-output-to-string (*standard-output*) + (write object :right-margin width :lines 1))) + +(provide :swank-clipboard) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-fancy-inspector.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-fancy-inspector.lisp new file mode 100644 index 0000000..c2201a8 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-fancy-inspector.lisp @@ -0,0 +1,1006 @@ +;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects +;; +;; Author: Marco Baringer and others +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-util)) + +(defmethod emacs-inspect ((symbol symbol)) + (let ((package (symbol-package symbol))) + (multiple-value-bind (_symbol status) + (and package (find-symbol (string symbol) package)) + (declare (ignore _symbol)) + (append + (label-value-line "Its name is" (symbol-name symbol)) + ;; + ;; Value + (cond ((boundp symbol) + (append + (label-value-line (if (constantp symbol) + "It is a constant of value" + "It is a global variable bound to") + (symbol-value symbol) :newline nil) + ;; unbinding constants might be not a good idea, but + ;; implementations usually provide a restart. + `(" " (:action "[unbind]" + ,(lambda () (makunbound symbol)))) + '((:newline)))) + (t '("It is unbound." (:newline)))) + (docstring-ispec "Documentation" symbol 'variable) + (multiple-value-bind (expansion definedp) (macroexpand symbol) + (if definedp + (label-value-line "It is a symbol macro with expansion" + expansion))) + ;; + ;; Function + (if (fboundp symbol) + (append (if (macro-function symbol) + `("It a macro with macro-function: " + (:value ,(macro-function symbol))) + `("It is a function: " + (:value ,(symbol-function symbol)))) + `(" " (:action "[unbind]" + ,(lambda () (fmakunbound symbol)))) + `((:newline))) + `("It has no function value." (:newline))) + (docstring-ispec "Function documentation" symbol 'function) + (when (compiler-macro-function symbol) + (append + (label-value-line "It also names the compiler macro" + (compiler-macro-function symbol) :newline nil) + `(" " (:action "[remove]" + ,(lambda () + (setf (compiler-macro-function symbol) nil))) + (:newline)))) + (docstring-ispec "Compiler macro documentation" + symbol 'compiler-macro) + ;; + ;; Package + (if package + `("It is " ,(string-downcase (string status)) + " to the package: " + (:value ,package ,(package-name package)) + ,@(if (eq :internal status) + `(" " + (:action "[export]" + ,(lambda () (export symbol package))))) + " " + (:action "[unintern]" + ,(lambda () (unintern symbol package))) + (:newline)) + '("It is a non-interned symbol." (:newline))) + ;; + ;; Plist + (label-value-line "Property list" (symbol-plist symbol)) + ;; + ;; Class + (if (find-class symbol nil) + `("It names the class " + (:value ,(find-class symbol) ,(string symbol)) + " " + (:action "[remove]" + ,(lambda () (setf (find-class symbol) nil))) + (:newline))) + ;; + ;; More package + (if (find-package symbol) + (label-value-line "It names the package" (find-package symbol))) + (inspect-type-specifier symbol))))) + +#-sbcl +(defun inspect-type-specifier (symbol) + (declare (ignore symbol))) + +#+sbcl +(defun inspect-type-specifier (symbol) + (let* ((kind (sb-int:info :type :kind symbol)) + (fun (case kind + (:defined + (or (sb-int:info :type :expander symbol) t)) + (:primitive + (or #.(if (swank/sbcl::sbcl-version>= 1 3 1) + '(let ((x (sb-int:info :type :expander symbol))) + (if (consp x) + (car x) + x)) + '(sb-int:info :type :translator symbol)) + t))))) + (when fun + (append + (list + (format nil "It names a ~@[primitive~* ~]type-specifier." + (eq kind :primitive)) + '(:newline)) + (docstring-ispec "Type-specifier documentation" symbol 'type) + (unless (eq t fun) + (let ((arglist (arglist fun))) + (append + `("Type-specifier lambda-list: " + ;; Could use ~:s, but inspector-princ does a bit more, + ;; and not all NILs in the arglist should be printed that way. + ,(if arglist + (inspector-princ arglist) + "()") + (:newline)) + (multiple-value-bind (expansion ok) + (handler-case (sb-ext:typexpand-1 symbol) + (error () (values nil nil))) + (when ok + (list "Type-specifier expansion: " + (princ-to-string expansion))))))))))) + +(defun docstring-ispec (label object kind) + "Return a inspector spec if OBJECT has a docstring of kind KIND." + (let ((docstring (documentation object kind))) + (cond ((not docstring) nil) + ((< (+ (length label) (length docstring)) + 75) + (list label ": " docstring '(:newline))) + (t + (list label ":" '(:newline) " " docstring '(:newline)))))) + +(unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil) + (defmethod emacs-inspect ((f function)) + (inspect-function f))) + +(defun inspect-function (f) + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(inspector-princ (arglist f)) (:newline)) + (docstring-ispec "Documentation" f t) + (if (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f))))) + +(defun method-specializers-for-inspect (method) + "Return a \"pretty\" list of the method's specializers. Normal + specializers are replaced by the name of the class, eql + specializers are replaced by `(eql ,object)." + (mapcar (lambda (spec) + (typecase spec + (swank-mop:eql-specializer + `(eql ,(swank-mop:eql-specializer-object spec))) + #-sbcl + (t + (swank-mop:class-name spec)) + #+sbcl + (t + ;; SBCL has extended specializers + (let ((gf (sb-mop:method-generic-function method))) + (cond (gf + (sb-pcl:unparse-specializer-using-class gf spec)) + ((typep spec 'class) + (class-name spec)) + (t + spec)))))) + (swank-mop:method-specializers method))) + +(defun method-for-inspect-value (method) + "Returns a \"pretty\" list describing METHOD. The first element + of the list is the name of generic-function method is + specialiazed on, the second element is the method qualifiers, + the rest of the list is the method's specialiazers (as per + method-specializers-for-inspect)." + (append (list (swank-mop:generic-function-name + (swank-mop:method-generic-function method))) + (swank-mop:method-qualifiers method) + (method-specializers-for-inspect method))) + +(defmethod emacs-inspect ((object standard-object)) + (let ((class (class-of object))) + `("Class: " (:value ,class) (:newline) + ,@(all-slots-for-inspector object)))) + +(defvar *gf-method-getter* 'methods-by-applicability + "This function is called to get the methods of a generic function. +The default returns the method sorted by applicability. +See `methods-by-applicability'.") + +(defun specializer< (specializer1 specializer2) + "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." + (let ((s1 specializer1) (s2 specializer2) ) + (cond ((typep s1 'swank-mop:eql-specializer) + (not (typep s2 'swank-mop:eql-specializer))) + ((typep s1 'class) + (flet ((cpl (class) + (and (swank-mop:class-finalized-p class) + (swank-mop:class-precedence-list class)))) + (member s2 (cpl s1))))))) + +(defun methods-by-applicability (gf) + "Return methods ordered by most specific argument types. + +`method-specializer<' is used for sorting." + ;; FIXME: argument-precedence-order and qualifiers are ignored. + (labels ((method< (meth1 meth2) + (loop for s1 in (swank-mop:method-specializers meth1) + for s2 in (swank-mop:method-specializers meth2) + do (cond ((specializer< s2 s1) (return nil)) + ((specializer< s1 s2) (return t)))))) + (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) + #'method<))) + +(defun abbrev-doc (doc &optional (maxlen 80)) + "Return the first sentence of DOC, but not more than MAXLAN characters." + (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) + maxlen + (length doc)))) + +(defstruct (inspector-checklist (:conc-name checklist.) + (:constructor %make-checklist (buttons))) + (buttons nil :type (or null simple-vector)) + (count 0)) + +(defun make-checklist (n) + (%make-checklist (make-array n :initial-element nil))) + +(defun reinitialize-checklist (checklist) + ;; Along this counter the buttons are created, so we have to + ;; initialize it to 0 everytime the inspector page is redisplayed. + (setf (checklist.count checklist) 0) + checklist) + +(defun make-checklist-button (checklist) + (let ((buttons (checklist.buttons checklist)) + (i (checklist.count checklist))) + (incf (checklist.count checklist)) + `(:action ,(if (svref buttons i) + "[X]" + "[ ]") + ,#'(lambda () + (setf (svref buttons i) (not (svref buttons i)))) + :refreshp t))) + +(defmacro do-checklist ((idx checklist) &body body) + "Iterate over all set buttons in CHECKLIST." + (let ((buttons (gensym "buttons"))) + `(let ((,buttons (checklist.buttons ,checklist))) + (dotimes (,idx (length ,buttons)) + (when (svref ,buttons ,idx) + ,@body))))) + +(defun box (thing) (cons :box thing)) +(defun ref (box) + (assert (eq (car box) :box)) + (cdr box)) +(defun (setf ref) (value box) + (assert (eq (car box) :box)) + (setf (cdr box) value)) + +(defvar *inspector-slots-default-order* :alphabetically + "Accepted values: :alphabetically and :unsorted") + +(defvar *inspector-slots-default-grouping* :all + "Accepted values: :inheritance and :all") + +(defgeneric all-slots-for-inspector (object)) + +(defmethod all-slots-for-inspector ((object standard-object)) + (let* ((class (class-of object)) + (direct-slots (swank-mop:class-direct-slots class)) + (effective-slots (swank-mop:class-slots class)) + (longest-slot-name-length + (loop for slot :in effective-slots + maximize (length (symbol-name + (swank-mop:slot-definition-name slot))))) + (checklist + (reinitialize-checklist + (ensure-istate-metadata object :checklist + (make-checklist (length effective-slots))))) + (grouping-kind + ;; We box the value so we can re-set it. + (ensure-istate-metadata object :grouping-kind + (box *inspector-slots-default-grouping*))) + (sort-order + (ensure-istate-metadata object :sort-order + (box *inspector-slots-default-order*))) + (sort-predicate (ecase (ref sort-order) + (:alphabetically #'string<) + (:unsorted (constantly nil)))) + (sorted-slots (sort (copy-seq effective-slots) + sort-predicate + :key #'swank-mop:slot-definition-name)) + (effective-slots + (ecase (ref grouping-kind) + (:all sorted-slots) + (:inheritance (stable-sort-by-inheritance sorted-slots + class sort-predicate))))) + `("--------------------" + (:newline) + " Group slots by inheritance " + (:action ,(ecase (ref grouping-kind) + (:all "[ ]") + (:inheritance "[X]")) + ,(lambda () + ;; We have to do this as the order of slots will + ;; be sorted differently. + (fill (checklist.buttons checklist) nil) + (setf (ref grouping-kind) + (ecase (ref grouping-kind) + (:all :inheritance) + (:inheritance :all)))) + :refreshp t) + (:newline) + " Sort slots alphabetically " + (:action ,(ecase (ref sort-order) + (:unsorted "[ ]") + (:alphabetically "[X]")) + ,(lambda () + (fill (checklist.buttons checklist) nil) + (setf (ref sort-order) + (ecase (ref sort-order) + (:unsorted :alphabetically) + (:alphabetically :unsorted)))) + :refreshp t) + (:newline) + ,@ (case (ref grouping-kind) + (:all + `((:newline) + "All Slots:" + (:newline) + ,@(make-slot-listing checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:inheritance + (list-all-slots-by-inheritance checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:newline) + (:action "[set value]" + ,(lambda () + (do-checklist (idx checklist) + (query-and-set-slot class object + (nth idx effective-slots)))) + :refreshp t) + " " + (:action "[make unbound]" + ,(lambda () + (do-checklist (idx checklist) + (swank-mop:slot-makunbound-using-class + class object (nth idx effective-slots)))) + :refreshp t) + (:newline)))) + +(defun list-all-slots-by-inheritance (checklist object class effective-slots + direct-slots longest-slot-name-length) + (flet ((slot-home-class (slot) + (slot-home-class-using-class slot class))) + (let ((current-slots '())) + (append + (loop for slot in effective-slots + for previous-home-class = (slot-home-class slot) then home-class + for home-class = previous-home-class then (slot-home-class slot) + if (eq home-class previous-home-class) + do (push slot current-slots) + else + collect '(:newline) + and collect (format nil "~A:" (class-name previous-home-class)) + and collect '(:newline) + and append (make-slot-listing checklist object class + (nreverse current-slots) + direct-slots + longest-slot-name-length) + and do (setf current-slots (list slot))) + (and current-slots + `((:newline) + ,(format nil "~A:" + (class-name (slot-home-class-using-class + (car current-slots) class))) + (:newline) + ,@(make-slot-listing checklist object class + (nreverse current-slots) direct-slots + longest-slot-name-length))))))) + +(defun make-slot-listing (checklist object class effective-slots direct-slots + longest-slot-name-length) + (flet ((padding-for (slot-name) + (make-string (- longest-slot-name-length (length slot-name)) + :initial-element #\Space))) + (loop + for effective-slot :in effective-slots + for direct-slot = (find (swank-mop:slot-definition-name effective-slot) + direct-slots + :key #'swank-mop:slot-definition-name) + for slot-name = (inspector-princ + (swank-mop:slot-definition-name effective-slot)) + collect (make-checklist-button checklist) + collect " " + collect `(:value ,(if direct-slot + (list direct-slot effective-slot) + effective-slot) + ,slot-name) + collect (padding-for slot-name) + collect " = " + collect (slot-value-for-inspector class object effective-slot) + collect '(:newline)))) + +(defgeneric slot-value-for-inspector (class object slot) + (:method (class object slot) + (let ((boundp (swank-mop:slot-boundp-using-class class object slot))) + (if boundp + `(:value ,(swank-mop:slot-value-using-class class object slot)) + "#")))) + +(defun slot-home-class-using-class (slot class) + (let ((slot-name (swank-mop:slot-definition-name slot))) + (loop for class in (reverse (swank-mop:class-precedence-list class)) + thereis (and (member slot-name (swank-mop:class-direct-slots class) + :key #'swank-mop:slot-definition-name + :test #'eq) + class)))) + +(defun stable-sort-by-inheritance (slots class predicate) + (stable-sort slots predicate + :key #'(lambda (s) + (class-name (slot-home-class-using-class s class))))) + +(defun query-and-set-slot (class object slot) + (let* ((slot-name (swank-mop:slot-definition-name slot)) + (value-string (read-from-minibuffer-in-emacs + (format nil "Set slot ~S to (evaluated) : " + slot-name)))) + (when (and value-string (not (string= value-string ""))) + (with-simple-restart (abort "Abort setting slot ~S" slot-name) + (setf (swank-mop:slot-value-using-class class object slot) + (eval (read-from-string value-string))))))) + + +(defmethod emacs-inspect ((gf standard-generic-function)) + (flet ((lv (label value) (label-value-line label value))) + (append + (lv "Name" (swank-mop:generic-function-name gf)) + (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) + (docstring-ispec "Documentation" gf t) + (lv "Method class" (swank-mop:generic-function-method-class gf)) + (lv "Method combination" + (swank-mop:generic-function-method-combination gf)) + `("Methods: " (:newline)) + (loop for method in (funcall *gf-method-getter* gf) append + `((:value ,method ,(inspector-princ + ;; drop the name of the GF + (cdr (method-for-inspect-value method)))) + " " + (:action "[remove method]" + ,(let ((m method)) ; LOOP reassigns method + (lambda () + (remove-method gf m)))) + (:newline))) + `((:newline)) + (all-slots-for-inspector gf)))) + +(defmethod emacs-inspect ((method standard-method)) + `(,@(if (swank-mop:method-generic-function method) + `("Method defined on the generic function " + (:value ,(swank-mop:method-generic-function method) + ,(inspector-princ + (swank-mop:generic-function-name + (swank-mop:method-generic-function method))))) + '("Method without a generic function")) + (:newline) + ,@(docstring-ispec "Documentation" method t) + "Lambda List: " (:value ,(swank-mop:method-lambda-list method)) + (:newline) + "Specializers: " (:value ,(swank-mop:method-specializers method) + ,(inspector-princ + (method-specializers-for-inspect method))) + (:newline) + "Qualifiers: " (:value ,(swank-mop:method-qualifiers method)) + (:newline) + "Method function: " (:value ,(swank-mop:method-function method)) + (:newline) + ,@(all-slots-for-inspector method))) + +(defun specializer-direct-methods (class) + (sort (copy-seq (swank-mop:specializer-direct-methods class)) + #'string< + :key + (lambda (x) + (symbol-name + (let ((name (swank-mop::generic-function-name + (swank-mop::method-generic-function x)))) + (if (symbolp name) + name + (second name))))))) + +(defmethod emacs-inspect ((class standard-class)) + `("Name: " + (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(common-seperated-spec + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (swank-mop:slot-definition-name slot))))) + `("# " + (:action "[finalize]" + ,(lambda () (swank-mop:finalize-inheritance class))))) + (:newline) + ,@(let ((doc (documentation class t))) + (when doc + `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) + "Sub classes: " + ,@(common-seperated-spec (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub + ,(inspector-princ (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec + (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class ,(inspector-princ (class-name class))))) + '("#")) + (:newline) + ,@(when (swank-mop:specializer-direct-methods class) + `("It is used as a direct specializer in the following methods:" + (:newline) + ,@(loop + for method in (specializer-direct-methods class) + collect " " + collect `(:value ,method + ,(inspector-princ + (method-for-inspect-value method))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (abbrev-doc (documentation method t)) and + collect '(:newline)))) + "Prototype: " ,(if (swank-mop:class-finalized-p class) + `(:value ,(swank-mop:class-prototype class)) + '"#") + (:newline) + ,@(all-slots-for-inspector class))) + +(defmethod emacs-inspect ((slot swank-mop:standard-slot-definition)) + `("Name: " + (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" (:newline) + (:value ,(swank-mop:slot-definition-documentation + slot)) + (:newline))) + "Init args: " + (:value ,(swank-mop:slot-definition-initargs slot)) + (:newline) + "Init form: " + ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#") + (:newline) + "Init function: " + (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline) + ,@(all-slots-for-inspector slot))) + + +;; Wrapper structure over the list of symbols of a package that should +;; be displayed with their respective classification flags. This is +;; because we need a unique type to dispatch on in EMACS-INSPECT. +;; Used by the Inspector for packages. +(defstruct (%package-symbols-container + (:conc-name %container.) + (:constructor %%make-package-symbols-container)) + title ;; A string; the title of the inspector page in Emacs. + description ;; A list of renderable objects; used as description. + symbols ;; A list of symbols. Supposed to be sorted alphabetically. + grouping-kind) ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING + + +(defun %make-package-symbols-container (&key title description symbols) + (%%make-package-symbols-container :title title :description description + :symbols symbols :grouping-kind :symbol)) + +(defgeneric make-symbols-listing (grouping-kind symbols)) + +(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols) + "Returns an object renderable by Emacs' inspector side that +alphabetically lists all the symbols in SYMBOLS together with a +concise string representation of what each symbol +represents (see SYMBOL-CLASSIFICATION-STRING)" + (let ((max-length (loop for s in symbols + maximizing (length (symbol-name s)))) + (distance 10)) ; empty distance between name and classification + (flet ((string-representations (symbol) + (let* ((name (symbol-name symbol)) + (length (length name)) + (padding (- max-length length))) + (values + (concatenate 'string + name + (make-string (+ padding distance) + :initial-element #\Space)) + (symbol-classification-string symbol))))) + `("" ; 8 is (length "Symbols:") + "Symbols:" ,(make-string (+ -8 max-length distance) + :initial-element #\Space) + "Flags:" + (:newline) + ,(concatenate 'string ; underlining dashes + (make-string (+ max-length distance -1) + :initial-element #\-) + " " + (symbol-classification-string '#:foo)) + (:newline) + ,@(loop for symbol in symbols appending + (multiple-value-bind (symbol-string classification-string) + (string-representations symbol) + `((:value ,symbol ,symbol-string) ,classification-string + (:newline) + ))))))) + +(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols) + "For each possible classification (cf. CLASSIFY-SYMBOL), group +all the symbols in SYMBOLS to all of their respective +classifications. (If a symbol is, for instance, boundp and a +generic-function, it'll appear both below the BOUNDP group and +the GENERIC-FUNCTION group.) As macros and special-operators are +specified to be FBOUNDP, there is no general FBOUNDP group, +instead there are the three explicit FUNCTION, MACRO and +SPECIAL-OPERATOR groups." + (let ((table (make-hash-table :test #'eq)) + (+default-classification+ :misc)) + (flet ((normalize-classifications (classifications) + (cond ((null classifications) `(,+default-classification+)) + ;; Convert an :FBOUNDP in CLASSIFICATIONS to + ;; :FUNCTION if possible. + ((and (member :fboundp classifications) + (not (member :macro classifications)) + (not (member :special-operator classifications))) + (substitute :function :fboundp classifications)) + (t (remove :fboundp classifications))))) + (loop for symbol in symbols do + (loop for classification in + (normalize-classifications (classify-symbol symbol)) + ;; SYMBOLS are supposed to be sorted alphabetically; + ;; this property is preserved here except for reversing. + do (push symbol (gethash classification table))))) + (let* ((classifications (loop for k being each hash-key in table + collect k)) + (classifications (sort classifications + ;; Sort alphabetically, except + ;; +DEFAULT-CLASSIFICATION+ which + ;; sort to the end. + (lambda (a b) + (cond ((eql a +default-classification+) + nil) + ((eql b +default-classification+) + t) + (t (string< a b))))))) + (loop for classification in classifications + for symbols = (gethash classification table) + appending`(,(symbol-name classification) + (:newline) + ,(make-string 64 :initial-element #\-) + (:newline) + ,@(mapcan (lambda (symbol) + `((:value ,symbol ,(symbol-name symbol)) + (:newline))) + ;; restore alphabetic order. + (nreverse symbols)) + (:newline)))))) + +(defmethod emacs-inspect ((%container %package-symbols-container)) + (with-struct (%container. title description symbols grouping-kind) %container + `(,title (:newline) (:newline) + ,@description + (:newline) + " " ,(ecase grouping-kind + (:symbol + `(:action "[Group by classification]" + ,(lambda () + (setf grouping-kind :classification)) + :refreshp t)) + (:classification + `(:action "[Group by symbol]" + ,(lambda () (setf grouping-kind :symbol)) + :refreshp t))) + (:newline) (:newline) + ,@(make-symbols-listing grouping-kind symbols)))) + +(defun display-link (type symbols length &key title description) + (if (null symbols) + (format nil "0 ~A symbols." type) + `(:value ,(%make-package-symbols-container :title title + :description description + :symbols symbols) + ,(format nil "~D ~A symbol~P." length type length)))) + +(defmethod emacs-inspect ((package package)) + (let ((package-name (package-name package)) + (package-nicknames (package-nicknames package)) + (package-use-list (package-use-list package)) + (package-used-by-list (package-used-by-list package)) + (shadowed-symbols (package-shadowing-symbols package)) + (present-symbols '()) (present-symbols-length 0) + (internal-symbols '()) (internal-symbols-length 0) + (inherited-symbols '()) (inherited-symbols-length 0) + (external-symbols '()) (external-symbols-length 0)) + + (do-symbols* (sym package) + (let ((status (symbol-status sym package))) + (when (eq status :inherited) + (push sym inherited-symbols) (incf inherited-symbols-length) + (go :continue)) + (push sym present-symbols) (incf present-symbols-length) + (cond ((eq status :internal) + (push sym internal-symbols) (incf internal-symbols-length)) + (t + (push sym external-symbols) (incf external-symbols-length)))) + :continue) + + (setf package-nicknames (sort (copy-list package-nicknames) + #'string<) + package-use-list (sort (copy-list package-use-list) + #'string< :key #'package-name) + package-used-by-list (sort (copy-list package-used-by-list) + #'string< :key #'package-name) + shadowed-symbols (sort (copy-list shadowed-symbols) + #'string<)) + ;;; SORT + STRING-LESSP conses on at least SBCL 0.9.18. + (setf present-symbols (sort present-symbols #'string<) + internal-symbols (sort internal-symbols #'string<) + external-symbols (sort external-symbols #'string<) + inherited-symbols (sort inherited-symbols #'string<)) + `("" ;; dummy to preserve indentation. + "Name: " (:value ,package-name) (:newline) + + "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline) + + ,@(when (documentation package t) + `("Documentation:" (:newline) + ,(documentation package t) (:newline))) + + "Use list: " ,@(common-seperated-spec + package-use-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + "Used by list: " ,@(common-seperated-spec + package-used-by-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + ,(display-link "present" present-symbols present-symbols-length + :title + (format nil "All present symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered present in a package if it's" + (:newline) + "\"accessible in that package directly, rather than" + (:newline) + "being inherited from another package.\"" + (:newline) + "(CLHS glossary entry for `present')" + (:newline))) + + (:newline) + ,(display-link "external" external-symbols external-symbols-length + :title + (format nil "All external symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered external of a package if it's" + (:newline) + "\"part of the `external interface' to the package and" + (:newline) + "[is] inherited by any other package that uses the" + (:newline) + "package.\" (CLHS glossary entry of `external')" + (:newline))) + (:newline) + ,(display-link "internal" internal-symbols internal-symbols-length + :title + (format nil "All internal symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered internal of a package if it's" + (:newline) + "present and not external---that is if the package is" + (:newline) + "the home package of the symbol, or if the symbol has" + (:newline) + "been explicitly imported into the package." + (:newline) + (:newline) + "Notice that inherited symbols will thus not be listed," + (:newline) + "which deliberately deviates from the CLHS glossary" + (:newline) + "entry of `internal' because it's assumed to be more" + (:newline) + "useful this way." + (:newline))) + (:newline) + ,(display-link "inherited" inherited-symbols inherited-symbols-length + :title + (format nil "All inherited symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered inherited in a package if it" + (:newline) + "was made accessible via USE-PACKAGE." + (:newline))) + (:newline) + ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols) + :title + (format nil "All shadowed symbols of package \"~A\"" + package-name) + :description nil)))) + + +(defmethod emacs-inspect ((pathname pathname)) + `(,(if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + (:newline) + ,@(label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + ,@ (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname))))) + +(defmethod emacs-inspect ((pathname logical-pathname)) + (append + (label-value-line* + ("Namestring" (namestring pathname)) + ("Physical pathname: " (translate-logical-pathname pathname))) + `("Host: " + (:value ,(pathname-host pathname)) + " (" + (:value ,(logical-pathname-translations + (pathname-host pathname))) + " other translations)" + (:newline)) + (label-value-line* + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname)) + ("Truename" (if (not (wild-pathname-p pathname)) + (probe-file pathname)))))) + +(defmethod emacs-inspect ((n number)) + `("Value: " ,(princ-to-string n))) + +(defun format-iso8601-time (time-value &optional include-timezone-p) + "Formats a universal time TIME-VALUE in ISO 8601 format, with + the time zone included if INCLUDE-TIMEZONE-P is non-NIL" + ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html + ;; Thanks, Nikolai Sandved and Thomas Russ! + (flet ((format-iso8601-timezone (zone) + (if (zerop zone) + "Z" + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + ;; Tricky. Sign of time zone is reversed in ISO 8601 + ;; relative to Common Lisp convention! + (format nil "~:[+~;-~]~2,'0D:~2,'0D" + (> zone 0) h (round (* 60 m))))))) + (multiple-value-bind (second minute hour day month year dow dst zone) + (decode-universal-time time-value) + (declare (ignore dow)) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" + year month day hour minute second + include-timezone-p (format-iso8601-timezone (if dst + (+ zone 1) + zone)))))) + +(defmethod emacs-inspect ((i integer)) + (append + `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" + i i i i (ignore-errors (coerce i 'float))) + (:newline)) + (when (< -1 i char-code-limit) + (label-value-line "Code-char" (code-char i))) + (label-value-line "Integer-length" (integer-length i)) + (ignore-errors + (label-value-line "Universal-time" (format-iso8601-time i t))))) + +(defmethod emacs-inspect ((c complex)) + (label-value-line* + ("Real part" (realpart c)) + ("Imaginary part" (imagpart c)))) + +(defmethod emacs-inspect ((r ratio)) + (label-value-line* + ("Numerator" (numerator r)) + ("Denominator" (denominator r)) + ("As float" (float r)))) + +(defmethod emacs-inspect ((f float)) + (cond + ((float-nan-p f) + ;; try NaN first because the next tests may perform operations + ;; that are undefined for NaNs. + (list "Not a Number.")) + ((not (float-infinity-p f)) + (multiple-value-bind (significand exponent sign) (decode-float f) + (append + `("Scientific: " ,(format nil "~E" f) (:newline) + "Decoded: " + (:value ,sign) " * " + (:value ,significand) " * " + (:value ,(float-radix f)) "^" + (:value ,exponent) (:newline)) + (label-value-line "Digits" (float-digits f)) + (label-value-line "Precision" (float-precision f))))) + ((> f 0) + (list "Positive infinity.")) + ((< f 0) + (list "Negative infinity.")))) + +(defun make-pathname-ispec (pathname position) + `("Pathname: " + (:value ,pathname) + (:newline) " " + ,@(when position + `((:action "[visit file and show current position]" + ,(lambda () + (ed-in-emacs `(,pathname :position ,position :bytep t))) + :refreshp nil) + (:newline))))) + +(defun make-file-stream-ispec (stream) + ;; SBCL's socket stream are file-stream but are not associated to + ;; any pathname. + (let ((pathname (ignore-errors (pathname stream)))) + (when pathname + (make-pathname-ispec pathname (and (open-stream-p stream) + (file-position stream)))))) + +(defmethod emacs-inspect ((stream file-stream)) + (multiple-value-bind (content) + (call-next-method) + (append (make-file-stream-ispec stream) content))) + +(defmethod emacs-inspect ((condition stream-error)) + (multiple-value-bind (content) + (call-next-method) + (let ((stream (stream-error-stream condition))) + (append (when (typep stream 'file-stream) + (make-file-stream-ispec stream)) + content)))) + +(defun common-seperated-spec (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast + (loop + for i in list + collect (funcall callback i) + collect ", "))) + +(defun inspector-princ (list) + "Like princ-to-string, but don't rewrite (function foo) as #'foo. +Do NOT pass circular lists to this function." + (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) + (set-pprint-dispatch '(cons (member function)) nil) + (princ-to-string list))) + +(provide :swank-fancy-inspector) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-fuzzy.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-fuzzy.lisp new file mode 100644 index 0000000..bfd274f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-fuzzy.lisp @@ -0,0 +1,706 @@ +;;; swank-fuzzy.lisp --- fuzzy symbol completion +;; +;; Authors: Brian Downing +;; Tobias C. Rittweiler +;; and others +;; +;; License: Public Domain +;; + + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-util) + (swank-require :swank-c-p-c)) + +(defvar *fuzzy-duplicate-symbol-filter* :nearest-package + "Specifies how fuzzy-matching handles \"duplicate\" symbols. +Possible values are :NEAREST-PACKAGE, :HOME-PACKAGE, :ALL, or a custom +function. See Fuzzy Completion in the manual for details.") + +(export '*fuzzy-duplicate-symbol-filter*) + +;;; For nomenclature of the fuzzy completion section, please read +;;; through the following docstring. + +(defslimefun fuzzy-completions (string default-package-name + &key limit time-limit-in-msec) +"Returns a list of two values: + + An (optionally limited to LIMIT best results) list of fuzzy + completions for a symbol designator STRING. The list will be + sorted by score, most likely match first. + + A flag that indicates whether or not TIME-LIMIT-IN-MSEC has + been exhausted during computation. If that parameter's value is + NIL or 0, no time limit is assumed. + +The main result is a list of completion objects, where a completion +object is: + + (COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING) + +where a CHUNK is a description of a matched substring: + + (OFFSET SUBSTRING) + +and FLAGS is short string describing properties of the symbol (see +SYMBOL-CLASSIFICATION-STRING). + +E.g., completing \"mvb\" in a package that uses COMMON-LISP would +return something like: + + ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\")) + (:FBOUNDP :MACRO)) + ...) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +Which symbols are candidates for matching depends on the symbol +designator's format. The cases are as follows: + FOO - Symbols accessible in the buffer package. + PKG:FOO - Symbols external in package PKG. + PKG::FOO - Symbols accessible in package PKG." + ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC + ;; to denote an infinite time limit. Internally, we only use NIL for + ;; that purpose, to be able to distinguish between "no time limit + ;; alltogether" and "current time limit already exhausted." So we've + ;; got to canonicalize its value at first: + (let* ((no-time-limit-p (or (not time-limit-in-msec) + (zerop time-limit-in-msec))) + (time-limit (if no-time-limit-p nil time-limit-in-msec))) + (multiple-value-bind (completion-set interrupted-p) + (fuzzy-completion-set string default-package-name :limit limit + :time-limit-in-msec time-limit) + ;; We may send this as elisp [] arrays to spare a coerce here, + ;; but then the network serialization were slower by handling arrays. + ;; Instead we limit the number of completions that is transferred + ;; (the limit is set from Emacs.) + (list (coerce completion-set 'list) interrupted-p)))) + + +;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion +;;; object that will be sent back to Emacs, as described above. + +(defstruct (fuzzy-matching (:conc-name fuzzy-matching.) + (:predicate fuzzy-matching-p) + (:constructor make-fuzzy-matching + (symbol package-name score package-chunks + symbol-chunks &key (symbol-p t)))) + symbol ; The symbol that has been found to match. + symbol-p ; To deffirentiate between completeing + ; package: and package:nil + package-name ; The name of the package where SYMBOL was found in. + ; (This is not necessarily the same as the home-package + ; of SYMBOL, because the SYMBOL can be internal to + ; lots of packages; also think of package nicknames.) + score ; The higher the better SYMBOL is a match. + package-chunks ; Chunks pertaining to the package identifier of SYMBOL. + symbol-chunks) ; Chunks pertaining to SYMBOL's name. + +(defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string) + (multiple-value-bind (_ user-package-name __ input-internal-p) + (parse-completion-arguments user-input-string nil) + (declare (ignore _ __)) + (with-struct (fuzzy-matching. score symbol package-name package-chunks + symbol-chunks symbol-p) + fuzzy-matching + (let (symbol-name real-package-name internal-p) + (cond (symbol-p ; symbol fuzzy matching? + (setf symbol-name (symbol-name symbol)) + (setf internal-p input-internal-p) + (setf real-package-name (cond ((keywordp symbol) "") + ((not user-package-name) nil) + (t package-name)))) + (t ; package fuzzy matching? + (setf symbol-name "") + (setf real-package-name package-name) + ;; If no explicit package name was given by the user + ;; (e.g. input was "asdf"), we want to append only + ;; one colon ":" to the package names. + (setf internal-p (if user-package-name input-internal-p nil)))) + (values symbol-name + real-package-name + (if user-package-name internal-p nil) + (completion-output-symbol-converter user-input-string) + (completion-output-package-converter user-input-string)))))) + +(defun fuzzy-format-matching (fuzzy-matching user-input-string) + "Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING." + (multiple-value-bind (symbol-name package-name internal-p + symbol-converter package-converter) + (%fuzzy-extract-matching-info fuzzy-matching user-input-string) + (setq symbol-name (and symbol-name + (funcall symbol-converter symbol-name))) + (setq package-name (and package-name + (funcall package-converter package-name))) + (let ((result (untokenize-symbol package-name internal-p symbol-name))) + ;; We return the length of the possibly added prefix as second value. + (values result (search symbol-name result))))) + +(defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string) + "Converts a result from the fuzzy completion core into something +that emacs is expecting. Converts symbols to strings, fixes case +issues, and adds information (as a string) describing if the symbol is +bound, fbound, a class, a macro, a generic-function, a +special-operator, or a package." + (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks + symbol-p) + fuzzy-matching + (multiple-value-bind (name added-length) + (fuzzy-format-matching fuzzy-matching user-input-string) + (list name + (format nil "~,2f" score) + (append package-chunks + (mapcar (lambda (chunk) + ;; Fix up chunk positions to account for possible + ;; added package identifier. + (let ((offset (first chunk)) + (string (second chunk))) + (list (+ added-length offset) string))) + symbol-chunks)) + (if symbol-p + (symbol-classification-string symbol) + "-------p"))))) + +(defun fuzzy-completion-set (string default-package-name + &key limit time-limit-in-msec) + "Returns two values: an array of completion objects, sorted by +their score, that is how well they are a match for STRING +according to the fuzzy completion algorithm. If LIMIT is set, +only the top LIMIT results will be returned. Additionally, a flag +is returned that indicates whether or not TIME-LIMIT-IN-MSEC was +exhausted." + (check-type limit (or null (integer 0 #.(1- most-positive-fixnum)))) + (check-type time-limit-in-msec + (or null (integer 0 #.(1- most-positive-fixnum)))) + (multiple-value-bind (matchings interrupted-p) + (fuzzy-generate-matchings string default-package-name time-limit-in-msec) + (when (and limit + (> limit 0) + (< limit (length matchings))) + (if (array-has-fill-pointer-p matchings) + (setf (fill-pointer matchings) limit) + (setf matchings (make-array limit :displaced-to matchings)))) + (map-into matchings #'(lambda (m) + (fuzzy-convert-matching-for-emacs m string)) + matchings) + (values matchings interrupted-p))) + + +(defun fuzzy-generate-matchings (string default-package-name + time-limit-in-msec) + "Does all the hard work for FUZZY-COMPLETION-SET. If +TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed." + (multiple-value-bind (parsed-symbol-name parsed-package-name + package internal-p) + (parse-completion-arguments string default-package-name) + (flet ((fix-up (matchings parent-package-matching) + ;; The components of each matching in MATCHINGS have been computed + ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute. + (let* ((p parent-package-matching) + (p.name (fuzzy-matching.package-name p)) + (p.score (fuzzy-matching.score p)) + (p.chunks (fuzzy-matching.package-chunks p))) + (map-into + matchings + (lambda (m) + (let ((m.score (fuzzy-matching.score m))) + (setf (fuzzy-matching.package-name m) p.name) + (setf (fuzzy-matching.package-chunks m) p.chunks) + (setf (fuzzy-matching.score m) + (if (equal parsed-symbol-name "") + ;; Make package matchings be sorted before all + ;; the relative symbol matchings while preserving + ;; over all orderness. + (/ p.score 100) + (+ p.score m.score))) + m)) + matchings))) + (find-symbols (designator package time-limit &optional filter) + (fuzzy-find-matching-symbols designator package + :time-limit-in-msec time-limit + :external-only (not internal-p) + :filter (or filter #'identity))) + (find-packages (designator time-limit) + (fuzzy-find-matching-packages designator + :time-limit-in-msec time-limit)) + (maybe-find-local-package (name) + (or (find-locally-nicknamed-package name *buffer-package*) + (find-package name)))) + (let ((time-limit time-limit-in-msec) (symbols) (packages) (results) + (dedup-table (make-hash-table :test #'equal))) + (cond ((not parsed-package-name) ; E.g. STRING = "asd" + ;; We don't know if user is searching for a package or a symbol + ;; within his current package. So we try to find either. + (setf (values packages time-limit) + (find-packages parsed-symbol-name time-limit)) + (setf (values symbols time-limit) + (find-symbols parsed-symbol-name package time-limit))) + ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo" + (setf (values symbols time-limit) + (find-symbols parsed-symbol-name package time-limit))) + (t ; E.g. STRING = "asd:" or "asd:foo" + ;; Find fuzzy matchings of the denoted package identifier part. + ;; After that, find matchings for the denoted symbol identifier + ;; relative to all the packages found. + (multiple-value-bind (symbol-packages rest-time-limit) + (find-packages parsed-package-name time-limit-in-msec) + ;; We want to traverse the found packages in the order of + ;; their score, since those with higher score presumably + ;; represent better choices. (This is important because some + ;; packages may never be looked at if time limit exhausts + ;; during traversal.) + (setf symbol-packages + (sort symbol-packages #'fuzzy-matching-greaterp)) + (loop + for package-matching across symbol-packages + for package = (maybe-find-local-package + (fuzzy-matching.package-name + package-matching)) + while (or (not time-limit) (> rest-time-limit 0)) do + (multiple-value-bind (matchings remaining-time) + ;; The duplication filter removes all those symbols + ;; which are present in more than one package + ;; match. See *FUZZY-DUPLICATE-SYMBOL-FILTER* + (find-symbols parsed-symbol-name package rest-time-limit + (%make-duplicate-symbols-filter + package-matching symbol-packages dedup-table)) + (setf matchings (fix-up matchings package-matching)) + (setf symbols (concatenate 'vector symbols matchings)) + (setf rest-time-limit remaining-time) + (let ((guessed-sort-duration + (%guess-sort-duration (length symbols)))) + (when (and rest-time-limit + (<= rest-time-limit guessed-sort-duration)) + (decf rest-time-limit guessed-sort-duration) + (loop-finish)))) + finally + (setf time-limit rest-time-limit) + (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:" + (setf packages symbol-packages)))))) + ;; Sort by score; thing with equal score, sort alphabetically. + ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all + ;; possible completions are to be returned.) + (setf results (concatenate 'vector symbols packages)) + (setf results (sort results #'fuzzy-matching-greaterp)) + (values results (and time-limit (<= time-limit 0))))))) + +(defun %guess-sort-duration (length) + ;; These numbers are pretty much arbitrary, except that they're + ;; vaguely correct on my machine with SBCL. Yes, this is an ugly + ;; kludge, but it's better than before (where this didn't exist at + ;; all, which essentially meant, that this was taken to be 0.) + (if (zerop length) + 0 + (let ((comparasions (* 3.8 (* length (log length 2))))) + (* 1000 (* comparasions (expt 10 -7)))))) ; msecs + +(defun %make-duplicate-symbols-filter (current-package-matching fuzzy-package-matchings dedup-table) + ;; Returns a filter function based on *FUZZY-DUPLICATE-SYMBOL-FILTER*. + (case *fuzzy-duplicate-symbol-filter* + (:home-package + ;; Return a filter function that takes a symbol, and which returns T + ;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents + ;; the home-package of the symbol passed. + (let ((packages (mapcar #'(lambda (m) + (find-package (fuzzy-matching.package-name m))) + (remove current-package-matching + (coerce fuzzy-package-matchings 'list))))) + #'(lambda (symbol) + (not (member (symbol-package symbol) packages))))) + (:nearest-package + ;; Keep only the first occurence of the symbol. + #'(lambda (symbol) + (unless (gethash (symbol-name symbol) dedup-table) + (setf (gethash (symbol-name symbol) dedup-table) t)))) + (:all + ;; No filter + #'identity) + (t + (typecase *fuzzy-duplicate-symbol-filter* + (function + ;; Custom filter + (funcall *fuzzy-duplicate-symbol-filter* + (fuzzy-matching.package-name current-package-matching) + (map 'list #'fuzzy-matching.package-name fuzzy-package-matchings) + dedup-table)) + (t + ;; Bad filter value + (warn "bad *FUZZY-DUPLICATE-SYMBOL-FILTER* value: ~s" + *fuzzy-duplicate-symbol-filter*) + #'identity))))) + +(defun fuzzy-matching-greaterp (m1 m2) + "Returns T if fuzzy-matching M1 should be sorted before M2. +Basically just the scores of the two matchings are compared, and +the match with higher score wins. For the case that the score is +equal, the one which comes alphabetically first wins." + (declare (type fuzzy-matching m1 m2)) + (let ((score1 (fuzzy-matching.score m1)) + (score2 (fuzzy-matching.score m2))) + (cond ((> score1 score2) t) + ((< score1 score2) nil) ; total order + (t + (let ((name1 (symbol-name (fuzzy-matching.symbol m1))) + (name2 (symbol-name (fuzzy-matching.symbol m2)))) + (string< name1 name2)))))) + +(declaim (ftype (function () (integer 0)) get-real-time-msecs)) +(defun get-real-time-in-msecs () + (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000)))) + (values (floor (get-internal-real-time) units-per-msec)))) + +(defun fuzzy-find-matching-symbols + (string package &key (filter #'identity) external-only time-limit-in-msec) + "Returns two values: a vector of fuzzy matchings for matching +symbols in PACKAGE, using the fuzzy completion algorithm, and the +remaining time limit. + +Only those symbols are considered of which FILTER does return T. + +If EXTERNAL-ONLY is true, only external symbols are considered. A +TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or +negative, perform a NOP." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (package-name (package-name package)) + (count 0)) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type (integer 0 #.(1- most-positive-fixnum)) count)) + + (flet ((recompute-remaining-time (old-remaining-time) + (cond ((not time-limit-p) + ;; propagate NIL back as infinite time limit + (values nil nil)) + ((> count 0) ; ease up on getting internal time like crazy + (setf count (mod (1+ count) 128)) + (values nil old-remaining-time)) + (t (let* ((elapsed-time (- (get-real-time-in-msecs) + rtime-at-start)) + (remaining (- time-limit elapsed-time))) + (values (<= remaining 0) remaining))))) + (perform-fuzzy-match (string symbol-name) + (let* ((converter (completion-output-symbol-converter string)) + (converted-symbol-name (funcall converter symbol-name))) + (compute-highest-scoring-completion string + converted-symbol-name)))) + (let ((completions (make-array 256 :adjustable t :fill-pointer 0)) + (rest-time-limit time-limit)) + (do-symbols* (symbol package) + (multiple-value-bind (exhausted? remaining-time) + (recompute-remaining-time rest-time-limit) + (setf rest-time-limit remaining-time) + (cond (exhausted? (return)) + ((not (and (or (not external-only) + (symbol-external-p symbol package)) + (funcall filter symbol)))) + ((string= "" string) ; "" matches always + (vector-push-extend + (make-fuzzy-matching symbol package-name + 0.0 '() '()) + completions)) + (t + (multiple-value-bind (match-result score) + (perform-fuzzy-match string (symbol-name symbol)) + (when match-result + (vector-push-extend + (make-fuzzy-matching symbol package-name score + '() match-result) + completions))))))) + (values completions rest-time-limit))))) + +(defun fuzzy-find-matching-packages (name &key time-limit-in-msec) + "Returns a vector of fuzzy matchings for each package that is +similiar to NAME, and the remaining time limit. +Cf. FUZZY-FIND-MATCHING-SYMBOLS." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (converter (completion-output-package-converter name)) + (completions (make-array 32 :adjustable t :fill-pointer 0))) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type function converter)) + (flet ((match-package (names) + (loop with max-pkg-name = "" + with max-result = nil + with max-score = 0 + for package-name in names + for converted-name = (funcall converter package-name) + do + (multiple-value-bind (result score) + (compute-highest-scoring-completion name + converted-name) + (when (and result (> score max-score)) + (setf max-pkg-name package-name) + (setf max-result result) + (setf max-score score))) + finally + (when max-result + (vector-push-extend + (make-fuzzy-matching nil max-pkg-name + max-score max-result '() + :symbol-p nil) + completions))))) + (cond ((and time-limit-p (<= time-limit 0)) + (values #() time-limit)) + (t + (loop for (nick) in (package-local-nicknames *buffer-package*) + do + (match-package (list nick))) + (loop for package in (list-all-packages) + do + ;; Find best-matching package-nickname: + (match-package (package-names package)) + finally + (return + (values completions + (and time-limit-p + (let ((elapsed-time (- (get-real-time-in-msecs) + rtime-at-start))) + (- time-limit elapsed-time))))))))))) + + +(defslimefun fuzzy-completion-selected (original-string completion) + "This function is called by Slime when a fuzzy completion is +selected by the user. It is for future expansion to make +testing, say, a machine learning algorithm for completion scoring +easier. + +ORIGINAL-STRING is the string the user completed from, and +COMPLETION is the completion object (see docstring for +SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the +user selected." + (declare (ignore original-string completion)) + nil) + + +;;;;; Fuzzy completion core + +(defparameter *fuzzy-recursion-soft-limit* 30 + "This is a soft limit for recursion in +RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit, +completing a string such as \"ZZZZZZ\" with a symbol named +\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to +find all the ways it can match. + +Most natural language searches and symbols do not have this +problem -- this is only here as a safeguard.") +(declaim (fixnum *fuzzy-recursion-soft-limit*)) + +(defvar *all-chunks* '()) +(declaim (type list *all-chunks*)) + +(defun compute-highest-scoring-completion (short full) + "Finds the highest scoring way to complete the abbreviation +SHORT onto the string FULL, using CHAR= as a equality function for +letters. Returns two values: The first being the completion +chunks of the highest scorer, and the second being the score." + (let* ((scored-results + (mapcar #'(lambda (result) + (cons (score-completion result short full) result)) + (compute-most-completions short full))) + (winner (first (sort scored-results #'> :key #'first)))) + (values (rest winner) (first winner)))) + +(defun compute-most-completions (short full) + "Finds most possible ways to complete FULL with the letters in SHORT. +Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns +a list of (&rest CHUNKS), where each CHUNKS is a description of +how a completion matches." + (let ((*all-chunks* nil)) + (recursively-compute-most-completions short full 0 0 nil nil nil t) + *all-chunks*)) + +(defun recursively-compute-most-completions + (short full + short-index initial-full-index + chunks current-chunk current-chunk-pos + recurse-p) + "Recursively (if RECURSE-P is true) find /most/ possible ways +to fuzzily map the letters in SHORT onto FULL, using CHAR= to +determine if two letters match. + +A chunk is a list of elements that have matched consecutively. +When consecutive matches stop, it is coerced into a string, +paired with the starting position of the chunk, and pushed onto +CHUNKS. + +Whenever a letter matches, if RECURSE-P is true, +RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position +one index ahead, to find other possibly higher scoring +possibilities. If there are less than +*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently, +this call will also recurse. + +Once a word has been completely matched, the chunks are pushed +onto the special variable *ALL-CHUNKS* and the function returns." + (declare (optimize speed) + (type fixnum short-index initial-full-index) + (type list current-chunk) + (simple-string short full)) + (flet ((short-cur () + "Returns the next letter from the abbreviation, or NIL + if all have been used." + (if (= short-index (length short)) + nil + (aref short short-index))) + (add-to-chunk (char pos) + "Adds the CHAR at POS in FULL to the current chunk, + marking the start position if it is empty." + (unless current-chunk + (setf current-chunk-pos pos)) + (push char current-chunk)) + (collect-chunk () + "Collects the current chunk to CHUNKS and prepares for + a new chunk." + (when current-chunk + (let ((current-chunk-as-string + (nreverse + (make-array (length current-chunk) + :element-type 'character + :initial-contents current-chunk)))) + (push (list current-chunk-pos current-chunk-as-string) chunks) + (setf current-chunk nil + current-chunk-pos nil))))) + ;; If there's an outstanding chunk coming in collect it. Since + ;; we're recursively called on skipping an input character, the + ;; chunk can't possibly continue on. + (when current-chunk (collect-chunk)) + (do ((pos initial-full-index (1+ pos))) + ((= pos (length full))) + (let ((cur-char (aref full pos))) + (if (and (short-cur) + (char= cur-char (short-cur))) + (progn + (when recurse-p + ;; Try other possibilities, limiting insanely deep + ;; recursion somewhat. + (recursively-compute-most-completions + short full short-index (1+ pos) + chunks current-chunk current-chunk-pos + (not (> (length *all-chunks*) + *fuzzy-recursion-soft-limit*)))) + (incf short-index) + (add-to-chunk cur-char pos)) + (collect-chunk)))) + (collect-chunk) + ;; If we've exhausted the short characters we have a match. + (if (short-cur) + nil + (let ((rev-chunks (reverse chunks))) + (push rev-chunks *all-chunks*) + rev-chunks)))) + + +;;;;; Fuzzy completion scoring + +(defvar *fuzzy-completion-symbol-prefixes* "*+-%&?<" + "Letters that are likely to be at the beginning of a symbol. +Letters found after one of these prefixes will be scored as if +they were at the beginning of ths symbol.") +(defvar *fuzzy-completion-symbol-suffixes* "*+->" + "Letters that are likely to be at the end of a symbol. +Letters found before one of these suffixes will be scored as if +they were at the end of the symbol.") +(defvar *fuzzy-completion-word-separators* "-/." + "Letters that separate different words in symbols. Letters +after one of these symbols will be scores more highly than other +letters.") + +(defun score-completion (completion short full) + "Scores the completion chunks COMPLETION as a completion from +the abbreviation SHORT to the full string FULL. COMPLETION is a +list like: + ((0 \"mul\") (9 \"v\") (15 \"b\")) +Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\", +would indicate that it completed as such (completed letters +capitalized): + MULtiple-Value-Bind + +Letters are given scores based on their position in the string. +Letters at the beginning of a string or after a prefix letter at +the beginning of a string are scored highest. Letters after a +word separator such as #\- are scored next highest. Letters at +the end of a string or before a suffix letter at the end of a +string are scored medium, and letters anywhere else are scored +low. + +If a letter is directly after another matched letter, and its +intrinsic value in that position is less than a percentage of the +previous letter's value, it will use that percentage instead. + +Finally, a small scaling factor is applied to favor shorter +matches, all other things being equal." + (labels ((at-beginning-p (pos) + (= pos 0)) + (after-prefix-p (pos) + (and (= pos 1) + (find (aref full 0) *fuzzy-completion-symbol-prefixes*))) + (word-separator-p (pos) + (find (aref full pos) *fuzzy-completion-word-separators*)) + (after-word-separator-p (pos) + (find (aref full (1- pos)) *fuzzy-completion-word-separators*)) + (at-end-p (pos) + (= pos (1- (length full)))) + (before-suffix-p (pos) + (and (= pos (- (length full) 2)) + (find (aref full (1- (length full))) + *fuzzy-completion-symbol-suffixes*))) + (score-or-percentage-of-previous (base-score pos chunk-pos) + (if (zerop chunk-pos) + base-score + (max base-score + (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85) + (expt 1.2 chunk-pos))))) + (score-char (pos chunk-pos) + (score-or-percentage-of-previous + (cond ((at-beginning-p pos) 10) + ((after-prefix-p pos) 10) + ((word-separator-p pos) 1) + ((after-word-separator-p pos) 8) + ((at-end-p pos) 6) + ((before-suffix-p pos) 6) + (t 1)) + pos chunk-pos)) + (score-chunk (chunk) + (loop for chunk-pos below (length (second chunk)) + for pos from (first chunk) + summing (score-char pos chunk-pos)))) + (let* ((chunk-scores (mapcar #'score-chunk completion)) + (length-score (/ 10.0 (1+ (- (length full) (length short)))))) + (values + (+ (reduce #'+ chunk-scores) length-score) + (list (mapcar #'list chunk-scores completion) length-score))))) + +(defun highlight-completion (completion full) + "Given a chunk definition COMPLETION and the string FULL, +HIGHLIGHT-COMPLETION will create a string that demonstrates where +the completion matched in the string. Matches will be +capitalized, while the rest of the string will be lower-case." + (let ((highlit (nstring-downcase (copy-seq full)))) + (dolist (chunk completion) + (setf highlit (nstring-upcase highlit + :start (first chunk) + :end (+ (first chunk) + (length (second chunk)))))) + highlit)) + +(defun format-fuzzy-completion-set (winners) + "Given a list of completion objects such as on returned by +FUZZY-COMPLETION-SET, format the list into user-readable output +for interactive debugging purpose." + (let ((max-len + (loop for winner in winners maximizing (length (first winner))))) + (loop for (sym score result) in winners do + (format t "~&~VA score ~8,2F ~A" + max-len (highlight-completion result sym) score result)))) + +(provide :swank-fuzzy) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-goo.goo b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-goo.goo new file mode 100644 index 0000000..562401d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-goo.goo @@ -0,0 +1,995 @@ +;;;; swank-goo.goo --- Swank server for GOO +;;; +;;; Copyright (C) 2005 Helmut Eller +;;; +;;; This file is licensed under the terms of the GNU General Public +;;; License as distributed with Emacs (press C-h C-c to view it). + +;;;; Installation +;; +;; 1. Add something like this to your .emacs: +;; +;; (setq slime-lisp-implementations +;; '((goo ("g2c") :init goo-slime-init))) +;; +;; (defun goo-slime-init (file _) +;; (format "%S\n%S\n" +;; `(set goo/system:*module-search-path* +;; (cat '(".../slime/contrib/") +;; goo/system:*module-search-path*)) +;; `(swank-goo:start-swank ,file))) +;; +;; 2. Start everything with M-- M-x slime goo +;; + +;;;; Code + +(use goo) +(use goo/boot) +(use goo/x) +(use goo/io/port) +(use goo/io/write) +(use goo/eval) +(use goo/system) +(use goo/conditions) +(use goo/fun) +(use goo/loc) +(use goo/chr) +(use eval/module) +(use eval/ast) +(use eval/g2c) + + +;;;; server setup + +(df create-server (port-number) (setup-server port-number announce-port)) + +(df start-swank (port-file) + (setup-server 0 (fun (s) (write-port-file (%local-port s) port-file)))) + +(df setup-server (port-number announce) + (let ((s (create-socket port-number))) + (fin (seq + (announce s) + (let ((c (accept s))) + ;;(post "connection: %s" c) + (fin (serve-requests c) + (%close (@fd c))))) + (post "closing socket: %s" s) + (%close s)))) + +(df announce-port (socket) + (post "Listening on port: %d\n" (%local-port socket))) + +(df write-port-file (port-number filename) + (with-port (file (open filename)) + (msg file "%d\n" port-number))) + +(dc ()) + +(dc ()) +(dp @socket ( => )) +(dp @in ( => )) +(dp @out ( => )) + +(dv emacs-connection|(t? ) #f) + +(df serve-requests (socket) + (dlet ((emacs-connection (new + @socket socket + @out (new @socket socket) + @in (new @socket socket)))) + (dlet ((out (@out emacs-connection)) + (in (@in emacs-connection))) + (while #t + (simple-restart + "SLIME top-level" + (fun () (process-next-event socket))))))) + +(d. (t= 'nil)) +(d. t #t) +(d. cons pair) + +(dv tag-counter| 0) + +(df process-next-event (port) (dispatch-event (decode-message port) port)) + +(df dispatch-event (event port) + ;; (post "%=\n" event) + (match event + ((:emacs-rex ,form ,package ,_thread-id ,id) + (eval-for-emacs form package port id)) + ((:read-string ,_) + (def tag (incf tag-counter)) + (encode-message `(:read-string ,_ ,tag) port) + (rep loop () + (match (decode-message port) + ((:emacs-return-string ,_ ,rtag ,str) + (assert (= tag rtag) "Unexpected reply tag: %d" rtag) + str) + ((,@evt) + (try-recover + (fun () (dispatch-event evt port)) + (fun () (encode-message `(:read-aborted ,_ ,tag) port))) + (loop))))) + ((:emacs-return-string ,_ ,rtag ,str) + (error "Unexpected event: %=" event)) + ((,@_) (encode-message event port)))) + +(dc ()) +(dp @module ( => )) +(dp @id ( => )) +(dp @port ( => )) +(dp @prev ( => (t? ))) + +;; should be ddv +(dv eval-context|(t? ) #f) + +(df buffer-module () (@module eval-context)) + +(df eval-for-emacs (form| package|(t+ ) port id|) + (try-recover + (fun () + (try debugger-hook + (dlet ((eval-context (new + @module (find-buffer-module package) @id id + @port port @prev eval-context))) + (def result (eval (frob-form-for-eval form) 'swank-goo)) + (force-out out) + (dispatch-event `(:return (:ok ,result) ,id) port)))) + (fun () (dispatch-event `(:return (:abort) ,id) port)))) + +(dm find-buffer-module (name| => ) + (or (elt-or (all-modules) (as-sym name) #f) + (find-buffer-module 'nil))) + +(dm find-buffer-module (name| => ) default-module) + +(dv default-module| (runtime-module 'goo/user)) + +(d. slimefuns (fab 100)) + +(ds defslimefun (,name ,args ,@body) + `(set (elt slimefuns ',name) + (df ,(cat-sym 'swank@ name) ,args ,@body))) + +(df slimefun (name) + (or (elt-or slimefuns name #f) + (error "Undefined slimefun: %=" name))) + +;; rewrite (swank:foo ...) to ((slimefun 'foo) ...) +(df frob-form-for-eval (form) + (match form + ((,op ,@args) + (match (map as-sym (split (sym-name op) #\:)) + ((swank ,name) + `((slimefun ',name) ,@args)))))) + + +;;;; debugger + +(dc ()) +(dp @level ( => )) +(dp @top-frame ( => )) +(dp @restarts ( => )) +(dp @condition ( => )) +(dp @eval-context ( => (t? ))) + +(dv sldb-context|(t? ) #f) + +(df debugger-hook (c| resume) + (let ((tf (find-top-frame 'debugger-hook 2)) + (rs (compute-restarts c)) + (l (if sldb-context (1+ (@level sldb-context)) 1))) + (cond ((> l 10) (emergency-abort c)) + (#t + (dlet ((sldb-context (new + @level l @top-frame tf + @restarts rs @condition c + @eval-context eval-context))) + (let ((bt (compute-backtrace tf 0 10))) + (force-out out) + (dispatch-event `(:debug 0 ,l + ,@(debugger-info c rs bt eval-context)) + (@port eval-context)) + (sldb-loop l (@port eval-context)))))))) + +(df emergency-abort (c) + (post "Maximum debug level reached aborting...\n") + (post "%s\n" (describe-condition c)) + (do-stack-frames (fun (f args) (msg out " %= %=\n" f args))) + (invoke-handler-interactively (find-restart ) in out)) + +(df sldb-loop (level port) + (fin (while #t + (dispatch-event `(:debug-activate 0 ,level) port) + (simple-restart + (msg-to-str "Return to SLDB level %s" level) + (fun () (process-next-event port)))) + (dispatch-event `(:debug-return 0 ,level nil) port))) + +(defslimefun backtrace (start| end|(t+ )) + (backtrace-for-emacs + (compute-backtrace (@top-frame sldb-context) + start + (if (isa? end ) end #f)))) + +(defslimefun throw-to-toplevel () + (invoke-handler-interactively (find-restart ) in out)) + +(defslimefun invoke-nth-restart-for-emacs (sldb-level| n|) + (when (= (@level sldb-context) sldb-level) + (invoke-handler-interactively (elt (@restarts sldb-context) n) in out))) + +(defslimefun debugger-info-for-emacs (start end) + (debugger-info (@condition sldb-context) + (@restarts sldb-context) + (compute-backtrace (@top-frame sldb-context) + start + (if (isa? end ) end #f)))) + +(defslimefun frame-locals-and-catch-tags (frame-idx) + (def frame (nth-frame frame-idx)) + (list + (map-keyed (fun (i name) + (lst ':name (sym-name name) ':id 0 + ':value (safe-write-to-string (frame-var-value frame i)))) + (frame-var-names frame)) + '())) + +(defslimefun inspect-frame-var (frame-idx var-idx) + (reset-inspector) + (inspect-object (frame-var-value (nth-frame frame-idx) var-idx))) + +(defslimefun inspect-current-condition () + (reset-inspector) + (inspect-object (@condition sldb-context))) + +(defslimefun frame-source-location (frame-idx) + (match (nth-frame frame-idx) + ((,f ,@_) + (or (emacs-src-loc f) + `(:error ,(msg-to-str "No src-loc available for: %s" f)))))) + +(defslimefun eval-string-in-frame (string frame-idx) + (def frame (nth-frame frame-idx)) + (let ((names (frame-var-names frame)) + (values (frame-var-values frame))) + (write-to-string + (app (eval `(fun ,names ,(read-from-string string)) + (module-name (buffer-module))) + values)))) + +(df debugger-info (condition restarts backtrace eval-context) + (lst `(,(try-or (fun () (describe-condition condition)) "<...>") + ,(cat " [class: " (class-name-str condition) "]") + ()) + (restarts-for-emacs restarts) + (backtrace-for-emacs backtrace) + (pending-continuations eval-context))) + +(df backtrace-for-emacs (backtrace) + (map (fun (f) + (match f + ((,idx (,f ,@args)) + (lst idx (cat (if (fun-name f) + (sym-name (fun-name f)) + (safe-write-to-string f)) + (safe-write-to-string args)))))) + backtrace)) + +(df restarts-for-emacs (restarts) + (map (fun (x) `(,(sym-name (class-name (%handler-condition-type x))) + ,(describe-restart x))) + restarts)) + +(df describe-restart (restart) + (describe-handler (%handler-info restart) (%handler-condition-type restart))) + +(df compute-restarts (condition) + (packing (%do-handlers-of-type (fun (c) (pack c))))) + +(df find-restart (type) + (esc ret + (%do-handlers-of-type type ret) + #f)) + +(df pending-continuations (context|(t? )) + (if context + (pair (@id context) (pending-continuations (@prev context))) + '())) + +(df find-top-frame (fname| offset|) + (esc ret + (let ((top-seen? #f)) + (do-stack-frames (fun (f args) + (cond (top-seen? + (cond ((== offset 0) + (ret (pair f args))) + (#t (decf offset)))) + ((== (fun-name f) fname) + (set top-seen? #t)))))))) + +(df compute-backtrace (top-frame start| end) + (packing + (esc break + (do-user-frames (fun (idx f args) + (when (and end (<= end idx)) + (break #f)) + (when (<= start idx) + (pack (lst idx (pair f args))))) + top-frame)))) + +(df nth-frame (n|) + (esc ret + (do-user-frames + (fun (idx f args) + (when (= idx n) + (ret (pair f args)))) + (@top-frame sldb-context)))) + +(df frame-var-value (frame var-idx) + (match frame + ((,f ,@args) + (def sig (fun-sig f)) + (def arity (sig-arity sig)) + (def nary? (sig-nary? sig)) + (cond ((< var-idx arity) (elt args var-idx)) + (nary? (sub* args arity)))))) + +(df frame-var-names (frame) + (match frame + ((,f ,@_) (fun-info-names (fun-info f))))) + +(df frame-var-values (frame) + (map (curry frame-var-value frame) (keys (frame-var-names frame)))) + +(df do-user-frames (f| top-frame) + (let ((idx -1) + (top-seen? #f)) + (do-stack-frames + (fun (ffun args) + (cond (top-seen? + (incf idx) + (f idx ffun (rev args))) + ((= (pair ffun args) top-frame) + (set top-seen? #t))))))) + + +;;;; Write some classes a little less verbose + +;; (dm recurring-write (port| x d| recur|) +;; (msg port "#{%s &%s}" (class-name-str x) +;; (num-to-str-base (address-of x) 16))) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s %s}" (class-name-str x) (module-name x))) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s %s}" (class-name-str x) (binding-name x))) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s %s}" (class-name-str x) (len x))) + +(dm recurring-write (port| x| + d| recur|) + (msg port "#{%s}" (class-name-str x))) + +(dm recurring-write (port| x| + d| recur|) + (msg port "#{%s}" (class-name-str x))) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s %s:%=}" (class-name-str x) + (src-loc-file x) (src-loc-line x))) + + +;;;; Inspector + +(dc ()) +(dp! @object ( => )) +(dp! @parts ( => ) (new )) +(dp! @stack ( => ) '()) + +(dv inspector #f) + +(defslimefun init-inspector (form|) + (reset-inspector) + (inspect-object (str-eval form (buffer-module)))) + +(defslimefun quit-inspector () (reset-inspector) 'nil) + +(defslimefun inspect-nth-part (n|) + (inspect-object (elt (@parts inspector) n))) + +(defslimefun inspector-pop () + (cond ((<= 2 (len (@stack inspector))) + (popf (@stack inspector)) + (inspect-object (popf (@stack inspector)))) + (#t 'nil))) + +(df reset-inspector () (set inspector (new ))) + +(df inspect-object (o) + (set (@object inspector) o) + (set (@parts inspector) (new )) + (pushf (@stack inspector) o) + (lst ':title (safe-write-to-string o) ; ':type (class-name-str o) + ':content (inspector-content + `("class: " (:value ,(class-of o)) "\n" + ,@(inspect o))))) + +(df inspector-content (content) + (map (fun (part) + (case-by part isa? + (() part) + (() + (match part + ((:value ,o ,@str) + `(:value ,@(if (nul? str) + (lst (safe-write-to-string o)) + str) + ,(assign-index o))))) + (#t (error "Bad inspector content: %=" part)))) + content)) + +(df assign-index (o) + (pushf (@parts inspector) o) + (1- (len (@parts inspector)))) + +(dg inspect (o)) + +;; a list of dangerous functions +(d. getter-blacklist (lst fun-code fun-env class-row)) + +(dm inspect (o) + (join (map (fun (p) + (let ((getter (prop-getter p))) + `(,(sym-name (fun-name getter)) ": " + ,(cond ((mem? getter-blacklist getter) "<...>") + ((not (prop-bound? o getter)) "") + (#t (try-or (fun () `(:value ,(getter o))) + "<...>")))))) + (class-props (class-of o))) + '("\n"))) + +(dm inspect (o|) + (join (packing (do-keyed (fun (pos val) + (pack `(,(num-to-str pos) ": " (:value ,val)))) + o)) + '("\n"))) + +(dm inspect (o|) + (join (packing (do-keyed (fun (key val) + (pack `((:value ,key) "\t: " (:value ,val)))) + o)) + '("\n"))) + +;; inspecting the env of closures is broken +;; (dm inspect (o|) +;; (cat (sup o) +;; '("\n") +;; (if (%fun-env? o) +;; (inspect (packing (for ((i (below (%fun-env-len o)))) +;; (pack (%fun-env-elt o i))))) +;; '()))) +;; +;; (df %fun-env? (f| => ) #eb{ FUNENV($f) != $#f }) +;; (df %fun-env-len (f| => ) #ei{ ((ENV)FUNENV ($f))->size }) +;; (df %fun-env-elt (f| i| => ) #eg{ FUNENVGET($f, @i) }) + + +;;;; init + +(defslimefun connection-info () + `(:pid + ,(process-id) :style nil + :lisp-implementation (:type "GOO" :name "goo" + :version ,(%lookup '*goo-version* 'eval/main)) + :machine (:instance "" :type "" :version "") + :features () + :package (:name "goo/user" :prompt "goo/user"))) + +(defslimefun quit-lisp () #ei{ exit (0),0 }) + +(defslimefun set-default-directory (dir|) #ei{ chdir(@dir) } dir) + + +;;;; eval + +(defslimefun ping () "PONG") + +(defslimefun create-repl (_) + (let ((name (sym-name (module-name (buffer-module))))) + `(,name ,name))) + +(defslimefun listener-eval (string) + (clear-input in) + `(:values ,(write-to-string (str-eval string (buffer-module))))) + +(defslimefun interactive-eval (string) + (cat "=> " (write-to-string (str-eval string (buffer-module))))) + +(df str-eval (s| m|) + (eval (read-from-string s) (module-name m))) + +(df clear-input (in|) (while (ready? in) (get in))) + +(dc ()) + +(defslimefun simple-break () + (simple-restart + "Continue from break" + (fun () (sig (new + condition-message "Interrupt from Emacs")))) + 'nil) + +(defslimefun clear-repl-results () 'nil) + + +;;;; compile + +(defslimefun compile-string-for-emacs (string buffer position directory) + (def start (current-time)) + (def r (g2c-eval (read-from-string string) + (module-target-environment (buffer-module)))) + (lst (write-to-string r) + (/ (as (- (current-time) start)) 1000000.0))) + +(defslimefun compiler-notes-for-emacs () 'nil) + +(defslimefun filename-to-modulename (filename| => (t+ )) + (try-or (fun () (sym-name (filename-to-modulename filename))) 'nil)) + +(df filename-to-modulename (filename| => ) + (def paths (map pathname-to-components + (map simplify-filename + (pick file-exists? *module-search-path*)))) + (def filename (pathname-to-components filename)) + (def moddir (rep parent ((modpath filename)) + (cond ((any? (curry = modpath) paths) + modpath) + (#t + (parent (components-parent-directory modpath)))))) + (def modfile (components-to-pathname (sub* filename (len moddir)))) + (as-sym (sub modfile 0 (- (len modfile) (len *goo-extension*))))) + + + +;;;; Load + +(defslimefun load-file (filename) + (let ((file (cond ((= (sub (rev filename) 0 4) "oog.") filename) + (#t (cat filename ".goo"))))) + (safe-write-to-string (load-file file (filename-to-modulename file))))) + + +;;;; background activities + +(defslimefun operator-arglist (op _) + (try-or (fun () + (let ((value (str-eval op (buffer-module)))) + (if (isa? value ) + (write-to-string value) + 'nil))) + 'nil)) + + +;;;; M-. + +(defslimefun find-definitions-for-emacs (name|) + (match (parse-symbol name) + ((,sym ,modname) + (def env (module-target-environment (runtime-module modname))) + (def b (find-binding sym env)) + (cond (b (find-binding-definitions b)) + (#t 'nil))))) + +(df parse-symbol (name| => ) + (if (mem? name #\:) + (match (split name #\:) + ((,module ,name) (lst (as-sym name) (as-sym module)))) + (lst (as-sym name) (module-name (buffer-module))))) + +(df find-binding-definitions (b|) + (def value (case (binding-kind b) + (('runtime) (loc-val (binding-locative b))) + (('global) (let ((box (binding-global-box b))) + (and box (global-box-value box)))) + (('macro) (binding-info b)) + (#t (error "unknown binding kind %=" (binding-kind b))))) + (map (fun (o) + (def loc (emacs-src-loc o)) + `(,(write-to-string (dspec o)) + ,(or loc `(:error "no src-loc available")))) + (defining-objects value))) + +(dm defining-objects (o => ) '()) +(dm defining-objects (o| => ) (lst o)) +(dm defining-objects (o| => ) (pair o (fun-mets o))) + +(dm emacs-src-loc (o|) + (def loc (fun-src-loc o)) + (and loc `(:location (:file ,(simplify-filename + (find-goo-file-in-path + (module-name-to-relpath (src-loc-file loc)) + *module-search-path*))) + (:line ,(src-loc-line loc)) + ()))) + +(dm dspec (f|) + (cond ((fun-name f) + `(,(if (isa? f ) 'dg 'dm) ,(fun-name f) ,@(dspec-arglist f))) + (#t f))) + +(df dspec-arglist (f|) + (map2 (fun (name class) + (cond ((= class ) name) + ((isa? class ) + `(,name ,(class-name class))) + (#t `(,name ,class)))) + (fun-info-names (fun-info f)) + (sig-specs (fun-sig f)))) + +(defslimefun buffer-first-change (filename) 'nil) + + +;;;; apropos + +(defslimefun apropos-list-for-emacs + (pattern only-external? case-sensitive? package) + (def matches (fab 100)) + (do-all-bindings + (fun (b) + (when (finds (binding-name-str b) pattern) + (set (elt matches + (cat-sym (binding-name b) + (module-name (binding-module b)))) + b)))) + (set matches (sort-by (packing-as (for ((b matches)) (pack b))) + (fun (x y) + (< (binding-name x) + (binding-name y))))) + (map (fun (b) + `(:designator + ,(cat (sym-name (module-name (binding-module b))) ":" + (binding-name-str b) + "\tkind: " (sym-name (binding-kind b))))) + (as matches))) + +(df do-all-bindings (f|) + (for ((module (%module-loader-modules (runtime-module-loader)))) + (do f (environment-bindings (module-target-environment module))))) + +(dm < (s1| s2| => ) + (let ((l1 (len s1)) (l2 (len s2))) + (rep loop ((i 0)) + (cond ((= i l1) (~= l1 l2)) + ((= i l2) #f) + ((< (elt s1 i) (elt s2 i)) #t) + ((= (elt s1 i) (elt s2 i)) (loop (1+ i))) + (#t #f))))) + +(df %binding-info (name| module|) + (binding-info + (find-binding + name (module-target-environment (runtime-module module))))) + + +;;;; completion + +(defslimefun simple-completions (pattern| package) + (def matches (lst)) + (for ((b (environment-bindings (module-target-environment (buffer-module))))) + (when (prefix? (binding-name-str b) pattern) + (pushf matches b))) + (def strings (map binding-name-str matches)) + `(,strings ,(cond ((nul? strings) pattern) + (#t (fold+ common-prefix strings))))) + +(df common-prefix (s1| s2|) + (let ((limit (min (len s1) (len s2)))) + (rep loop ((i 0)) + (cond ((or (= i limit) + (~= (elt s1 i) (elt s2 i))) + (sub s1 0 i)) + (#t (loop (1+ i))))))) + +(defslimefun list-all-package-names (_|...) + (map sym-name (keys (all-modules)))) + +(df all-modules () (%module-loader-modules (runtime-module-loader))) + + +;;;; Macroexpand + +(defslimefun swank-macroexpand-1 (str|) + (write-to-string + (%ast-macro-expand (read-from-string str) + (module-target-environment (buffer-module)) + #f))) + + +;;;; streams + +(dc ()) +(dp @socket ( => )) +(dp! @buf-len ( => ) 0) +(dp @buf ( => ) (new )) +(dp! @timestamp ( => ) 0) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s buf-len: %s}" (class-name-str x) (@buf-len x))) + +(dm put (p| c|) + (add! (@buf p) c) + (incf (@buf-len p)) + (maybe-flush p (= c #\newline))) + +(dm puts (p| s|) + (add! (@buf p) s) + (incf (@buf-len p) (len s)) + (maybe-flush p (mem? s #\newline))) + +(df maybe-flush (p| newline?|) + (and (or (> (@buf-len p) 4000) newline?) + (> (- (current-time) (@timestamp p)) 100000) + (force-out p))) + +(dm force-out (p|) + (unless (zero? (@buf-len p)) + (dispatch-event `(:write-string ,(%buf-to-str (@buf p))) (@socket p)) + (set (@buf-len p) 0) + (zap! (@buf p))) + (set (@timestamp p) (current-time))) + +(df %buf-to-str (buf|) + (packing-as + (for ((i buf)) + (cond ((isa? i ) (for ((c i)) (pack c))) + (#t (pack i)))))) + +(dc ()) +(dp @socket ( => )) +(dp! @idx ( => ) 0) +(dp! @buf ( => ) "") + +(df receive-input (p|) + (dispatch-event `(:read-string ,0) (@socket p))) + +(dm get (p| => ) + (cond ((< (@idx p) (len (@buf p))) + (def c (elt (@buf p) (@idx p))) + (incf (@idx p)) + c) + (#t + (def input (receive-input p)) + (cond ((zero? (len input)) (eof-object)) + (#t (set (@buf p) input) + (set (@idx p) 0) + (get p)))))) + +(dm ready? (p| => ) (< (@idx p) (len (@buf p)))) + +(dm peek (p| => ) + (let ((c (get p))) + (unless (eof-object? c) + (decf (@idx p))) + c)) + + +;;;; Message encoding + +(df decode-message (port|) + (read-from-string (get-block port (read-message-length port)))) + +(df read-message-length (port) + (or (str-to-num (cat "#x" (get-block port 6))) + (error "can't parse message length"))) + +(df encode-message (message port) + (let ((string (dlet ((*max-print-length* 1000000) + (*max-print-depth* 1000000)) + (write-to-string message)))) + (puts port (encode-message-length (len string))) + (puts port string) + (force-out port))) + +(df encode-message-length (n) + (loc ((hex (byte) + (if (< byte #x10) + (cat "0" (num-to-str-base byte 16)) + (num-to-str-base byte 16))) + (byte (i) (hex (& (>> n (* i 8)) 255)))) + (cat (byte 2) (byte 1) (byte 0)))) + + +;;;; semi general utilities + +;; Return the name of O's class as string. +(df class-name-str (o => ) (sym-name (class-name (class-of o)))) + +(df binding-name-str (b| => ) (sym-name (binding-name b))) + +(df as-sym (str|) (as str)) + +;; Replace '//' in the middle of a filename with with a '/' +(df simplify-filename (str| => ) + (match (pathname-to-components str) + ((,hd ,@tl) + (components-to-pathname (cons hd (del-vals tl 'root)))))) + +;; Execute BODY and only if BODY exits abnormally execute RECOVER. +(df try-recover (body recover) + (let ((ok #f)) + (fin (let ((val (body))) + (set ok #t) + val) + (unless ok + (recover))))) + +;; like CL's IGNORE-ERRORS but return VALUE in case of an error. +(df try-or (body| value) + (esc ret + (try (fun (condition resume) (ret value)) + (body)))) + +(df simple-restart (type msg body) + (esc restart + (try ((type type) (description msg)) + (fun (c r) (restart #f)) + (body)))) + +(df safe-write-to-string (o) + (esc ret + (try (fun (c r) + (ret (cat "#"))) + (write-to-string o)))) + +;; Read a string of length COUNT. +(df get-block (port| count| => ) + (packing-as + (for ((i (below count))) + (let ((c (get port))) + (cond ((eof-object? c) + (error "Premature EOF (read %d of %d)" i count)) + (#t (pack c))))))) + + +;;;; import some internal bindings + +(df %lookup (name| module|) + (loc-val + (binding-locative + (find-binding + name (module-target-environment (runtime-module module)))))) + +(d. %handler-info (%lookup 'handler-info 'goo/conditions)) +(d. %handler-condition-type (%lookup 'handler-condition-type 'goo/conditions)) +(d. %do-handlers-of-type (%lookup 'do-handlers-of-type 'goo/conditions)) +(d. %module-loader-modules (%lookup 'module-loader-modules 'eval/module)) +(d. %ast-macro-expand (%lookup 'ast-macro-expand 'eval/ast)) + + +;;;; low level socket stuff +;;; this shouldn't be here + +#{ +#include +#include +#include +#include +#include +#include +#include + +/* convert a goo number to a C long */ +static long g2i (P o) { return untag (o); } + +static int +set_reuse_address (int socket, int value) { + return setsockopt (socket, SOL_SOCKET, SO_REUSEADDR, &value, sizeof value); +} + +static int +bind_socket (int socket, int port) { + struct sockaddr_in addr; + addr.sin_family = AF_INET; + addr.sin_port = htons (port); + addr.sin_addr.s_addr = htonl (INADDR_ANY); + return bind (socket, (struct sockaddr *)&addr, sizeof addr); +} + +static int +local_port (int socket) { + struct sockaddr_in addr; + socklen_t len = sizeof addr; + int code = getsockname (socket, (struct sockaddr *)&addr, &len); + return (code == -1) ? -1 : ntohs (addr.sin_port); +} + +static int +c_accept (int socket) { + struct sockaddr_in addr; + socklen_t len = sizeof addr; + return accept (socket, (struct sockaddr *)&addr, &len); +} + +static P tup3 (P e0, P e1, P e2) { + P tup = YPPtfab ((P)3, YPfalse); + YPtelt_setter (e0, tup, (P)0); + YPtelt_setter (e1, tup, (P)1); + YPtelt_setter (e2, tup, (P)2); + return tup; +} + +static P +current_time (void) { + struct timeval timeval; + int code = gettimeofday (&timeval, NULL); + if (code == 0) { + return tup3 (YPib ((P)(timeval.tv_sec >> 24)), + YPib ((P)(timeval.tv_sec & 0xffffff)), + YPib ((P)(timeval.tv_usec))); + } else return YPib ((P)errno); +} +} + +;; Return the current time in microsecs +(df current-time (=> ) + (def t #eg{ current_time () }) + (cond ((isa? t ) (error "%s" (strerror t))) + (#t (+ (* (+ (<< (1st t) 24) + (2nd t)) + 1000000) + (3rd t))))) + +(dm strerror (e| => ) #es{ strerror (g2i ($e)) }) +(dm strerror (e|(t= #f) => ) #es{ strerror (errno) }) + +(df checkr (value|) + (cond ((~== value -1) value) + (#t (error "%s" (strerror #f))))) + +(df create-socket (port| => ) + (let ((socket (checkr #ei{ socket (PF_INET, SOCK_STREAM, 0) }))) + (checkr #ei{ set_reuse_address (g2i ($socket), 1) }) + (checkr #ei{ bind_socket (g2i ($socket), g2i ($port)) }) + (checkr #ei{ listen (g2i ($socket), 1)}) + socket)) + +(df %local-port (fd|) (checkr #ei{ local_port (g2i ($fd)) })) +(df %close (fd|) (checkr #ei{ close (g2i ($fd)) })) + +(dc ( )) +(dp @fd ( => )) +(dp @in ( => )) +(dp @out ( => )) + +(dm recurring-write (port| x| d| recur|) + (msg port "#{%s fd: %s}" (class-name-str x) (@fd x))) + +(dm get (port| => ) (get (@in port))) + +(dm puts (port| s|) (puts (@out port) s)) +(dm force-out (port|) (force-out (@out port))) + +(dm fdopen (fd| type|(t= ) => ) + (new @fd fd + @in (new port-handle (%fdopen fd "r")) + @out (new port-handle (%fdopen fd "w")))) + +(df %fdopen (fd| mode| => ) + (def addr #ei{ fdopen (g2i ($fd), @mode) }) + (when (zero? addr) + (error "fdopen failed: %s" (strerror #f))) + (%lb (%iu addr))) + +(df accept (socket| => ) + (fdopen (checkr #ei{ c_accept (g2i ($socket)) }) )) + +(export + start-swank + create-server) + +;;; swank-goo.goo ends here \ No newline at end of file diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-hyperdoc.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-hyperdoc.lisp new file mode 100644 index 0000000..1e34a1d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-hyperdoc.lisp @@ -0,0 +1,18 @@ +(in-package :swank) + +(defslimefun hyperdoc (string) + (let ((hyperdoc-package (find-package :hyperdoc))) + (when hyperdoc-package + (multiple-value-bind (symbol foundp symbol-name package) + (parse-symbol string *buffer-package*) + (declare (ignore symbol)) + (when foundp + (funcall (find-symbol (string :lookup) hyperdoc-package) + (package-name (if (member package (cons *buffer-package* + (package-use-list + *buffer-package*))) + *buffer-package* + package)) + symbol-name)))))) + +(provide :swank-hyperdoc) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-ikarus.ss b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-ikarus.ss new file mode 100644 index 0000000..e048446 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-ikarus.ss @@ -0,0 +1,86 @@ +;; swank-larceny.scm --- Swank server for Ikarus +;; +;; License: Public Domain +;; Author: Helmut Eller +;; +;; In a shell execute: +;; ikarus swank-ikarus.ss +;; and then `M-x slime-connect' in Emacs. +;; + +(library (swank os) + (export getpid make-server-socket accept local-port close-socket) + (import (rnrs) + (only (ikarus foreign) make-c-callout dlsym dlopen + pointer-set-c-long! pointer-ref-c-unsigned-short + malloc free pointer-size) + (rename (only (ikarus ipc) tcp-server-socket accept-connection + close-tcp-server-socket) + (tcp-server-socket make-server-socket) + (close-tcp-server-socket close-socket)) + (only (ikarus) + struct-type-descriptor + struct-type-field-names + struct-field-accessor) + ) + + (define libc (dlopen)) + (define (cfun name return-type arg-types) + ((make-c-callout return-type arg-types) (dlsym libc name))) + + (define getpid (cfun "getpid" 'signed-int '())) + + (define (accept socket codec) + (let-values (((in out) (accept-connection socket))) + (values (transcoded-port in (make-transcoder codec)) + (transcoded-port out (make-transcoder codec))))) + + (define (socket-fd socket) + (let ((rtd (struct-type-descriptor socket))) + (do ((i 0 (+ i 1)) + (names (struct-type-field-names rtd) (cdr names))) + ((eq? (car names) 'fd) ((struct-field-accessor rtd i) socket))))) + + (define sockaddr_in/size 16) + (define sockaddr_in/sin_family 0) + (define sockaddr_in/sin_port 2) + (define sockaddr_in/sin_addr 4) + + (define (local-port socket) + (let* ((fd (socket-fd socket)) + (addr (malloc sockaddr_in/size)) + (size (malloc (pointer-size)))) + (pointer-set-c-long! size 0 sockaddr_in/size) + (let ((code (getsockname fd addr size)) + (port (ntohs (pointer-ref-c-unsigned-short + addr sockaddr_in/sin_port)))) + (free addr) + (free size) + (cond ((= code -1) (error "getsockname failed")) + (#t port))))) + + (define getsockname + (cfun "getsockname" 'signed-int '(signed-int pointer pointer))) + + (define ntohs (cfun "ntohs" 'unsigned-short '(unsigned-short))) + + ) + + +(library (swank sys) + (export implementation-name eval-in-interaction-environment) + (import (rnrs) + (rnrs eval) + (only (ikarus) interaction-environment)) + + (define (implementation-name) "ikarus") + + (define (eval-in-interaction-environment form) + (eval form (interaction-environment))) + + ) + +(import (only (ikarus) load)) +(load "swank-r6rs.scm") +(import (swank)) +(start-server #f) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-indentation.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-indentation.lisp new file mode 100644 index 0000000..67e638d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-indentation.lisp @@ -0,0 +1,140 @@ +(in-package :swank) + +(defvar *application-hints-tables* '() + "A list of hash tables mapping symbols to indentation hints (lists +of symbols and numbers as per cl-indent.el). Applications can add hash +tables to the list to change the auto indentation slime sends to +emacs.") + +(defun has-application-indentation-hint-p (symbol) + (let ((default (load-time-value (gensym)))) + (dolist (table *application-hints-tables*) + (let ((indentation (gethash symbol table default))) + (unless (eq default indentation) + (return-from has-application-indentation-hint-p + (values indentation t)))))) + (values nil nil)) + +(defun application-indentation-hint (symbol) + (let ((indentation (has-application-indentation-hint-p symbol))) + (labels ((walk (indentation-spec) + (etypecase indentation-spec + (null nil) + (number indentation-spec) + (symbol (string-downcase indentation-spec)) + (cons (cons (walk (car indentation-spec)) + (walk (cdr indentation-spec))))))) + (walk indentation)))) + +;;; override swank version of this function +(defun symbol-indentation (symbol) + "Return a form describing the indentation of SYMBOL. + +The form is to be used as the `common-lisp-indent-function' property +in Emacs." + (cond + ((has-application-indentation-hint-p symbol) + (application-indentation-hint symbol)) + ((and (macro-function symbol) + (not (known-to-emacs-p symbol))) + (let ((arglist (arglist symbol))) + (etypecase arglist + ((member :not-available) + nil) + (list + (macro-indentation arglist))))) + (t nil))) + +;;; More complex version. +(defun macro-indentation (arglist) + (labels ((frob (list &optional base) + (if (every (lambda (x) + (member x '(nil "&rest") :test #'equal)) + list) + ;; If there was nothing interesting, don't return anything. + nil + ;; Otherwise substitute leading NIL's with 4 or 1. + (let ((ok t)) + (substitute-if (if base + 4 + 1) + (lambda (x) + (if (and ok (not x)) + t + (setf ok nil))) + list)))) + (walk (list level &optional firstp) + (when (consp list) + (let ((head (car list))) + (if (consp head) + (let ((indent (frob (walk head (+ level 1) t)))) + (cons (list* "&whole" (if (zerop level) + 4 + 1) + indent) (walk (cdr list) level))) + (case head + ;; &BODY is &BODY, this is clear. + (&body + '("&body")) + ;; &KEY is tricksy. If it's at the base level, we want + ;; to indent them normally: + ;; + ;; (foo bar quux + ;; :quux t + ;; :zot nil) + ;; + ;; If it's at a destructuring level, we want indent of 1: + ;; + ;; (with-foo (var arg + ;; :foo t + ;; :quux nil) + ;; ...) + (&key + (if (zerop level) + '("&rest" nil) + '("&rest" 1))) + ;; &REST is tricksy. If it's at the front of + ;; destructuring, we want to indent by 1, otherwise + ;; normally: + ;; + ;; (foo (bar quux + ;; zot) + ;; ...) + ;; + ;; but + ;; + ;; (foo bar quux + ;; zot) + (&rest + (if (and (plusp level) firstp) + '("&rest" 1) + '("&rest" nil))) + ;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there + ;; at all. + ((&whole &environment) + (walk (cddr list) level firstp)) + ;; &OPTIONAL is indented normally -- and the &OPTIONAL marker + ;; itself is not counted. + (&optional + (walk (cdr list) level)) + ;; Indent normally, walk the tail -- but + ;; unknown lambda-list keywords terminate the walk. + (otherwise + (unless (member head lambda-list-keywords) + (cons nil (walk (cdr list) level)))))))))) + (frob (walk arglist 0 t) t))) + +#+nil +(progn + (assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body") + (macro-indentation '(bar quux (&rest slots) &body body)))) + (assert (equal nil + (macro-indentation '(a b c &rest more)))) + (assert (equal '(4 4 4 "&body") + (macro-indentation '(a b c &body more)))) + (assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body") + (macro-indentation '((name zot &key foo bar) &body body)))) + (assert (equal nil + (macro-indentation '(x y &key z))))) + +(provide :swank-indentation) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-jolt.k b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-jolt.k new file mode 100644 index 0000000..93e53ab --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-jolt.k @@ -0,0 +1,998 @@ +;;; swank-jolt.k --- Swank server for Jolt -*- goo -*- +;; +;; Copyright (C) 2008 Helmut Eller +;; +;; This file is licensed under the terms of the GNU General Public +;; License as distributed with Emacs (press C-h C-c for details). + +;;; Commentary: +;; +;; Jolt/Coke is a Lisp-like language wich operates at the semantic level of +;; C, i.e. most objects are machine words and memory pointers. The +;; standard boot files define an interface to Id Smalltalk. So we can +;; also pretend to do OOP, but we must be careful to pass properly +;; tagged pointers to Smalltalk. +;; +;; This file only implements a minimum of SLIME's functionality. We +;; install a handler with atexit(3) to invoke the debugger. This way +;; we can stop Jolt from terminating the process on every error. +;; Unfortunately, the backtrace doesn't contain much information and +;; we also have no error message (other than the exit code). Jolt +;; usually prints some message to stdout before calling exit, so you +;; have to look in the *inferior-lisp* buffer for hints. We do +;; nothing (yet) to recover from SIGSEGV. + +;;; Installation +;; +;; 1. Download and build cola. See . +;; I used the svn version: +;; svn co http://piumarta.com/svn2/idst/trunk idst +;; 2. Add something like this to your .emacs: +;; +;; (add-to-list 'slime-lisp-implementations +;; '(jolt (".../idst/function/jolt-burg/main" +;; "boot.k" ".../swank-jolt.k" "-") ; note the "-" +;; :init jolt-slime-init +;; :init-function slime-redirect-inferior-output) +;; (defun jolt-slime-init (file _) (format "%S\n" `(start-swank ,file))) +;; (defun jolt () (interactive) (slime 'jolt)) +;; +;; 3. Use `M-x jolt' to start it. +;; + +;;; Code + +;; In this file I use 2-3 letters for often used names, like DF or +;; VEC, even if those names are abbreviations. I think that after a +;; little getting used to, this style is just as readable as the more +;; traditional DEFUN and VECTOR. Shorter names make it easier to +;; write terse code, in particular 1-line definitions. + +;; `df' is like `defun' in a traditional lisp +(syntax df + (lambda (form compiler) + (printf "df %s ...\n" [[[form second] asString] _stringValue]) + `(define ,[form second] (lambda ,@[form copyFrom: '2])))) + +;; (! args ...) is the same as [args ...] but easier to edit. +(syntax ! + (lambda (form compiler) + (cond ((== [form size] '3) + (if [[form third] isSymbol] + `(send ',[form third] ,[form second]) + [compiler errorSyntax: [form third]])) + ((and [[form size] > '3] + (== [[form size] \\ '2] '0)) + (let ((args [OrderedCollection new]) + (keys [OrderedCollection new]) + (i '2) (len [form size])) + (while (< i len) + (let ((key [form at: i])) + (if (or [key isKeyword] + (and (== i '2) [key isSymbol])) ; for [X + Y] + [keys addLast: [key asString]] + [compiler errorSyntax: key])) + [args addLast: [form at: [i + '1]]] + (set i [i + '2])) + `(send ',[[keys concatenated] asSymbol] ,[form second] ,@args))) + (1 [compiler errorArgumentCount: form])))) + +(define Integer (import "Integer")) +(define Symbol (import "Symbol")) ;; aka. _selector +(define StaticBlockClosure (import "StaticBlockClosure")) +(define BlockClosure (import "BlockClosure")) +(define SequenceableCollection (import "SequenceableCollection")) +(define _vtable (import "_vtable")) +(define ByteArray (import "ByteArray")) +(define CodeGenerator (import "CodeGenerator")) +(define TheGlobalEnvironment (import "TheGlobalEnvironment")) + +(df error (msg) (! Object error: msg)) +(df print-to-string (obj) + (let ((len '200) + (stream (! WriteStream on: (! String new: len)))) + (! stream print: obj) + (! stream contents))) +(df assertion-failed (exp) + (error (! '"Assertion failed: " , (print-to-string exp)))) + +(syntax assert + (lambda (form) + `(if (not ,(! form second)) + (assertion-failed ',(! form second))))) + +(df isa? (obj type) (! obj isKindOf: type)) +(df equal (o1 o2) (! o1 = o2)) + +(define nil 0) +(define false 0) +(define true (! Object notNil)) +(df bool? (obj) (or (== obj false) (== obj true))) +(df int? (obj) (isa? obj Integer)) + +;; In this file the convention X>Y is used for operations that convert +;; X-to-Y. And _ means "machine word". So _>int is the operator that +;; converts a machine word to an Integer. + +(df _>int (word) (! Integer value_: word)) +(df int>_ (i) (! i _integerValue)) + +;; Fixnum operators. Manual tagging/untagging would probably be more +;; efficent than invoking methods. + +(df fix? (obj) (& obj 1)) +(df _>fix (n) (! SmallInteger value_: n)) +(df fix>_ (i) (! i _integerValue)) +(df fx+ (fx1 fx2) (! fx1 + fx2)) +(df fx* (fx1 fx2) (! fx1 * fx2)) +(df fx1+ (fx) (! fx + '1)) +(df fx1- (fx) (! fx - '1)) + +(df str? (obj) (isa? obj String)) +(df >str (o) (! o asString)) +(df str>_ (s) (! s _stringValue)) +(df _>str (s) (! String value_: s)) +(df sym? (obj) (isa? obj Symbol)) +(df seq? (obj) (isa? obj SequenceableCollection)) +(df array? (obj) (isa? obj Array)) +(df len (obj) (! obj size)) +(df len_ (obj) (! (! obj size) _integerValue)) +(df ref (obj idx) (! obj at: idx)) +(df set-ref (obj idx elt) (! obj at: idx put: elt)) +(df first (obj) (! obj first)) +(df second (obj) (! obj second)) + +(df puts (string stream) (! stream nextPutAll: string)) + +(define _GC_base (dlsym "GC_base")) + +;; Is ADDR a pointer to a heap allocated object? The Boehm GC nows +;; such things. This is useful for debugging, because we can quite +;; safely (i.e. without provoking SIGSEGV) access such addresses. +(df valid-pointer? (addr) + (let ((ptr (& addr (~ 1)))) + (and (_GC_base ptr) + (_GC_base (long@ ptr -1))))) + +;; Print OBJ as a Lisp printer would do. +(df prin1 (obj stream) + (cond ((fix? obj) (! stream print: obj)) + ((== obj nil) (puts '"nil" stream)) + ((== obj false) (puts '"#f" stream)) + ((== obj true) (puts '"#t" stream)) + ((not (valid-pointer? obj)) + (begin (puts '"#int obj) stream) + (puts '">" stream))) + ((int? obj) (! stream print: obj)) + ((sym? obj) (puts (>str obj) stream)) + ((isa? obj StaticBlockClosure) + (begin (puts '"#" stream))) + ((and (str? obj) (len obj)) + (! obj printEscapedOn: stream delimited: (ref '"\"" '0))) + ((and (array? obj) (len obj)) + (begin (puts '"(" stream) + (let ((max (- (len_ obj) 1))) + (for (i 0 1 max) + (prin1 (ref obj (_>fix i)) stream) + (if (!= i max) + (puts '" " stream)))) + (puts '")" stream))) + ((and (isa? obj OrderedCollection) (len obj)) + (begin (puts '"#[" stream) + (let ((max (- (len_ obj) 1))) + (for (i 0 1 max) + (prin1 (ref obj (_>fix i)) stream) + (if (!= i max) + (puts '" " stream)))) + (puts '"]" stream))) + (true + (begin (puts '"#<" stream) + (puts (! obj debugName) stream) + (puts '">" stream)))) + obj) + +(df print (obj) + (prin1 obj StdOut) + (puts '"\n" StdOut)) + +(df prin1-to-string (obj) + (let ((len '100) + (stream (! WriteStream on: (! String new: len)))) + (prin1 obj stream) + (! stream contents))) + +;;(df %vable-tally (_vtable) (long@ _vtable)) +(df cr () (printf "\n")) +(df print-object-selectors (obj) + (let ((vtable (! obj _vtable)) + (tally (long@ vtable 0)) + (bindings (long@ vtable 1))) + (for (i 1 1 tally) + (print (long@ (long@ bindings i))) + (cr)))) + +(df print-object-slots (obj) + (let ((size (! obj _sizeof)) + (end (+ obj size))) + (while (< obj end) + (print (long@ obj)) + (cr) + (incr obj 4)))) + +(df intern (string) (! Symbol intern: string)) + +;; Jolt doesn't seem to have an equivalent for gensym, but it's damn +;; hard to write macros without it. So here we adopt the conventions +;; that symbols which look like ".[0-9]+" are reserved for gensym and +;; shouldn't be used for "user visible variables". +(define gensym-counter 0) +(df gensym () + (set gensym-counter (+ gensym-counter 1)) + (intern (! '"." , (>str (_>fix gensym-counter))))) + +;; Surprisingly, SequenceableCollection doesn't have a indexOf method. +;; So we even need to implement such mundane things. +(df index-of (seq elt) + (let ((max (len seq)) + (i '0)) + (while (! i < max) + (if (equal (ref seq i) elt) + (return i) + (set i (! i + '1)))) + nil)) + +(df find-dot (array) (index-of array '.)) + +;; What followes is the implementation of the pattern matching macro MIF. +;; The syntax is (mif (PATTERN EXP) THEN ELSE). +;; The THEN-branch is executed if PATTERN matches the value produced by EXP. +;; ELSE gets only executed if the match failes. +;; A pattern can be +;; 1) a symbol, which matches all values, but also binds the variable to the +;; value +;; 2) (quote LITERAL), matches if the value is `equal' to LITERAL. +;; 3) (PS ...) matches sequences, if the elements match PS. +;; 4) (P1 ... Pn . Ptail) matches if P1 ... Pn match the respective elements +;; at indices 1..n and if Ptail matches the rest +;; of the sequence +;; Examples: +;; (mif (x 10) x 'else) => 10 +;; (mif ('a 'a) 'then 'else) => then +;; (mif ('a 'b) 'then 'else) => else +;; (mif ((a b) '(1 2)) b 'else) => 2 +;; (mif ((a . b) '(1 2)) b 'else) => '(2) +;; (mif ((. x) '(1 2)) x 'else) => '(1 2) + +(define mif% 0) ;; defer +(df mif%array (compiler pattern i value then fail) + ;;(print `(mif%array ,pattern ,i ,value)) + (cond ((== i (len_ pattern)) then) + ((== (ref pattern (_>fix i)) '.) + (begin + (if (!= (- (len_ pattern) 2) i) + (begin + (print pattern) + (! compiler error: (! '"dot in strange position: " + , (>str (_>fix i)))))) + (mif% compiler + (ref pattern (_>fix (+ i 1))) + `(! ,value copyFrom: ',(_>fix i)) + then fail))) + (true + (mif% compiler + (ref pattern (_>fix i)) + `(ref ,value ',(_>fix i)) + (mif%array compiler pattern (+ i 1) value then fail) + fail)))) + +(df mif% (compiler pattern value then fail) + ;;(print `(mif% ,pattern ,value ,then)) + (cond ((== pattern '_) then) + ((== pattern '.) (! compiler errorSyntax: pattern)) + ((sym? pattern) + `(let ((,pattern ,value)) ,then)) + ((seq? pattern) + (cond ((== (len_ pattern) 0) + `(if (== (len_ ,value) 0) ,then (goto ,fail))) + ((== (first pattern) 'quote) + (begin + (if (not (== (len_ pattern) 2)) + (! compiler errorSyntax: pattern)) + `(if (equal ,value ,pattern) ,then (goto ,fail)))) + (true + (let ((tmp (gensym)) (tmp2 (gensym)) + (pos (find-dot pattern))) + `(let ((,tmp2 ,value) + (,tmp ,tmp2)) + (if (and (seq? ,tmp) + ,(if (find-dot pattern) + `(>= (len ,tmp) + ',(_>fix (- (len_ pattern) 2))) + `(== (len ,tmp) ',(len pattern)))) + ,(mif%array compiler pattern 0 tmp then fail) + (goto ,fail))))))) + (true (! compiler errorSyntax: pattern)))) + +(syntax mif + (lambda (node compiler) + ;;(print `(mif ,node)) + (if (not (or (== (len_ node) 4) + (== (len_ node) 3))) + (! compiler errorArgumentCount: node)) + (if (not (and (array? (ref node '1)) + (== (len_ (ref node '1)) 2))) + (! compiler errorSyntax: (ref node '1))) + (let ((pattern (first (ref node '1))) + (value (second (ref node '1))) + (then (ref node '2)) + (else (if (== (len_ node) 4) + (ref node '3) + `(error "mif failed"))) + (destination (gensym)) + (fail (! compiler newLabel)) + (success (! compiler newLabel))) + `(let ((,destination 0)) + ,(mif% compiler pattern value + `(begin (set ,destination ,then) + (goto ,success)) + fail) + (label ,fail) + (set ,destination ,else) + (label ,success) + ,destination)))) + +;; (define *catch-stack* nil) +;; +(df bar (o) (mif ('a o) 'yes 'no)) +(assert (== (bar 'a) 'yes)) +(assert (== (bar 'b) 'no)) +(df foo (o) (mif (('a) o) 'yes 'no)) +(assert (== (foo '(a)) 'yes)) +(assert (== (foo '(b)) 'no)) +(df baz (o) (mif (('a 'b) o) 'yes 'no)) +(assert (== (baz '(a b)) 'yes)) +(assert (== (baz '(a c)) 'no)) +(assert (== (baz '(b c)) 'no)) +(assert (== (baz 'a) 'no)) +(df mifvar (o) (mif (y o) y 'no)) +(assert (== (mifvar 'foo) 'foo)) +(df mifvec (o) (mif ((y) o) y 'no)) +(assert (== (mifvec '(a)) 'a)) +(assert (== (mifvec 'x) 'no)) +(df mifvec2 (o) (mif (('a y) o) y 'no)) +(assert (== (mifvec2 '(a b)) 'b)) +(assert (== (mifvec2 '(b c)) 'no)) +(assert (== (mif ((x) '(a)) x 'no) 'a)) +(assert (== (mif ((x . y) '(a b)) x 'no) 'a)) +(assert (== (mif ((x y . z) '(a b)) y 'no) 'b)) +(assert (equal (mif ((x . y) '(a b)) y 'no) '(b))) +(assert (equal (mif ((. x) '(a b)) x 'no) '(a b))) +(assert (equal (mif (((. x)) '((a b))) x 'no) '(a b))) +(assert (equal (mif (((. x) . y) '((a b) c)) y 'no) '(c))) +(assert (== (mif (() '()) 'yes 'no) 'yes)) +(assert (== (mif (() '(a)) 'yes 'no) 'no)) + +;; Now that we have a somewhat convenient pattern matcher we can write +;; a more convenient macro defining macro: +(syntax defmacro + (lambda (node compiler) + (mif (('defmacro name (. args) . body) node) + (begin + (printf "defmacro %s ...\n" (str>_ (>str name))) + `(syntax ,name + (lambda (node compiler) + (mif ((',name ,@args) node) + (begin ,@body) + (! compiler errorSyntax: node))))) + (! compiler errorSyntax: node)))) + +;; and an even more convenient pattern matcher: +(defmacro mcase (value . clauses) + (let ((tmp (gensym))) + `(let ((,tmp ,value)) + ,(mif (() clauses) + `(begin (print ,tmp) + (error "mcase failed")) + (mif (((pattern . body) . more) clauses) + `(mif (,pattern ,tmp) + (begin ,@(mif (() body) '(0) body)) + (mcase ,tmp ,@more)) + (! compiler errorSyntax: clauses)))))) + +;; and some traditional macros +(defmacro when (test . body) `(if ,test (begin ,@body))) +(defmacro unless (test . body) `(if ,test 0 (begin ,@body))) +(defmacro or (. args) ; the built in OR returns 1 on success. + (mcase args + (() 0) + ((e) e) + ((e1 . more) + (let ((tmp (gensym))) + `(let ((,tmp ,e1)) + (if ,tmp ,tmp (or ,@more))))))) + +(defmacro dotimes_ ((var n) . body) + (let ((tmp (gensym))) + `(let ((,tmp ,n) + (,var 0)) + (while (< ,var ,tmp) + ,@body + (set ,var (+ ,var 1)))))) + +(defmacro dotimes ((var n) . body) + (let ((tmp (gensym))) + `(let ((,tmp ,n) + (,var '0)) + (while (< ,var ,tmp) + ,@body + (set ,var (fx1+ ,var)))))) + +;; DOVEC is like the traditional DOLIST but works on "vectors" +;; i.e. sequences which can be indexed efficently. +(defmacro dovec ((var seq) . body) + (let ((i (gensym)) + (max (gensym)) + (tmp (gensym))) + `(let ((,i 0) + (,tmp ,seq) + (,max (len_ ,tmp))) + (while (< ,i ,max) + (let ((,var (! ,tmp at: (_>fix ,i)))) + ,@body + (set ,i (+ ,i 1))))))) + +;; "Packing" is what Lispers usually call "collecting". +;; The Lisp idiom (let ((result '())) .. (push x result) .. (nreverse result)) +;; translates to (packing (result) .. (pack x result)) +(defmacro packing ((var) . body) + `(let ((,var (! OrderedCollection new))) + ,@body + (! ,var asArray))) + +(df pack (elt packer) (! packer addLast: elt)) + +(assert (equal (packing (p) (dotimes_ (i 2) (pack (_>fix i) p))) + '(0 1))) + +(assert (equal (packing (p) (dovec (e '(2 3)) (pack e p))) + '(2 3))) + +(assert (equal (packing (p) + (let ((a '(2 3))) + (dotimes (i (len a)) + (pack (ref a i) p)))) + '(2 3))) + +;; MAPCAR (more or less) +(df map (fun col) + (packing (r) + (dovec (e col) + (pack (fun e) r)))) + +;; VEC allocates and initializes a new array. +;; The macro translates (vec x y z) to `(,x ,y ,z). +(defmacro vec (. args) + `(quasiquote + (,@(map (lambda (arg) `(,'unquote ,arg)) + args)))) + +(assert (equal (vec '0 '1) '(0 1))) +(assert (equal (vec) '())) +(assert (== (len (vec 0 1 2 3 4)) '5)) + +;; Concatenate. +(defmacro cat (. args) `(! (vec '"" ,@args) concatenated)) + +(assert (equal (cat '"a" '"b" '"c") '"abc")) + +;; Take a vector of bytes and copy the bytes to a continuous +;; block of memory +(df assemble_ (col) (! (! ByteArray withAll: col) _bytes)) + +;; Jolt doesn't seem to have catch/throw or something equivalent. +;; Here I use a pair of assembly routines as substitue. +;; (catch% FUN) calls FUN with the current stack pointer. +;; (throw% VALUE K) unwinds the stack to K and then returns VALUE. +;; catch% is a bit like call/cc. +;; +;; [Would setjmp/longjmp work from Jolt? or does setjmp require +;; C-compiler magic?] +;; [I figure Smalltalk has a way to do non-local-exits but, I don't know +;; how to use that in Jolt.] +;; +(define catch% + (assemble_ + '(0x55 ; push %ebp + 0x89 0xe5 ; mov %esp,%ebp + 0x54 ; push %esp + 0x8b 0x45 0x08 ; mov 0x8(%ebp),%eax + 0xff 0xd0 ; call *%eax + 0xc9 ; leave + 0xc3 ; ret + ))) + +(define throw% + (assemble_ + `(,@'() + 0x8b 0x44 0x24 0x04 ; mov 0x4(%esp),%eax + 0x8b 0x6c 0x24 0x08 ; mov 0x8(%esp),%ebp + 0xc9 ; leave + 0xc3 ; ret + ))) + +(df bar (i k) + (if (== i 0) + (throw% 100 k) + (begin + (printf "bar %d\n" i) + (bar (- i 1) k)))) +(df foo (k) + (printf "foo.1\n") + (printf "foo.2 %d\n" (bar 10 k))) + +;; Our way to produce closures: we compile a new little function which +;; hardcodes the addresses of the code resp. the data-vector. The +;; nice thing is that such closures can be used called C function +;; pointers. It's probably slow to invoke the compiler for such +;; things, so use with care. +(df make-closure (addr state) + (int>_ + (! `(lambda (a b c d) + (,(_>int addr) ,(_>int state) a b c d)) + eval))) + +;; Return a closure which calls FUN with ARGS and the arguments +;; that the closure was called with. +;; Example: ((curry printf "%d\n") 10) +(defmacro curry (fun . args) + `(make-closure + (lambda (state a b c d) + ((ref state '0) + ,@(packing (sv) + (dotimes (i (len args)) + (pack `(ref state ',(fx1+ i)) sv))) + a b c d)) + (vec ,fun ,@args))) + +(df parse-closure-arglist (vars) + (let ((pos (or (index-of vars '|) + (return nil))) + (cvars (! vars copyFrom: '0 to: (fx1- pos))) + (lvars (! vars copyFrom: (fx1+ pos)))) + (vec cvars lvars))) + +;; Create a closure, to-be-closed-over variables must enumerated +;; explicitly. +;; Example: ((let ((x 1)) (closure (x | y) (+ x y))) 3) => 4. +;; The variables before the "|" are captured by the closure. +(defmacro closure ((. vars) . body) + (mif ((cvars lvars) (parse-closure-arglist vars)) + `(curry (lambda (,@cvars ,@lvars) ,@body) + ,@cvars) + (! compiler errorSyntax: vars))) + +;; The analog for Smalltalkish "blocks". +(defmacro block ((. vars) . body) + (mif ((cvars lvars) (parse-closure-arglist vars)) + `(! StaticBlockClosure + function_: (curry (lambda (,@cvars _closure _self ,@lvars) ,@body) + ,@cvars) + arity_: ,(len lvars)) + (! compiler errorSyntax: vars))) + +(define %mkstemp (dlsym "mkstemp")) +(df make-temp-file () + (let ((name (! '"/tmp/jolt-tmp.XXXXXX" copy)) + (fd (%mkstemp (! name _stringValue)))) + (if (== fd -1) + (error "mkstemp failed")) + `(,fd ,name))) +(define %unlink (dlsym "unlink")) +(df unlink (filename) (%unlink (! filename _stringValue))) + +(define write (dlsym "write")) +(df write-bytes (addr count fd) + (let ((written (write fd addr count))) + (if (!= written count) + (begin + (printf "write failed %p %d %d => %d" addr count fd written) + (error '"write failed"))))) + +(define system (dlsym "system")) +(define main (dlsym "main")) + +;; Starting at address ADDR, disassemble COUNT bytes. +;; This is implemented by writing the memory region to a file +;; and call ndisasm on it. +(df disas (addr count) + (let ((fd+name (make-temp-file))) + (write-bytes addr count (first fd+name)) + (let ((cmd (str>_ (cat '"ndisasm -u -o " + (>str (_>fix addr)) + '" " (second fd+name))))) + (printf "Running: %s\n" cmd) + (system cmd)) + (unlink (second fd+name)))) + +(df rep () + (let ((result (! (! CokeScanner read: StdIn) eval))) + (puts '"=> " StdOut) + (print result) + (puts '"\n" StdOut))) + +;; Perhaps we could use setcontext/getcontext to return from signal +;; handlers (or not). +(define +ucontext-size+ 350) +(define _getcontext (dlsym "getcontext")) +(define _setcontext (dlsym "setcontext")) +(df getcontext () + (let ((context (malloc 350))) + (_getcontext context) + context)) + +(define on_exit (dlsym "on_exit")) ; "atexit" doesn't work. why? + +(define *top-level-restart* 0) +(define *top-level-context* 0) +(define *debugger-hook* 0) + +;; Jolt's error handling strategy is charmingly simple: call exit. +;; We invoke the SLIME debugger from an exit handler. +;; (The handler is registered with atexit, that's a libc function.) + +(df exit-handler (reason arg) + (printf "exit-handler 0x%x\n" reason) + ;;(backtrace) + (on_exit exit-handler nil) + (when *debugger-hook* + (*debugger-hook* `(exit ,reason))) + (cond (*top-level-context* + (_setcontext *top-level-context*)) + (*top-level-restart* + (throw% reason *top-level-restart*)))) + +(df repl () + (set *top-level-context* (getcontext)) + (while (not (! (! StdIn readStream) atEnd)) + (printf "top-level\n") + (catch% + (lambda (k) + (set *top-level-restart* k) + (printf "repl\n") + (while 1 + (rep))))) + (printf "EOF\n")) + +;; (repl) + + +;;; Socket code. (How boring. Duh, should have used netcat instead.) + +(define strerror (dlsym "strerror")) + +(df check-os-code (value) + (if (== value -1) + (error (_>str (strerror (fix>_ (! OS errno))))) + value)) + +;; For now just hard-code constants which usually reside in header +;; files (just like a Forth guy would do). +(define PF_INET 2) +(define SOCK_STREAM 1) +(define SOL_SOCKET 1) +(define SO_REUSEADDR 2) +(define socket (dlsym "socket")) +(define setsockopt (dlsym "setsockopt")) + +(df set-reuse-address (sock value) + (let ((word-size 4) + (val (! Object _balloc: (_>fix word-size)))) + (set-int@ val value) + (check-os-code + (setsockopt sock SOL_SOCKET SO_REUSEADDR val word-size)))) + +(define sockaddr_in/size 16) +(define sockaddr_in/sin_family 0) +(define sockaddr_in/sin_port 2) +(define sockaddr_in/sin_addr 4) +(define INADDR_ANY 0) +(define AF_INET 2) +(define htons (dlsym "htons")) +(define bind (dlsym "bind")) + +(df bind-socket (sock port) + (let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))) + (set-short@ (+ addr sockaddr_in/sin_family) AF_INET) + (set-short@ (+ addr sockaddr_in/sin_port) (htons port)) + (set-int@ (+ addr sockaddr_in/sin_addr) INADDR_ANY) + (check-os-code + (bind sock addr sockaddr_in/size)))) + +(define listen (dlsym "listen")) + +(df create-socket (port) + (let ((sock (check-os-code (socket PF_INET SOCK_STREAM 0)))) + (set-reuse-address sock 1) + (bind-socket sock port) + (check-os-code (listen sock 1)) + sock)) + +(define accept% (dlsym "accept")) +(df accept (sock) + (let ((addr (! OS _balloc: (_>fix sockaddr_in/size))) + (len (! OS _balloc: 4))) + (set-int@ len sockaddr_in/size) + (check-os-code (accept% sock addr len)))) + +(define getsockname (dlsym "getsockname")) +(define ntohs (dlsym "ntohs")) +(df local-port (sock) + (let ((addr (! OS _balloc: (_>fix sockaddr_in/size))) + (len (! OS _balloc: 4))) + (set-int@ len sockaddr_in/size) + (check-os-code + (getsockname sock addr len)) + (ntohs (short@ (+ addr sockaddr_in/sin_port))))) + +(define close (dlsym "close")) +(define _read (dlsym "read")) + +;; Now, after 2/3 of the file we can begin with the actual Swank +;; server. + +(df read-string (fd count) + (let ((buffer (! String new: count)) + (buffer_ (str>_ buffer)) + (count_ (int>_ count)) + (start 0)) + (while (> (- count_ start) 0) + (let ((rcount (check-os-code (_read fd + (+ buffer_ start) + (- count_ start))))) + (set start (+ start rcount)))) + buffer)) + +;; Read and parse a message from the wire. +(df read-packet (fd) + (let ((header (read-string fd '6)) + (length (! Integer fromString: header base: '16)) + (payload (read-string fd length))) + (! CokeScanner read: payload))) + +;; Print a messag to the wire. +(df send-to-emacs (event fd) + (let ((stream (! WriteStream on: (! String new: '100)))) + (! stream position: '6) + (prin1 event stream) + (let ((len (! stream position))) + (! stream position: '0) + (! (fx+ len '-6) printOn: stream base: '16 width: '6) + (write-bytes (str>_ (! stream collection)) (int>_ len) fd)))) + +(df add-quotes (form) + (mcase form + ((fun . args) + `(,fun ,@(packing (s) + (dovec (e args) + (pack `(quote ,e) s))))))) + +(define sldb 0) ;defer + +(df eval-for-emacs (form id fd abort) + (let ((old-hook *debugger-hook*)) + (mcase (catch% + (closure (form fd | k) + (set *debugger-hook* (curry sldb fd k)) + `(ok ,(int>_ (! (add-quotes form) eval))))) + (('ok value) + (set *debugger-hook* old-hook) + (send-to-emacs `(:return (:ok ,value) ,id) fd) + 'ok) + (arg + (set *debugger-hook* old-hook) + (send-to-emacs `(:return (:abort) ,id) fd) + (throw% arg abort))))) + +(df process-events (fd) + (on_exit exit-handler nil) + (let ((done nil)) + (while (not done) + (mcase (read-packet fd) + ((':emacs-rex form package thread id) + (mcase (catch% (closure (form id fd | abort) + (eval-for-emacs form id fd abort))) + ('ok) + ;;('abort nil) + ('top-level) + (other + ;;(return other) ; compiler breaks with return + (set done 1)))))))) + +(df next-frame (fp) + (let ((next (get-caller-fp fp))) + (if (and (!= next fp) + (<= next %top-level-fp)) + next + nil))) + +(df nth-frame (n top) + (let ((fp top) + (i 0)) + (while fp + (if (== i n) (return fp)) + (set fp (next-frame fp)) + (set i (+ i 1))) + nil)) + +(define Dl_info/size 16) +(define Dl_info/dli_fname 0) +(define Dl_info/dli_sname 8) + +(df get-dl-sym-name (addr) + (let ((info (! OS _balloc: (_>fix Dl_info/size)))) + (when (== (dladdr addr info) 0) + (return nil)) + (let ((sname (long@ (+ info Dl_info/dli_sname)) ) + (fname (long@ (+ info Dl_info/dli_fname)))) + (cond ((and sname fname) + (cat (_>str sname) '" in " (_>str fname))) + (sname (_>str fname)) + (fname (cat '" " (_>str fname))) + (true nil))))) + +;;(get-dl-sym-name printf) + +(df guess-function-name (ip) + (let ((fname (get-function-name ip))) + (if fname + (_>str fname) + (get-dl-sym-name ip)))) + +(df backtrace>el (top_ from_ to_) + (let ((fp (nth-frame from_ top_)) + (i from_)) + (packing (bt) + (while (and fp (< i to_)) + (let ((ip (get-frame-ip fp))) + (pack (vec (_>int i) + (cat (or (guess-function-name ip) '"(no-name)") + '" " ;;(>str (_>int ip)) + )) + bt)) + (set i (+ i 1)) + (set fp (next-frame fp)))))) + +(df debugger-info (fp msg) + (vec `(,(prin1-to-string msg) " [type ...]" ()) + '(("quit" "Return to top level")) + (backtrace>el fp 0 20) + '())) + +(define *top-frame* 0) +(define *sldb-quit* 0) + +(df debugger-loop (fd args abort) + (let ((fp (get-current-fp))) + (set *top-frame* fp) + (send-to-emacs `(:debug 0 1 ,@(debugger-info fp args)) fd) + (while 1 + (mcase (read-packet fd) + ((':emacs-rex form package thread id) + (mcase (catch% (closure (form id fd | k) + (set *sldb-quit* k) + (eval-for-emacs form id fd k) + 'ok)) + ('ok nil) + (other + (send-to-emacs `(:return (:abort) ,id) fd) + (throw% other abort)))))))) + +(df sldb (fd abort args) + (let ((old-top-frame *top-frame*) + (old-sldb-quit *sldb-quit*)) + (mcase (catch% (curry debugger-loop fd args)) + (value + (set *top-frame* old-top-frame) + (set *sldb-quit* old-sldb-quit) + (send-to-emacs `(:debug-return 0 1 nil) fd) + (throw% value abort))))) + +(df swank:backtrace (start end) + (backtrace>el *top-frame* (int>_ start) (int>_ end))) + +(df sldb-quit () + (assert *sldb-quit*) + (throw% 'top-level *sldb-quit*)) + +(df swank:invoke-nth-restart-for-emacs (...) (sldb-quit)) +(df swank:throw-to-toplevel (...) (sldb-quit)) + +(df setup-server (port announce) + (let ((sock (create-socket port))) + (announce sock) + (let ((client (accept sock))) + (process-events client) + (close client)) + (printf "Closing socket: %d %d\n" sock (local-port sock)) + (close sock))) + +(df announce-port (sock) + (printf "Listening on port: %d\n" (local-port sock))) + +(df create-server (port) (setup-server port announce-port)) + +(df write-port-file (filename sock) + (let ((f (! File create: filename))) + (! f write: (print-to-string (_>int (local-port sock)))) + (! f close))) + +(df start-swank (port-file) + (setup-server 0 (curry write-port-file (_>str port-file)))) + +(define getpid (dlsym "getpid")) +(df swank:connection-info () + `(,@'() + :pid ,(_>int (getpid)) + :style nil + :lisp-implementation (,@'() + :type "Coke" + :name "jolt" + :version ,(! CodeGenerator versionString)) + :machine (:instance "" :type ,(! OS architecture) :version "") + :features () + :package (:name "jolt" :prompt "jolt"))) + +(df swank:listener-eval (string) + (let ((result (! (! CokeScanner read: string) eval))) + `(:values ,(prin1-to-string (if (or (fix? result) + (and (valid-pointer? result) + (int? result))) + (int>_ result) + result)) + ,(prin1-to-string result)))) + +(df swank:interactive-eval (string) + (let ((result (! (! CokeScanner read: string) eval))) + (cat '"=> " (prin1-to-string (if (or (fix? result) + (and (valid-pointer? result) + (int? result))) + (int>_ result) + result)) + '", " (prin1-to-string result)))) + +(df swank:operator-arglist () nil) +(df swank:buffer-first-change () nil) +(df swank:create-repl (_) '("jolt" "jolt")) + +(df min (x y) (if (<= x y) x y)) + +(df common-prefix2 (e1 e2) + (let ((i '0) + (max (min (len e1) (len e2)))) + (while (and (< i max) + (== (ref e1 i) (ref e2 i))) + (set i (fx1+ i))) + (! e1 copyFrom: '0 to: (fx1- i)))) + +(df common-prefix (seq) + (mcase seq + (() nil) + (_ + (let ((prefix (ref seq '0))) + (dovec (e seq) + (set prefix (common-prefix2 prefix e))) + prefix)))) + +(df swank:simple-completions (prefix _package) + (let ((matches (packing (s) + (dovec (e (! TheGlobalEnvironment keys)) + (let ((name (>str e))) + (when (! name beginsWith: prefix) + (pack name s))))))) + (vec matches (or (common-prefix matches) prefix)))) + + +;; swank-jolt.k ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-kawa.scm b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-kawa.scm new file mode 100644 index 0000000..3dd9c07 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-kawa.scm @@ -0,0 +1,2504 @@ +;;;; swank-kawa.scm --- Swank server for Kawa +;;; +;;; Copyright (C) 2007 Helmut Eller +;;; +;;; This file is licensed under the terms of the GNU General Public +;;; License as distributed with Emacs (press C-h C-c for details). + +;;;; Installation +;; +;; 1. You need Kawa (version 2.x) and a JVM with debugger support. +;; +;; 2. Compile this file and create swank-kawa.jar with: +;; java -cp kawa.jar:$JAVA_HOME/lib/tools.jar \ +;; -Xss2M kawa.repl --r7rs -d classes -C swank-kawa.scm && +;; jar cf swank-kawa.jar -C classes . +;; +;; 3. Add something like this to your .emacs: +#| +;; Kawa, Swank, and the debugger classes (tools.jar) must be in the +;; classpath. You also need to start the debug agent. +(setq slime-lisp-implementations + '((kawa + ("java" + ;; needed jar files + "-cp" "kawa-2.0.1.jar:swank-kawa.jar:/opt/jdk1.8.0/lib/tools.jar" + ;; channel for debugger + "-agentlib:jdwp=transport=dt_socket,server=y,suspend=n" + ;; depending on JVM, compiler may need more stack + "-Xss2M" + ;; kawa without GUI + "kawa.repl" "-s") + :init kawa-slime-init))) + +(defun kawa-slime-init (file _) + (setq slime-protocol-version 'ignore) + (format "%S\n" + `(begin (import (swank-kawa)) + (start-swank ,file) + ;; Optionally add source paths of your code so + ;; that M-. works better: + ;;(set! swank-java-source-path + ;; (append + ;; '(,(expand-file-name "~/lisp/slime/contrib/") + ;; "/scratch/kawa") + ;; swank-java-source-path)) + ))) + +;; Optionally define a command to start it. +(defun kawa () + (interactive) + (slime 'kawa)) + +|# +;; 4. Start everything with M-- M-x slime kawa +;; +;; + + +;;; Code: + +(define-library (swank macros) + (export df fun seq set fin esc + ! !! !s @ @s + when unless while dotimes dolist for packing with pushf == assert + mif mcase mlet mlet* typecase ignore-errors + ferror + ) + (import (scheme base) + (only (kawa base) + syntax + quasisyntax + syntax-case + define-syntax-case + identifier? + + invoke + invoke-static + field + static-field + instance? + try-finally + try-catch + primitive-throw + + format + reverse! + as + )) + (begin " +(" + +(define (ferror fstring #!rest args) + (let ((err ( + (as (apply format fstring args))))) + (primitive-throw err))) + +(define (rewrite-lambda-list args) + (syntax-case args () + (() #`()) + ((rest x ...) (eq? #'rest #!rest) args) + ((optional x ...) (eq? #'optional #!optional) args) + ((var args ...) (identifier? #'var) + #`(var #,@(rewrite-lambda-list #'(args ...)))) + (((var type) args ...) (identifier? #'var) + #`((var :: type) #,@(rewrite-lambda-list #'(args ...)))))) + +(define-syntax df + (lambda (stx) + (syntax-case stx (=>) + ((df name (args ... => return-type) body ...) + #`(define (name #,@(rewrite-lambda-list #'(args ...))) :: return-type + (seq body ...))) + ((df name (args ...) body ...) + #`(define (name #,@(rewrite-lambda-list #'(args ...))) + (seq body ...)))))) + +(define-syntax fun + (lambda (stx) + (syntax-case stx (=>) + ((fun (args ... => return-type) body ...) + #`(lambda #,(rewrite-lambda-list #'(args ...)) :: return-type + (seq body ...))) + ((fun (args ...) body ...) + #`(lambda #,(rewrite-lambda-list #'(args ...)) + (seq body ...)))))) + +(define-syntax fin + (syntax-rules () + ((fin body handler ...) + (try-finally body (seq handler ...))))) + +(define-syntax seq + (syntax-rules () + ((seq) + (begin #!void)) + ((seq body ...) + (begin body ...)))) + +(define-syntax esc + (syntax-rules () + ((esc abort body ...) + (let* ((key ()) + (abort (lambda (val) (throw key val)))) + (catch key + (lambda () body ...) + (lambda (key val) val)))))) + +(define-syntax ! + (syntax-rules () + ((! name obj args ...) + (invoke obj 'name args ...)))) + +(define-syntax !! + (syntax-rules () + ((!! name1 name2 obj args ...) + (! name1 (! name2 obj args ...))))) + +(define-syntax !s + (syntax-rules () + ((! class name args ...) + (invoke-static class 'name args ...)))) + +(define-syntax @ + (syntax-rules () + ((@ name obj) + (field obj 'name)))) + +(define-syntax @s + (syntax-rules (quote) + ((@s class name) + (static-field class (quote name))))) + +(define-syntax while + (syntax-rules () + ((while exp body ...) + (do () ((not exp)) body ...)))) + +(define-syntax dotimes + (syntax-rules () + ((dotimes (i n result) body ...) + (let ((max :: n)) + (do ((i :: 0 (as (+ i 1)))) + ((= i max) result) + body ...))) + ((dotimes (i n) body ...) + (dotimes (i n #f) body ...)))) + +(define-syntax dolist + (syntax-rules () + ((dolist (e list) body ... ) + (for ((e list)) body ...)))) + +(define-syntax for + (syntax-rules () + ((for ((var iterable)) body ...) + (let ((iter (! iterator iterable))) + (while (! has-next iter) + ((lambda (var) body ...) + (! next iter))))))) + +(define-syntax packing + (syntax-rules () + ((packing (var) body ...) + (let ((var :: '())) + (let ((var (lambda (v) (set! var (cons v var))))) + body ...) + (reverse! var))))) + +;;(define-syntax loop +;; (syntax-rules (for = then collect until) +;; ((loop for var = init then step until test collect exp) +;; (packing (pack) +;; (do ((var init step)) +;; (test) +;; (pack exp)))) +;; ((loop while test collect exp) +;; (packing (pack) (while test (pack exp)))))) + +(define-syntax with + (syntax-rules () + ((with (vars ... (f args ...)) body ...) + (f args ... (lambda (vars ...) body ...))))) + +(define-syntax pushf + (syntax-rules () + ((pushf value var) + (set! var (cons value var))))) + +(define-syntax == + (syntax-rules () + ((== x y) + (eq? x y)))) + +(define-syntax set + (syntax-rules () + ((set x y) + (let ((tmp y)) + (set! x tmp) + tmp)) + ((set x y more ...) + (begin (set! x y) (set more ...))))) + +(define-syntax assert + (syntax-rules () + ((assert test) + (seq + (when (not test) + (error "Assertion failed" 'test)) + 'ok)) + ((assert test fstring args ...) + (seq + (when (not test) + (error "Assertion failed" 'test (format #f fstring args ...))) + 'ok)))) + +(define-syntax mif + (syntax-rules (quote unquote _) + ((mif ('x value) then else) + (if (equal? 'x value) then else)) + ((mif (,x value) then else) + (if (eq? x value) then else)) + ((mif (() value) then else) + (if (eq? value '()) then else)) + #| This variant produces no lambdas but breaks the compiler + ((mif ((p . ps) value) then else) + (let ((tmp value) + (fail? :: 0) + (result #!null)) + (if (instance? tmp ) + (let ((tmp :: tmp)) + (mif (p (! get-car tmp)) + (mif (ps (! get-cdr tmp)) + (set! result then) + (set! fail? -1)) + (set! fail? -1))) + (set! fail? -1)) + (if (= fail? 0) result else))) + |# + ((mif ((p . ps) value) then else) + (let ((fail (lambda () else)) + (tmp value)) + (if (instance? tmp ) + (let ((tmp :: tmp)) + (mif (p (! get-car tmp)) + (mif (ps (! get-cdr tmp)) + then + (fail)) + (fail))) + (fail)))) + ((mif (_ value) then else) + then) + ((mif (var value) then else) + (let ((var value)) then)) + ((mif (pattern value) then) + (mif (pattern value) then (values))))) + +(define-syntax mcase + (syntax-rules () + ((mcase exp (pattern body ...) more ...) + (let ((tmp exp)) + (mif (pattern tmp) + (begin body ...) + (mcase tmp more ...)))) + ((mcase exp) (ferror "mcase failed ~s\n~a" 'exp exp)))) + +(define-syntax mlet + (syntax-rules () + ((mlet (pattern value) body ...) + (let ((tmp value)) + (mif (pattern tmp) + (begin body ...) + (error "mlet failed" tmp)))))) + +(define-syntax mlet* + (syntax-rules () + ((mlet* () body ...) (begin body ...)) + ((mlet* ((pattern value) ms ...) body ...) + (mlet (pattern value) (mlet* (ms ...) body ...))))) + +(define-syntax typecase% + (syntax-rules (eql or satisfies) + ((typecase% var (#t body ...) more ...) + (seq body ...)) + ((typecase% var ((eql value) body ...) more ...) + (cond ((eqv? var 'value) body ...) + (else (typecase% var more ...)))) + ((typecase% var ((satisfies predicate) body ...) more ...) + (cond ((predicate var) body ...) + (else (typecase% var more ...)))) + ((typecase% var ((or type) body ...) more ...) + (typecase% var (type body ...) more ...)) + ((typecase% var ((or type ...) body ...) more ...) + (let ((f (lambda (var) body ...))) + (typecase% var + (type (f var)) ... + (#t (typecase% var more ...))))) + ((typecase% var (type body ...) more ...) + (cond ((instance? var type) + (let ((var :: type (as type var))) + body ...)) + (else (typecase% var more ...)))) + ((typecase% var) + (error "typecase% failed" var + (! getClass (as var)))))) + +(define-syntax typecase + (lambda (stx) + (syntax-case stx () + ((_ exp more ...) (identifier? (syntax exp)) + #`(typecase% exp more ...)) + ((_ exp more ...) + #`(let ((tmp exp)) + (typecase% tmp more ...)))))) + +(define-syntax ignore-errors + (syntax-rules () + ((ignore-errors body ...) + (try-catch (seq body ...) + (v #f) + (v #f))))) + +)) + +(define-library (swank-kawa) + (export start-swank + create-swank-server + swank-java-source-path + break) + (import (scheme base) + (scheme file) + (scheme repl) + (scheme read) + (scheme write) + (scheme eval) + (scheme process-context) + (swank macros) + (only (kawa base) + + define-alias + define-variable + + define-simple-class + this + + invoke-special + instance? + as + + primitive-throw + try-finally + try-catch + synchronized + + call-with-input-string + call-with-output-string + force-output + format + + make-process + command-parse + + runnable + + scheme-implementation-version + reverse! + ) + (rnrs hashtables) + (only (gnu kawa slib syntaxutils) expand) + (only (kawa regex) regex-match)) + (begin " +(" + + +;;(define-syntax dc +;; (syntax-rules () +;; ((dc name () %% (props ...) prop more ...) +;; (dc name () %% (props ... (prop )) more ...)) +;; ;;((dc name () %% (props ...) (prop type) more ...) +;; ;; (dc name () %% (props ... (prop type)) more ...)) +;; ((dc name () %% ((prop type) ...)) +;; (define-simple-class name () +;; ((*init* (prop :: type) ...) +;; (set (field (this) 'prop) prop) ...) +;; (prop :type type) ...)) +;; ((dc name () props ...) +;; (dc name () %% () props ...)))) + + +;;;; Aliases + +(define-alias java.net.ServerSocket) +(define-alias java.net.Socket) +(define-alias java.io.InputStreamReader) +(define-alias java.io.OutputStreamWriter) +(define-alias gnu.kawa.io.InPort) +(define-alias gnu.kawa.io.OutPort) +(define-alias java.io.File) +(define-alias java.lang.String) +(define-alias java.lang.StringBuilder) +(define-alias java.lang.Throwable) +(define-alias gnu.text.SourceError) +(define-alias gnu.expr.ModuleInfo) +(define-alias java.lang.Iterable) +(define-alias java.lang.Thread) +(define-alias java.util.concurrent.LinkedBlockingQueue) +(define-alias java.util.concurrent.Exchanger) +(define-alias java.util.concurrent.TimeUnit) +(define-alias com.sun.jdi.VirtualMachine) +(define-alias com.sun.jdi.Mirror) +(define-alias com.sun.jdi.Value) +(define-alias com.sun.jdi.ThreadReference) +(define-alias com.sun.jdi.ObjectReference) +(define-alias com.sun.jdi.ArrayReference) +(define-alias com.sun.jdi.StringReference) +(define-alias com.sun.jdi.Method) +(define-alias com.sun.jdi.ClassType) +(define-alias com.sun.jdi.ReferenceType) +(define-alias com.sun.jdi.StackFrame) +(define-alias com.sun.jdi.Field) +(define-alias com.sun.jdi.LocalVariable) +(define-alias com.sun.jdi.Location) +(define-alias com.sun.jdi.AbsentInformationException) +(define-alias com.sun.jdi.event.Event) +(define-alias com.sun.jdi.event.ExceptionEvent) +(define-alias com.sun.jdi.event.StepEvent) +(define-alias com.sun.jdi.event.BreakpointEvent) +(define-alias gnu.mapping.Environment) + +(define-simple-class () + (owner :: #:init (!s java.lang.Thread currentThread)) + (peer :: ) + (queue :: #:init ()) + (lock #:init ())) + + +;;;; Entry Points + +(df create-swank-server (port-number) + (setup-server port-number announce-port)) + +(df start-swank (port-file) + (let ((announce (fun ((socket )) + (with (f (call-with-output-file port-file)) + (format f "~d\n" (! get-local-port socket)))))) + (spawn (fun () + (setup-server 0 announce))))) + +(df setup-server ((port-number ) announce) + (! set-name (current-thread) "swank") + (let ((s ( port-number))) + (announce s) + (let ((c (! accept s))) + (! close s) + (log "connection: ~s\n" c) + (fin (dispatch-events c) + (log "closing socket: ~a\n" s) + (! close c))))) + +(df announce-port ((socket )) + (log "Listening on port: ~d\n" (! get-local-port socket))) + + +;;;; Event dispatcher + +(define-variable *the-vm* #f) +(define-variable *last-exception* #f) +(define-variable *last-stacktrace* #f) +(df %vm (=> ) *the-vm*) + +;; FIXME: this needs factorization. But I guess the whole idea of +;; using bidirectional channels just sucks. Mailboxes owned by a +;; single thread to which everybody can send are much easier to use. + +(df dispatch-events ((s )) + (mlet* ((charset "iso-8859-1") + (ins ( (! getInputStream s) charset)) + (outs ( (! getOutputStream s) charset)) + ((in . _) (spawn/chan/catch (fun (c) (reader ins c)))) + ((out . _) (spawn/chan/catch (fun (c) (writer outs c)))) + ((dbg . _) (spawn/chan/catch vm-monitor)) + (user-env (interaction-environment)) + (x (seq + (! set-flag user-env #t #|:THREAD_SAFE|# 8) + (! set-flag user-env #f #|:DIRECT_INHERITED_ON_SET|# 16) + #f)) + ((listener . _) + (spawn/chan (fun (c) (listener c user-env)))) + (inspector #f) + (threads '()) + (repl-thread #f) + (extra '()) + (vm (let ((vm #f)) (fun () (or vm (rpc dbg `(get-vm))))))) + (while #t + (mlet ((c . event) (recv* (append (list in out dbg listener) + (if inspector (list inspector) '()) + (map car threads) + extra))) + ;;(log "event: ~s\n" event) + (mcase (list c event) + ((_ (':emacs-rex ('|swank:debugger-info-for-emacs| from to) + pkg thread id)) + (send dbg `(debug-info ,thread ,from ,to ,id))) + ((_ (':emacs-rex ('|swank:throw-to-toplevel|) pkg thread id)) + (send dbg `(throw-to-toplevel ,thread ,id))) + ((_ (':emacs-rex ('|swank:sldb-continue|) pkg thread id)) + (send dbg `(thread-continue ,thread ,id))) + ((_ (':emacs-rex ('|swank:frame-source-location| frame) + pkg thread id)) + (send dbg `(frame-src-loc ,thread ,frame ,id))) + ((_ (':emacs-rex ('|swank:frame-locals-and-catch-tags| frame) + pkg thread id)) + (send dbg `(frame-details ,thread ,frame ,id))) + ((_ (':emacs-rex ('|swank:sldb-disassemble| frame) + pkg thread id)) + (send dbg `(disassemble-frame ,thread ,frame ,id))) + ((_ (':emacs-rex ('|swank:backtrace| from to) pkg thread id)) + (send dbg `(thread-frames ,thread ,from ,to ,id))) + ((_ (':emacs-rex ('|swank:list-threads|) pkg thread id)) + (send dbg `(list-threads ,id))) + ((_ (':emacs-rex ('|swank:debug-nth-thread| n) _ _ _)) + (send dbg `(debug-nth-thread ,n))) + ((_ (':emacs-rex ('|swank:quit-thread-browser|) _ _ id)) + (send dbg `(quit-thread-browser ,id))) + ((_ (':emacs-rex ('|swank:init-inspector| str . _) pkg _ id)) + (set inspector (make-inspector user-env (vm))) + (send inspector `(init ,str ,id))) + ((_ (':emacs-rex ('|swank:inspect-frame-var| frame var) + pkg thread id)) + (mlet ((im . ex) (chan)) + (set inspector (make-inspector user-env (vm))) + (send dbg `(get-local ,ex ,thread ,frame ,var)) + (send inspector `(init-mirror ,im ,id)))) + ((_ (':emacs-rex ('|swank:inspect-current-condition|) pkg thread id)) + (mlet ((im . ex) (chan)) + (set inspector (make-inspector user-env (vm))) + (send dbg `(get-exception ,ex ,thread)) + (send inspector `(init-mirror ,im ,id)))) + ((_ (':emacs-rex ('|swank:inspect-nth-part| n) pkg _ id)) + (send inspector `(inspect-part ,n ,id))) + ((_ (':emacs-rex ('|swank:inspector-pop|) pkg _ id)) + (send inspector `(pop ,id))) + ((_ (':emacs-rex ('|swank:quit-inspector|) pkg _ id)) + (send inspector `(quit ,id))) + ((_ (':emacs-interrupt id)) + (let* ((vm (vm)) + (t (find-thread id (map cdr threads) repl-thread vm))) + (send dbg `(interrupt-thread ,t)))) + ((_ (':emacs-rex form _ _ id)) + (send listener `(,form ,id))) + ((_ ('get-vm c)) + (send dbg `(get-vm ,c))) + ((_ ('get-channel c)) + (mlet ((im . ex) (chan)) + (pushf im extra) + (send c ex))) + ((_ ('forward x)) + (send out x)) + ((_ ('set-listener x)) + (set repl-thread x)) + ((_ ('publish-vm vm)) + (set *the-vm* vm)) + ))))) + +(df find-thread (id threads listener (vm )) + (cond ((== id ':repl-thread) listener) + ((== id 't) listener + ;;(if (null? threads) + ;; listener + ;; (vm-mirror vm (car threads))) + ) + (#t + (let ((f (find-if threads + (fun (t :: ) + (= id (! uniqueID + (as (vm-mirror vm t))))) + #f))) + (cond (f (vm-mirror vm f)) + (#t listener)))))) + + +;;;; Reader thread + +(df reader ((in ) (c )) + (! set-name (current-thread) "swank-net-reader") + (let ((rt (!s gnu.kawa.lispexpr.ReadTable createInitial))) ; ':' not special + (while #t + (send c (decode-message in rt))))) + +(df decode-message ((in ) (rt ) => ) + (let* ((header (read-chunk in 6)) + (len (!s java.lang.Integer parseInt header 16))) + (call-with-input-string (read-chunk in len) + (fun ((port )) + (%read port rt))))) + +(df read-chunk ((in ) (len ) => ) + (let ((chars ( #:length len))) + (let loop ((offset :: 0)) + (cond ((= offset len) ( chars)) + (#t (let ((count (! read in chars offset (- len offset)))) + (assert (not (= count -1)) "partial packet") + (loop (+ offset count)))))))) + +;;; FIXME: not thread safe +(df %read ((port ) (table )) + (let ((old (!s gnu.kawa.lispexpr.ReadTable getCurrent))) + (try-finally + (seq (!s gnu.kawa.lispexpr.ReadTable setCurrent table) + (read port)) + (!s gnu.kawa.lispexpr.ReadTable setCurrent old)))) + + +;;;; Writer thread + +(df writer ((out ) (c )) + (! set-name (current-thread) "swank-net-writer") + (while #t + (encode-message out (recv c)))) + +(df encode-message ((out ) (message )) + (let ((builder ( (as 512)))) + (print-for-emacs message builder) + (! write out (! toString (format "~6,'0x" (! length builder)))) + (! write out builder) + (! flush out))) + +(df print-for-emacs (obj (out )) + (let ((pr (fun (o) (! append out (! toString (format "~s" o))))) + (++ (fun ((s )) (! append out (! toString s))))) + (cond ((null? obj) (++ "nil")) + ((string? obj) (pr obj)) + ((number? obj) (pr obj)) + ;;((keyword? obj) (++ ":") (! append out (to-str obj))) + ((symbol? obj) (pr obj)) + ((pair? obj) + (++ "(") + (let loop ((obj obj)) + (print-for-emacs (car obj) out) + (let ((cdr (cdr obj))) + (cond ((null? cdr) (++ ")")) + ((pair? cdr) (++ " ") (loop cdr)) + (#t (++ " . ") (print-for-emacs cdr out) (++ ")")))))) + (#t (error "Unprintable object" obj))))) + +;;;; SLIME-EVAL + +(df eval-for-emacs ((form ) env (id ) (c )) + ;;(! set-uncaught-exception-handler (current-thread) + ;; ( (fun (t e) (reply-abort c id)))) + (reply c (%eval form env) id)) + +(define-variable *slime-funs*) +(set *slime-funs* (tab)) + +(df %eval (form env) + (apply (lookup-slimefun (car form) *slime-funs*) env (cdr form))) + +(df lookup-slimefun ((name ) tab) + ;; name looks like '|swank:connection-info| + (or (get tab name #f) + (ferror "~a not implemented" name))) + +(df %defslimefun ((name ) (fun )) + (let ((string (symbol->string name))) + (cond ((regex-match #/:/ string) + (put *slime-funs* name fun)) + (#t + (let ((qname (string->symbol (string-append "swank:" string)))) + (put *slime-funs* qname fun)))))) + +(define-syntax defslimefun + (syntax-rules () + ((defslimefun name (args ...) body ...) + (seq + (df name (args ...) body ...) + (%defslimefun 'name name))))) + +(defslimefun connection-info ((env )) + (let ((prop (fun (name) (!s java.lang.System getProperty name)))) + `(:pid + 0 + :style :spawn + :lisp-implementation (:type "Kawa" :name "kawa" + :version ,(scheme-implementation-version)) + :machine (:instance ,(prop "java.vm.name") :type ,(prop "os.name") + :version ,(prop "java.runtime.version")) + :features () + :package (:name "??" :prompt ,(! getName env)) + :encoding (:coding-systems ("iso-8859-1")) + ))) + + +;;;; Listener + +(df listener ((c ) (env )) + (! set-name (current-thread) "swank-listener") + (log "listener: ~s ~s ~s ~s\n" + (current-thread) (! hashCode (current-thread)) c env) + (let ((out (make-swank-outport (rpc c `(get-channel))))) + (set (current-output-port) out) + (let ((vm (as (rpc c `(get-vm))))) + (send c `(set-listener ,(vm-mirror vm (current-thread)))) + (request-uncaught-exception-events vm) + ;;stack snaphost are too expensive + ;;(request-caught-exception-events vm) + ) + (rpc c `(get-vm)) + (listener-loop c env out))) + +(define-simple-class () + ((*init*) + (invoke-special (this) '*init* )) + ((abort) :: void + (primitive-throw (this)))) + +(df listener-loop ((c ) (env ) port) + (while (not (nul? c)) + ;;(log "listener-loop: ~s ~s\n" (current-thread) c) + (mlet ((form id) (recv c)) + (let ((restart (fun () + (close-port port) + (reply-abort c id) + (send (car (spawn/chan + (fun (cc) + (listener (recv cc) env)))) + c) + (set c #!null)))) + (! set-uncaught-exception-handler (current-thread) + ( (fun (t e) (restart)))) + (try-catch + (let* ((val (%eval form env))) + (force-output) + (reply c val id)) + (ex (invoke-debugger ex) (restart)) + (ex (invoke-debugger ex) (restart)) + (ex + (let ((flag (!s java.lang.Thread interrupted))) + (log "listener-abort: ~s ~a\n" ex flag)) + (restart)) + ))))) + +(df invoke-debugger (condition) + ;;(log "should now invoke debugger: ~a" condition) + (try-catch + (break condition) + (ex (seq)))) + +(defslimefun |swank-repl:create-repl| (env #!rest _) + (list "user" "user")) + +(defslimefun interactive-eval (env str) + (values-for-echo-area (eval (read-from-string str) env))) + +(defslimefun interactive-eval-region (env (s )) + (with (port (call-with-input-string s)) + (values-for-echo-area + (let next ((result (values))) + (let ((form (read port))) + (cond ((== form #!eof) result) + (#t (next (eval form env))))))))) + +(defslimefun |swank-repl:listener-eval| (env string) + (let* ((form (read-from-string string)) + (list (values-to-list (eval form env)))) + `(:values ,@(map pprint-to-string list)))) + +(defslimefun pprint-eval (env string) + (let* ((form (read-from-string string)) + (l (values-to-list (eval form env)))) + (apply cat (map pprint-to-string l)))) + +(defslimefun eval-and-grab-output (env string) + (let ((form (read (open-input-string string)))) + (let-values ((values (eval form env))) + (list "" + (format #f "~{~S~^~%~}" values))))) + +(df call-with-abort (f) + (try-catch (f) (ex (exception-message ex)))) + +(df exception-message ((ex )) + (typecase ex + ( (! to-string ex)) + ( (format "~a: ~a" + (class-name-sans-package ex) + (! getMessage ex))))) + +(df values-for-echo-area (values) + (let ((values (values-to-list values))) + (cond ((null? values) "; No value") + (#t (format "~{~a~^, ~}" (map pprint-to-string values)))))) + +;;;; Compilation + +(defslimefun compile-file-for-emacs (env (filename ) load? + #!optional options) + (let ((jar (cat (path-sans-extension (filepath filename)) ".jar"))) + (wrap-compilation + (fun ((m )) + (!s kawa.lang.CompileFile read filename m)) + jar (if (lisp-bool load?) env #f) #f))) + +(df wrap-compilation (f jar env delete?) + (let ((start-time (current-time)) + (messages ())) + (try-catch + (let ((c (as (f messages)))) + (set (@ explicit c) #t) + (! compile-to-archive c (! get-module c) jar)) + (ex + (log "error during compilation: ~a\n~a" ex (! getStackTrace ex)) + (! error messages (as #\f) + (to-str (exception-message ex)) #!null) + #f)) + (log "compilation done.\n") + (let ((success? (zero? (! get-error-count messages)))) + (when (and env success?) + (log "loading ...\n") + (eval `(load ,jar) env) + (log "loading ... done.\n")) + (when delete? + (ignore-errors (delete-file jar) #f)) + (let ((end-time (current-time))) + (list ':compilation-result + (compiler-notes-for-emacs messages) + (if success? 't 'nil) + (/ (- end-time start-time) 1000.0)))))) + +(defslimefun compile-string-for-emacs (env string buffer offset dir) + (wrap-compilation + (fun ((m )) + (let ((c (as + (call-with-input-string + string + (fun ((p )) + (! set-path p + (format "~s" + `(buffer ,buffer offset ,offset str ,string))) + (!s kawa.lang.CompileFile read p m)))))) + (let ((o (@ currentOptions c))) + (! set o "warn-invoke-unknown-method" #t) + (! set o "warn-undefined-variable" #t)) + (let ((m (! getModule c))) + (! set-name m (format ":~a/~a" buffer (current-time)))) + c)) + "/tmp/kawa-tmp.zip" env #t)) + +(df compiler-notes-for-emacs ((messages )) + (packing (pack) + (do ((e (! get-errors messages) (@ next e))) + ((nul? e)) + (pack (source-error>elisp e))))) + +(df source-error>elisp ((e ) => ) + (list ':message (to-string (@ message e)) + ':severity (case (integer->char (@ severity e)) + ((#\e #\f) ':error) + ((#\w) ':warning) + (else ':note)) + ':location (error-loc>elisp e))) + +(df error-loc>elisp ((e )) + (cond ((nul? (@ filename e)) `(:error "No source location")) + ((! starts-with (@ filename e) "(buffer ") + (mlet (('buffer b 'offset ('quote ((:position o) _)) 'str s) + (read-from-string (@ filename e))) + (let ((off (line>offset (1- (@ line e)) s)) + (col (1- (@ column e)))) + `(:location (:buffer ,b) (:position ,(+ o off col)) nil)))) + (#t + `(:location (:file ,(to-string (@ filename e))) + (:line ,(@ line e) ,(1- (@ column e))) + nil)))) + +(df line>offset ((line ) (s ) => ) + (let ((offset :: 0)) + (dotimes (i line) + (set offset (! index-of s (as #\newline) offset)) + (assert (>= offset 0)) + (set offset (as (+ offset 1)))) + (log "line=~a offset=~a\n" line offset) + offset)) + +(defslimefun load-file (env filename) + (format "Loaded: ~a => ~s" filename (eval `(load ,filename) env))) + +;;;; Completion + +(defslimefun simple-completions (env (pattern ) _) + (let* ((env (as env)) + (matches (packing (pack) + (let ((iter (! enumerate-all-locations env))) + (while (! has-next iter) + (let ((l (! next-location iter))) + (typecase l + ( + (let ((name (!! get-name get-key-symbol l))) + (when (! starts-with name pattern) + (pack name))))))))))) + `(,matches ,(cond ((null? matches) pattern) + (#t (fold+ common-prefix matches)))))) + +(df common-prefix ((s1 ) (s2 ) => ) + (let ((limit (min (! length s1) (! length s2)))) + (let loop ((i 0)) + (cond ((or (= i limit) + (not (== (! char-at s1 i) + (! char-at s2 i)))) + (! substring s1 0 i)) + (#t (loop (1+ i))))))) + +(df fold+ (f list) + (let loop ((s (car list)) + (l (cdr list))) + (cond ((null? l) s) + (#t (loop (f s (car l)) (cdr l)))))) + +;;; Quit + +(defslimefun quit-lisp (env) + (exit)) + +;;(defslimefun set-default-directory (env newdir)) + + +;;;; Dummy defs + +(defslimefun buffer-first-change (#!rest y) '()) +(defslimefun swank-require (#!rest y) '()) +(defslimefun frame-package-name (#!rest y) '()) + +;;;; arglist + +(defslimefun operator-arglist (env name #!rest _) + (mcase (try-catch `(ok ,(eval (read-from-string name) env)) + (ex 'nil)) + (('ok obj) + (mcase (arglist obj) + ('#f 'nil) + ((args rtype) + (format "(~a~{~^ ~a~})~a" name + (map (fun (e) + (if (equal (cadr e) "java.lang.Object") (car e) e)) + args) + (if (equal rtype "java.lang.Object") + "" + (format " => ~a" rtype)))))) + (_ 'nil))) + +(df arglist (obj) + (typecase obj + ( + (let* ((mref (module-method>meth-ref obj))) + (list (mapi (! arguments mref) + (fun ((v )) + (list (! name v) (! typeName v)))) + (! returnTypeName mref)))) + ( #f))) + +;;;; M-. + +(defslimefun find-definitions-for-emacs (env name) + (mcase (try-catch `(ok ,(eval (read-from-string name) env)) + (ex `(error ,(exception-message ex)))) + (('ok obj) (mapi (all-definitions obj) + (fun (d) + `(,(format "~a" d) ,(src-loc>elisp (src-loc d)))))) + (('error msg) `((,name (:error ,msg)))))) + +(define-simple-class () + (file #:init #f) + (line #:init #f) + ((*init* file name) + (set (@ file (this)) file) + (set (@ line (this)) line)) + ((lineNumber) :: (or line (absent))) + ((lineNumber (s :: )) :: int (! lineNumber (this))) + ((method) :: (absent)) + ((sourcePath) :: (or file (absent))) + ((sourcePath (s :: )) :: (! sourcePath (this))) + ((sourceName) :: (absent)) + ((sourceName (s :: )) :: (! sourceName (this))) + ((declaringType) :: (absent)) + ((codeIndex) :: -1) + ((virtualMachine) :: *the-vm*) + ((compareTo o) :: + (typecase o + ( (- (! codeIndex (this)) (! codeIndex o)))))) + +(df absent () (primitive-throw ())) + +(df all-definitions (o) + (typecase o + ( (list o)) + ( (list o)) + ( (append (mappend all-definitions (gf-methods o)) + (let ((s (! get-setter o))) + (if s (all-definitions s) '())))) + ( (list o)) + ( (all-definitions (! get-class o))) + ( (list o)) + ( (all-definitions (! getReflectClass o))) + ( '()) + )) + +(df gf-methods ((f )) + (let* ((o :: (vm-mirror *the-vm* f)) + (f (! field-by-name (! reference-type o) "methods")) + (ms (vm-demirror *the-vm* (! get-value o f)))) + (filter (array-to-list ms) (fun (x) (not (nul? x)))))) + +(df src-loc (o => ) + (typecase o + ( (src-loc (@ method o))) + ( (module-method>src-loc o)) + ( ( #f #f)) + ( (class>src-loc o)) + ( ( #f #f)) + ( (bytemethod>src-loc o)))) + +(df module-method>src-loc ((f )) + (! location (module-method>meth-ref f))) + +(df module-method>meth-ref ((f ) => ) + (let* ((module (! reference-type + (as (vm-mirror *the-vm* (@ module f))))) + (1st-method-by-name (fun (name) + (let ((i (! methods-by-name module name))) + (cond ((! is-empty i) #f) + (#t (1st i))))))) + (as (or (1st-method-by-name (! get-name f)) + (let ((mangled (mangled-name f))) + (or (1st-method-by-name mangled) + (1st-method-by-name (cat mangled "$V")) + (1st-method-by-name (cat mangled "$X")))))))) + +(df mangled-name ((f )) + (let* ((name0 (! get-name f)) + (name (cond ((nul? name0) (format "lambda~d" (@ selector f))) + (#t (!s gnu.expr.Compilation mangleName name0))))) + name)) + +(df class>src-loc ((c ) => ) + (let* ((type (class>ref-type c)) + (locs (! all-line-locations type))) + (cond ((not (! isEmpty locs)) (1st locs)) + (#t ( (1st (! source-paths type "Java")) + #f))))) + +(df class>ref-type ((class ) => ) + (! reflectedType (as + (vm-mirror *the-vm* class)))) + +(df class>class-type ((class ) => ) + (as (class>ref-type class))) + +(df bytemethod>src-loc ((m ) => ) + (let* ((cls (class>class-type (! get-reflect-class + (! get-declaring-class m)))) + (name (! get-name m)) + (sig (! get-signature m)) + (meth (! concrete-method-by-name cls name sig))) + (! location meth))) + +(df src-loc>elisp ((l )) + (df src-loc>list ((l )) + (list (ignore-errors (! source-name l "Java")) + (ignore-errors (! source-path l "Java")) + (ignore-errors (! line-number l "Java")))) + (mcase (src-loc>list l) + ((name path line) + (cond ((not path) + `(:error ,(call-with-abort (fun () (! source-path l))))) + ((! starts-with (as path) "(buffer ") + (mlet (('buffer b 'offset o 'str s) (read-from-string path)) + `(:location (:buffer ,b) + (:position ,(+ o (line>offset line s))) + nil))) + (#t + `(:location ,(or (find-file-in-path name (source-path)) + (find-file-in-path path (source-path)) + (ferror "Can't find source-path: ~s ~s ~a" + path name (source-path))) + (:line ,(or line -1)) ())))))) + +(df src-loc>str ((l )) + (cond ((nul? l) "") + (#t (format "~a ~a ~a" + (or (ignore-errors (! source-path l)) + (ignore-errors (! source-name l)) + (ignore-errors (!! name declaring-type l))) + (ignore-errors (!! name method l)) + (ignore-errors (! lineNumber l)))))) + +;;;;;; class-path hacking + +;; (find-file-in-path "kawa/lib/kawa/hashtable.scm" (source-path)) + +(df find-file-in-path ((filename ) (path )) + (let ((f ( filename))) + (cond ((! isAbsolute f) `(:file ,filename)) + (#t (let ((result #f)) + (find-if path (fun (dir) + (let ((x (find-file-in-dir f dir))) + (set result x))) + #f) + result))))) + +(df find-file-in-dir ((file ) (dir )) + (let ((filename :: (! getPath file))) + (or (let ((child ( ( dir) filename))) + (and (! exists child) + `(:file ,(! getPath child)))) + (try-catch + (and (not (nul? (! getEntry ( dir) filename))) + `(:zip ,dir ,filename)) + (ex #f))))) + +(define swank-java-source-path + (let* ((jre-home :: (!s getProperty "java.home")) + (parent :: (! get-parent ( jre-home)))) + (list (! get-path ( parent "src.zip"))))) + +(df source-path () + (mlet ((base) (search-path-prop "user.dir")) + (append + (list base) + (map (fun ((s )) + (let ((f ( s)) + (base :: (as base))) + (cond ((! isAbsolute f) s) + (#t (! getPath ( base s)))))) + (class-path)) + swank-java-source-path))) + +(df class-path () + (append (search-path-prop "java.class.path") + (search-path-prop "sun.boot.class.path"))) + +(df search-path-prop ((name )) + (array-to-list (! split (!s java.lang.System getProperty name) + (@s pathSeparator)))) + +;;;; Disassemble + +(defslimefun disassemble-form (env form) + (mcase (read-from-string form) + (('quote name) + (let ((f (eval name env))) + (typecase f + ( + (disassemble-to-string (module-method>meth-ref f)))))))) + +(df disassemble-to-string ((mr ) => ) + (with-sink #f (fun (out) (disassemble-meth-ref mr out)))) + +(df disassemble-meth-ref ((mr ) (out )) + (let* ((t (! declaring-type mr))) + (disas-header mr out) + (disas-code (! constant-pool t) + (! constant-pool-count t) + (! bytecodes mr) + out))) + +(df disas-header ((mr ) (out )) + (let* ((++ (fun ((str )) (! write out str))) + (? (fun (flag str) (if flag (++ str))))) + (? (! is-static mr) "static ") + (? (! is-final mr) "final ") + (? (! is-private mr) "private ") + (? (! is-protected mr) "protected ") + (? (! is-public mr) "public ") + (++ (! name mr)) (++ (! signature mr)) (++ "\n"))) + +(df disas-code ((cpool ) (cpoolcount ) (bytecode ) + (out )) + (let* ((ct ( "foo")) + (met (! addMethod ct "bar" 0)) + (ca ( met)) + (constants (let* ((bs ()) + (s ( bs))) + (! write-short s cpoolcount) + (! write s cpool) + (! flush s) + (! toByteArray bs)))) + (vm-set-slot *the-vm* ct "constants" + ( + ( + ( + constants)))) + (! setCode ca bytecode) + (let ((w ( ct out 0))) + (! print ca w) + (! flush w)))) + +(df with-sink (sink (f )) + (cond ((instance? sink ) (f sink)) + ((== sink #t) (f (as (current-output-port)))) + ((== sink #f) + (let* ((buffer ()) + (out ( buffer))) + (f out) + (! flush out) + (! toString buffer))) + (#t (ferror "Invalid sink designator: ~s" sink)))) + +(df test-disas ((c ) (m )) + (let* ((vm (as *the-vm*)) + (c (as (1st (! classes-by-name vm c)))) + (m (as (1st (! methods-by-name c m))))) + (with-sink #f (fun (out) (disassemble-meth-ref m out))))) + +;; (test-disas "java.lang.Class" "toString") + + +;;;; Macroexpansion + +(defslimefun swank-expand-1 (env s) (%swank-macroexpand s env)) +(defslimefun swank-expand (env s) (%swank-macroexpand s env)) +(defslimefun swank-expand-all (env s) (%swank-macroexpand s env)) + +(df %swank-macroexpand (string env) + (pprint-to-string (%macroexpand (read-from-string string) env))) + +(df %macroexpand (sexp env) (expand sexp #:env env)) + + +;;;; Inspector + +(define-simple-class () + (object #:init #!null) + (parts :: #:init () ) + (stack :: #:init '()) + (content :: #:init '())) + +(df make-inspector (env (vm ) => ) + (car (spawn/chan (fun (c) (inspector c env vm))))) + +(df inspector ((c ) env (vm )) + (! set-name (current-thread) "inspector") + (let ((state :: ()) + (open #t)) + (while open + (mcase (recv c) + (('init str id) + (set state ()) + (let ((obj (try-catch (eval (read-from-string str) env) + (ex ex)))) + (reply c (inspect-object obj state vm) id))) + (('init-mirror cc id) + (set state ()) + (let* ((mirror (recv cc)) + (obj (vm-demirror vm mirror))) + (reply c (inspect-object obj state vm) id))) + (('inspect-part n id) + (let ((part (! get (@ parts state) n))) + (reply c (inspect-object part state vm) id))) + (('pop id) + (reply c (inspector-pop state vm) id)) + (('quit id) + (reply c 'nil id) + (set open #f)))))) + +(df inspect-object (obj (state ) (vm )) + (set (@ object state) obj) + (set (@ parts state) ()) + (pushf obj (@ stack state)) + (set (@ content state) (inspector-content + `("class: " (:value ,(! getClass obj)) "\n" + ,@(inspect obj vm)) + state)) + (cond ((nul? obj) (list ':title "#!null" ':id 0 ':content `())) + (#t + (list ':title (pprint-to-string obj) + ':id (assign-index obj state) + ':content (let ((c (@ content state))) + (content-range c 0 (len c))))))) + +(df inspect (obj vm) + (let ((obj (as (vm-mirror vm obj)))) + (typecase obj + ( (inspect-array-ref vm obj)) + ( (inspect-obj-ref vm obj))))) + +(df inspect-array-ref ((vm ) (obj )) + (packing (pack) + (let ((i 0)) + (for (((v :: ) (! getValues obj))) + (pack (format "~d: " i)) + (pack `(:value ,(vm-demirror vm v))) + (pack "\n") + (set i (1+ i)))))) + +(df inspect-obj-ref ((vm ) (obj )) + (let* ((type (! referenceType obj)) + (fields (! allFields type)) + (values (! getValues obj fields)) + (ifields '()) (sfields '()) (imeths '()) (smeths '()) + (frob (lambda (lists) (apply append (reverse lists))))) + (for (((f :: ) fields)) + (let* ((val (as (! get values f))) + (l `(,(! name f) ": " (:value ,(vm-demirror vm val)) "\n"))) + (if (! is-static f) + (pushf l sfields) + (pushf l ifields)))) + (for (((m :: ) (! allMethods type))) + (let ((l `(,(! name m) ,(! signature m) "\n"))) + (if (! is-static m) + (pushf l smeths) + (pushf l imeths)))) + `(,@(frob ifields) + "--- static fields ---\n" ,@(frob sfields) + "--- methods ---\n" ,@(frob imeths) + "--- static methods ---\n" ,@(frob smeths)))) + +(df inspector-content (content (state )) + (map (fun (part) + (mcase part + ((':value val) + `(:value ,(pprint-to-string val) ,(assign-index val state))) + (x (to-string x)))) + content)) + +(df assign-index (obj (state ) => ) + (! add (@ parts state) obj) + (1- (! size (@ parts state)))) + +(df content-range (l start end) + (let* ((len (length l)) (end (min len end))) + (list (subseq l start end) len start end))) + +(df inspector-pop ((state ) vm) + (cond ((<= 2 (len (@ stack state))) + (let ((obj (cadr (@ stack state)))) + (set (@ stack state) (cddr (@ stack state))) + (inspect-object obj state vm))) + (#t 'nil))) + +;;;; IO redirection + +(define-simple-class () + (q :: #:init ( (as 100))) + ((*init*) (invoke-special (this) '*init*)) + ((write (buffer :: ) (from :: ) (to :: )) :: + (synchronized (this) + (assert (not (== q #!null))) + (! put q `(write ,( buffer from to))))) + ((close) :: + (synchronized (this) + (! put q 'close) + (set! q #!null))) + ((flush) :: + (synchronized (this) + (assert (not (== q #!null))) + (let ((ex ())) + (! put q `(flush ,ex)) + (! exchange ex #!null))))) + +(df swank-writer ((in ) (q )) + (! set-name (current-thread) "swank-redirect-thread") + (let* ((out (as (recv in))) + (builder ()) + (flush (fun () + (unless (zero? (! length builder)) + (send out `(forward (:write-string ,( builder)))) + (! setLength builder 0)))) + (closed #f)) + (while (not closed) + (mcase (! poll q (as long 200) (@s MILLISECONDS)) + ('#!null (flush)) + (('write s) + (! append builder (as s)) + (when (> (! length builder) 4000) + (flush))) + (('flush ex) + (flush) + (! exchange (as ex) #!null)) + ('close + (set closed #t) + (flush)))))) + +(df make-swank-outport ((out )) + (let ((w ())) + (mlet ((in . _) (spawn/chan (fun (c) (swank-writer c (@ q w))))) + (send in out)) + ( w #t #t))) + + +;;;; Monitor + +;;(define-simple-class () +;; (threadmap type: (tab))) + +(df vm-monitor ((c )) + (! set-name (current-thread) "swank-vm-monitor") + (let ((vm (vm-attach))) + (log-vm-props vm) + (request-breakpoint vm) + (mlet* (((ev . _) (spawn/chan/catch + (fun (c) + (let ((q (! eventQueue vm))) + (while #t + (send c `(vm-event ,(to-list (! remove q))))))))) + (to-string (vm-to-string vm)) + (state (tab))) + (send c `(publish-vm ,vm)) + (while #t + (mcase (recv* (list c ev)) + ((_ . ('get-vm cc)) + (send cc vm)) + ((,c . ('debug-info thread from to id)) + (reply c (debug-info thread from to state) id)) + ((,c . ('throw-to-toplevel thread id)) + (set state (throw-to-toplevel thread id c state))) + ((,c . ('thread-continue thread id)) + (set state (thread-continue thread id c state))) + ((,c . ('frame-src-loc thread frame id)) + (reply c (frame-src-loc thread frame state) id)) + ((,c . ('frame-details thread frame id)) + (reply c (list (frame-locals thread frame state) '()) id)) + ((,c . ('disassemble-frame thread frame id)) + (reply c (disassemble-frame thread frame state) id)) + ((,c . ('thread-frames thread from to id)) + (reply c (thread-frames thread from to state) id)) + ((,c . ('list-threads id)) + (reply c (list-threads vm state) id)) + ((,c . ('interrupt-thread ref)) + (set state (interrupt-thread ref state c))) + ((,c . ('debug-nth-thread n)) + (let ((t (nth (get state 'all-threads #f) n))) + ;;(log "thread ~d : ~a\n" n t) + (set state (interrupt-thread t state c)))) + ((,c . ('quit-thread-browser id)) + (reply c 't id) + (set state (del state 'all-threads))) + ((,ev . ('vm-event es)) + ;;(log "vm-events: len=~a\n" (len es)) + (for (((e :: ) (as es))) + (set state (process-vm-event e c state)))) + ((_ . ('get-exception from tid)) + (mlet ((_ _ es) (get state tid #f)) + (send from (let ((e (car es))) + (typecase e + ( (! exception e)) + ( e)))))) + ((_ . ('get-local rc tid frame var)) + (send rc (frame-local-var tid frame var state))) + ))))) + +(df reply ((c ) value id) + (send c `(forward (:return (:ok ,value) ,id)))) + +(df reply-abort ((c ) id) + (send c `(forward (:return (:abort nil) ,id)))) + +(df process-vm-event ((e ) (c ) state) + ;;(log "vm-event: ~s\n" e) + (typecase e + ( + ;;(log "exception: ~s\n" (! exception e)) + ;;(log "exception-message: ~s\n" + ;; (exception-message (vm-demirror *the-vm* (! exception e)))) + ;;(log "exception-location: ~s\n" (src-loc>str (! location e))) + ;;(log "exception-catch-location: ~s\n" (src-loc>str (! catch-location e))) + (cond ((! notifyUncaught (as + (! request e))) + (process-exception e c state)) + (#t + (let* ((t (! thread e)) + (r (! request e)) + (ex (! exception e))) + (unless (eq? *last-exception* ex) + (set *last-exception* ex) + (set *last-stacktrace* (copy-stack t))) + (! resume t)) + state))) + ( + (let* ((r (! request e)) + (k (! get-property r 'continuation))) + (! disable r) + (log "k: ~s\n" k) + (k e)) + state) + ( + (log "breakpoint event: ~a\n" e) + (debug-thread (! thread e) e state c)) + )) + +(df process-exception ((e ) (c ) state) + (let* ((tref (! thread e)) + (tid (! uniqueID tref)) + (s (get state tid #f))) + (mcase s + ('#f + ;; XXX redundant in debug-thread + (let* ((level 1) + (state (put state tid (list tref level (list e))))) + (send c `(forward (:debug ,tid ,level + ,@(debug-info tid 0 15 state)))) + (send c `(forward (:debug-activate ,tid ,level))) + state)) + ((_ level exs) + (send c `(forward (:debug-activate ,(! uniqueID tref) ,level))) + (put state tid (list tref (1+ level) (cons e exs))))))) + +(define-simple-class () + (loc :: ) + (args) + (names) + (values :: ) + (self) + ((*init* (loc :: ) args names (values :: ) self) + (set (@ loc (this)) loc) + (set (@ args (this)) args) + (set (@ names (this)) names) + (set (@ values (this)) values) + (set (@ self (this)) self)) + ((toString) :: + (format "#" (src-loc>str loc)))) + +(df copy-stack ((t )) + (packing (pack) + (iter (! frames t) + (fun ((f )) + (let ((vars (ignore-errors (! visibleVariables f)))) + (pack ( + (or (ignore-errors (! location f)) #!null) + (ignore-errors (! getArgumentValues f)) + (or vars #!null) + (or (and vars (ignore-errors (! get-values f vars))) + #!null) + (ignore-errors (! thisObject f))))))))) + +(define-simple-class () + (thread :: ) + ((*init* (thread :: )) (set (@ thread (this)) thread)) + ((request) :: #!null) + ((virtualMachine) :: (! virtualMachine thread))) + +(df break (#!optional condition) + ((breakpoint condition))) + +;; We set a breakpoint on this function. It returns a function which +;; specifies what the debuggee should do next (the actual return value +;; is set via JDI). Lets hope that the compiler doesn't optimize this +;; away. +(df breakpoint (condition => ) + (fun () #!null)) + +;; Enable breakpoints event on the breakpoint function. +(df request-breakpoint ((vm )) + (let* ((swank-classes (! classesByName vm "swank-kawa")) + (swank-classes-legacy (! classesByName vm "swank$Mnkawa")) + (class :: (1st (if (= (length swank-classes) 0) + swank-classes-legacy + swank-classes))) + (meth :: (1st (! methodsByName class "breakpoint"))) + (erm (! eventRequestManager vm)) + (req (! createBreakpointRequest erm (! location meth)))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! put-property req 'swank #t) + (! put-property req 'argname "condition") + (! enable req))) + +(df log-vm-props ((vm )) + (letrec-syntax ((p (syntax-rules () + ((p name) (log "~s: ~s\n" 'name (! name vm))))) + (p* (syntax-rules () + ((p* n ...) (seq (p n) ...))))) + (p* canBeModified + canRedefineClasses + canAddMethod + canUnrestrictedlyRedefineClasses + canGetBytecodes + canGetConstantPool + canGetSyntheticAttribute + canGetSourceDebugExtension + canPopFrames + canForceEarlyReturn + canGetMethodReturnValues + canGetInstanceInfo + ))) + +;;;;; Debugger + +(df debug-thread ((tref ) (ev ) state (c )) + (unless (! is-suspended tref) + (! suspend tref)) + (let* ((id (! uniqueID tref)) + (level 1) + (state (put state id (list tref level (list ev))))) + (send c `(forward (:debug ,id ,level ,@(debug-info id 0 10 state)))) + (send c `(forward (:debug-activate ,id ,level))) + state)) + +(df interrupt-thread ((tref ) state (c )) + (debug-thread tref ( tref) state c)) + +(df debug-info ((tid ) (from ) to state) + (mlet ((thread-ref level evs) (get state tid #f)) + (let* ((tref (as thread-ref)) + (vm (! virtualMachine tref)) + (ev (as (car evs))) + (ex (typecase ev + ( (breakpoint-condition ev)) + ( (! exception ev)) + ( ( "Interrupt")))) + (desc (typecase ex + ( + ;;(log "ex: ~a ~a\n" ex (vm-demirror vm ex)) + (! toString (vm-demirror vm ex))) + ( (! toString ex)))) + (type (format " [type ~a]" + (typecase ex + ( (! name (! referenceType ex))) + ( (!! getName getClass ex))))) + (bt (thread-frames tid from to state))) + `((,desc ,type nil) (("quit" "terminate current thread")) ,bt ())))) + +(df breakpoint-condition ((e ) => ) + (let ((frame (! frame (! thread e) 0))) + (1st (! get-argument-values frame)))) + +(df thread-frames ((tid ) (from ) to state) + (mlet ((thread level evs) (get state tid #f)) + (let* ((thread (as thread)) + (fcount (! frameCount thread)) + (stacktrace (event-stacktrace (car evs))) + (missing (cond ((zero? (len stacktrace)) 0) + (#t (- (len stacktrace) fcount)))) + (fstart (max (- from missing) 0)) + (flen (max (- to from missing) 0)) + (frames (! frames thread fstart (min flen (- fcount fstart))))) + (packing (pack) + (let ((i from)) + (dotimes (_ (max (- missing from) 0)) + (pack (list i (format "~a" (stacktrace i)))) + (set i (1+ i))) + (iter frames (fun ((f )) + (let ((s (frame-to-string f))) + (pack (list i s)) + (set i (1+ i)))))))))) + +(df event-stacktrace ((ev )) + (let ((nothing (fun () ())) + (vm (! virtualMachine ev))) + (typecase ev + ( + (let ((condition (vm-demirror vm (breakpoint-condition ev)))) + (cond ((instance? condition ) + (throwable-stacktrace vm condition)) + (#t (nothing))))) + ( + (throwable-stacktrace vm (vm-demirror vm (! exception ev)))) + ( (nothing))))) + +(df throwable-stacktrace ((vm ) (ex )) + (cond ((== ex (ignore-errors (vm-demirror vm *last-exception*))) + *last-stacktrace*) + (#t + (! getStackTrace ex)))) + +(df frame-to-string ((f )) + (let ((loc (! location f)) + (vm (! virtualMachine f))) + (format "~a (~a)" (!! name method loc) + (call-with-abort + (fun () (format "~{~a~^ ~}" + (mapi (! getArgumentValues f) + (fun (arg) + (pprint-to-string + (vm-demirror vm arg)))))))))) + +(df frame-src-loc ((tid ) (n ) state) + (try-catch + (mlet* (((frame vm) (nth-frame tid n state)) + (vm (as vm))) + (src-loc>elisp + (typecase frame + ( (! location frame)) + ( (@ loc frame)) + ( + (let* ((classname (! getClassName frame)) + (classes (! classesByName vm classname)) + (t (as (1st classes)))) + (1st (! locationsOfLine t (! getLineNumber frame)))))))) + (ex + (let ((msg (! getMessage ex))) + `(:error ,(if (== msg #!null) + (! toString ex) + msg)))))) + +(df nth-frame ((tid ) (n ) state) + (mlet ((tref level evs) (get state tid #f)) + (let* ((thread (as tref)) + (fcount (! frameCount thread)) + (stacktrace (event-stacktrace (car evs))) + (missing (cond ((zero? (len stacktrace)) 0) + (#t (- (len stacktrace) fcount)))) + (vm (! virtualMachine thread)) + (frame (cond ((< n missing) + (stacktrace n)) + (#t (! frame thread (- n missing)))))) + (list frame vm)))) + +;;;;; Locals + +(df frame-locals ((tid ) (n ) state) + (mlet ((thread _ _) (get state tid #f)) + (let* ((thread (as thread)) + (vm (! virtualMachine thread)) + (p (fun (x) (pprint-to-string + (call-with-abort (fun () (vm-demirror vm x))))))) + (map (fun (x) + (mlet ((name value) x) + (list ':name name ':value (p value) ':id 0))) + (%frame-locals tid n state))))) + +(df frame-local-var ((tid ) (frame ) (var ) state => ) + (cadr (nth (%frame-locals tid frame state) var))) + +(df %frame-locals ((tid ) (n ) state) + (mlet ((frame _) (nth-frame tid n state)) + (typecase frame + ( + (let* ((visible (try-catch (! visibleVariables frame) + (ex + '()))) + (map (! getValues frame visible)) + (p (fun (x) x))) + (packing (pack) + (let ((self (ignore-errors (! thisObject frame)))) + (when self + (pack (list "this" (p self))))) + (iter (! entrySet map) + (fun ((e )) + (let ((var (as (! getKey e))) + (val (as (! getValue e)))) + (pack (list (! name var) (p val))))))))) + ( + (packing (pack) + (when (@ self frame) + (pack (list "this" (@ self frame)))) + (iter (! entrySet (@ values frame)) + (fun ((e )) + (let ((var (as (! getKey e))) + (val (as (! getValue e)))) + (pack (list (! name var) val))))))) + ( '())))) + +(df disassemble-frame ((tid ) (frame ) state) + (mlet ((frame _) (nth-frame tid frame state)) + (typecase frame + ( "") + ( + (let* ((l (! location frame)) + (m (! method l)) + (c (! declaringType l))) + (disassemble-to-string m)))))) + +;;;;; Restarts + +;; FIXME: factorize +(df throw-to-toplevel ((tid ) (id ) (c ) state) + (mlet ((tref level exc) (get state tid #f)) + (let* ((t (as tref)) + (ev (car exc))) + (typecase ev + ( ; actually uncaughtException + (! resume t) + (reply-abort c id) + ;;(send-debug-return c tid state) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid)) + ( + ;; XXX race condition? + (log "resume from from break (suspendCount: ~d)\n" (! suspendCount t)) + (let ((vm (! virtualMachine t)) + (k (fun () (primitive-throw ())))) + (reply-abort c id) + (! force-early-return t (vm-mirror vm k)) + (! resume t) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid))) + ( + (log "resume from from interrupt\n") + (let ((vm (! virtualMachine t))) + (! stop t (vm-mirror vm ())) + (! resume t) + (reply-abort c id) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid)) + ))))) + +(df thread-continue ((tid ) (id ) (c ) state) + (mlet ((tref level exc) (get state tid #f)) + (log "thread-continue: ~a ~a ~a \n" tref level exc) + (let* ((t (as tref))) + (! resume t)) + (reply-abort c id) + (do ((level level (1- level)) + (exc exc (cdr exc))) + ((null? exc)) + (send c `(forward (:debug-return ,tid ,level nil)))) + (del state tid))) + +(df thread-step ((t ) k) + (let* ((vm (! virtual-machine t)) + (erm (! eventRequestManager vm)) + ( ) + (req (! createStepRequest erm t + (@s STEP_MIN) + (@s STEP_OVER)))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! addCountFilter req 1) + (! put-property req 'continuation k) + (! enable req))) + +(df eval-in-thread ((t ) sexp + #!optional (env :: (!s current))) + (let* ((vm (! virtualMachine t)) + (sc :: + (1st (! classes-by-name vm "kawa.standard.Scheme"))) + (ev :: + (1st (! methods-by-name sc "eval" + (cat "(Ljava/lang/Object;Lgnu/mapping/Environment;)" + "Ljava/lang/Object;"))))) + (! invokeMethod sc t ev (list sexp env) + (@s INVOKE_SINGLE_THREADED)))) + +;;;;; Threads + +(df list-threads (vm :: state) + (let* ((threads (! allThreads vm))) + (put state 'all-threads threads) + (packing (pack) + (pack '(\:id \:name \:status \:priority)) + (iter threads (fun ((t )) + (pack (list (! uniqueID t) + (! name t) + (let ((s (thread-status t))) + (if (! is-suspended t) + (cat "SUSPENDED/" s) + s)) + 0))))))) + +(df thread-status (t :: ) + (let ((s (! status t))) + (cond ((= s (@s THREAD_STATUS_UNKNOWN)) "UNKNOWN") + ((= s (@s THREAD_STATUS_ZOMBIE)) "ZOMBIE") + ((= s (@s THREAD_STATUS_RUNNING)) "RUNNING") + ((= s (@s THREAD_STATUS_SLEEPING)) "SLEEPING") + ((= s (@s THREAD_STATUS_MONITOR)) "MONITOR") + ((= s (@s THREAD_STATUS_WAIT)) "WAIT") + ((= s (@s THREAD_STATUS_NOT_STARTED)) "NOT_STARTED") + (#t "")))) + +;;;;; Bootstrap + +(df vm-attach (=> ) + (attach (getpid) 20)) + +(df attach (pid timeout) + (log "attaching: ~a ~a\n" pid timeout) + (let* (( ) + ( ) + (vmm (!s com.sun.jdi.Bootstrap virtualMachineManager)) + (pa (as + (or + (find-if (! attaching-connectors vmm) + (fun (x :: ) + (! equals (! name x) "com.sun.jdi.ProcessAttach")) + #f) + (error "ProcessAttach connector not found")))) + (args (! default-arguments pa))) + (! set-value (as (! get args (to-str "pid"))) pid) + (when timeout + (! set-value (as (! get args (to-str "timeout"))) timeout)) + (log "attaching2: ~a ~a\n" pa args) + (! attach pa args))) + +(df getpid () + (let ((p (make-process (command-parse "echo $PPID") #!null))) + (! waitFor p) + (! read-line ( ( (! get-input-stream p)))))) + +(df request-uncaught-exception-events ((vm )) + (let* ((erm (! eventRequestManager vm)) + (req (! createExceptionRequest erm #!null #f #t))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! addThreadFilter req (vm-mirror vm (current-thread))) + (! enable req))) + + +(df request-caught-exception-events ((vm )) + (let* ((erm (! eventRequestManager vm)) + (req (! createExceptionRequest erm #!null #t #f))) + (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) + (! addThreadFilter req (vm-mirror vm (current-thread))) + (! addClassExclusionFilter req "java.lang.ClassLoader") + (! addClassExclusionFilter req "java.net.URLClassLoader") + (! addClassExclusionFilter req "java.net.URLClassLoader$1") + (! enable req))) + +(df set-stacktrace-recording ((vm ) (flag )) + (for (((e :: ) + (!! exceptionRequests eventRequestManager vm))) + (when (! notify-caught e) + (! setEnabled e flag)))) + +;; (set-stacktrace-recording *the-vm* #f) + +(df vm-to-string ((vm )) + (let* ((obj (as (1st (! classesByName vm "java.lang.Object")))) + (met (as (1st (! methodsByName obj "toString"))))) + (fun ((o ) (t )) + (! value + (as + (! invokeMethod o t met '() + (@s INVOKE_SINGLE_THREADED))))))) + +(define-simple-class () + (var #:allocation 'static)) + +(define-variable *global-get-mirror* #!null) +(define-variable *global-set-mirror* #!null) +(define-variable *global-get-raw* #!null) +(define-variable *global-set-raw* #!null) + +(df init-global-field ((vm )) + (when (nul? *global-get-mirror*) + (set (@s var) #!null) ; prepare class + (let* ((swank-global-variable-classes + (! classes-by-name vm "swank-global-variable")) + (swank-global-variable-classes-legacy + (! classes-by-name vm "swank$Mnglobal$Mnvariable")) + (c (as + (1st (if (= (length swank-global-variable-classes) 0) + swank-global-variable-classes-legacy + swank-global-variable-classes)))) + (f (! fieldByName c "var"))) + (set *global-get-mirror* (fun () (! getValue c f))) + (set *global-set-mirror* (fun ((v )) (! setValue c f v)))) + (set *global-get-raw* (fun () '() (@s var))) + (set *global-set-raw* (fun (x) + (set (@s var) x))))) + +(df vm-mirror ((vm ) obj) + (synchronized vm + (init-global-field vm) + (*global-set-raw* obj) + (*global-get-mirror*))) + +(df vm-demirror ((vm ) (v )) + (synchronized vm + (if (== v #!null) + #!null + (typecase v + ( (init-global-field vm) + (*global-set-mirror* v) + (*global-get-raw*)) + ( (! value v)) + ( (! value v)) + ( (! value v)) + ( (! value v)) + ( (! value v)) + ( (! value v)) + ( (! value v)) + ( (! value v)))))) + +(df vm-set-slot ((vm ) (o ) (name ) value) + (let* ((o (as (vm-mirror vm o))) + (t (! reference-type o)) + (f (! field-by-name t name))) + (! set-value o f (vm-mirror vm value)))) + +(define-simple-class + () + (f :: ) + ((*init* (f :: )) (set (@ f (this)) f)) + ((uncaughtException (t :: ) (e :: )) + :: + (! println (@s java.lang.System err) (to-str "uhexc:::")) + (! apply2 f t e) + #!void)) + +;;;; Channels + +(df spawn (f) + (let ((thread ( (%%runnable f)))) + (! start thread) + thread)) + + +;; gnu.mapping.RunnableClosure uses the try{...}catch(Throwable){...} +;; idiom which defeats all attempts to use a break-on-error-style +;; debugger. Previously I had my own version of RunnableClosure +;; without that deficiency but something in upstream changed and it no +;; longer worked. Now we use the normal RunnableClosure and at the +;; cost of taking stack snapshots on every throw. +(df %%runnable (f => ) + ;;( f) + ;;( f) + ;;(runnable f) + (%runnable f) + ) + +(df %runnable (f => ) + (runnable + (fun () + (try-catch (f) + (ex + (log "exception in thread ~s: ~s" (current-thread) + ex) + (! printStackTrace ex)))))) + +(df chan () + (let ((lock ()) + (im ()) + (ex ())) + (set (@ lock im) lock) + (set (@ lock ex) lock) + (set (@ peer im) ex) + (set (@ peer ex) im) + (cons im ex))) + +(df immutable? (obj) + (or (== obj #!null) + (symbol? obj) + (number? obj) + (char? obj) + (instance? obj ) + (null? obj))) + +(df send ((c ) value => ) + (df pass (obj) + (cond ((immutable? obj) obj) + ((string? obj) (! to-string obj)) + ((pair? obj) + (let loop ((r (list (pass (car obj)))) + (o (cdr obj))) + (cond ((null? o) (reverse! r)) + ((pair? o) (loop (cons (pass (car o)) r) (cdr o))) + (#t (append (reverse! r) (pass o)))))) + ((instance? obj ) + (let ((o :: obj)) + (assert (== (@ owner o) (current-thread))) + (synchronized (@ lock c) + (set (@ owner o) (@ owner (@ peer c)))) + o)) + ((or (instance? obj ) + (instance? obj )) + ;; those can be shared, for pragmatic reasons + obj + ) + (#t (error "can't send" obj (class-name-sans-package obj))))) + ;;(log "send: ~s ~s -> ~s\n" value (@ owner c) (@ owner (@ peer c))) + (assert (== (@ owner c) (current-thread))) + ;;(log "lock: ~s send\n" (@ owner (@ peer c))) + (synchronized (@ owner (@ peer c)) + (! put (@ queue (@ peer c)) (pass value)) + (! notify (@ owner (@ peer c)))) + ;;(log "unlock: ~s send\n" (@ owner (@ peer c))) + ) + +(df recv ((c )) + (cdr (recv/timeout (list c) 0))) + +(df recv* ((cs )) + (recv/timeout cs 0)) + +(df recv/timeout ((cs ) (timeout )) + (let ((self (current-thread)) + (end (if (zero? timeout) + 0 + (+ (current-time) timeout)))) + ;;(log "lock: ~s recv\n" self) + (synchronized self + (let loop () + ;;(log "receive-loop: ~s\n" self) + (let ((ready (find-if cs + (fun ((c )) + (not (! is-empty (@ queue c)))) + #f))) + (cond (ready + ;;(log "unlock: ~s recv\n" self) + (cons ready (! take (@ queue (as ready))))) + ((zero? timeout) + ;;(log "wait: ~s recv\n" self) + (! wait self) (loop)) + (#t + (let ((now (current-time))) + (cond ((<= end now) + 'timeout) + (#t + ;;(log "wait: ~s recv\n" self) + (! wait self (- end now)) + (loop))))))))))) + +(df rpc ((c ) msg) + (mlet* (((im . ex) (chan)) + ((op . args) msg)) + (send c `(,op ,ex . ,args)) + (recv im))) + +(df spawn/chan (f) + (mlet ((im . ex) (chan)) + (let ((thread ( (%%runnable (fun () (f ex)))))) + (set (@ owner ex) thread) + (! start thread) + (cons im thread)))) + +(df spawn/chan/catch (f) + (spawn/chan + (fun (c) + (try-catch + (f c) + (ex + (send c `(error ,(! toString ex) + ,(class-name-sans-package ex) + ,(map (fun (e) (! to-string e)) + (array-to-list (! get-stack-trace ex)))))))))) + +;;;; Logging + +(define swank-log-port (current-error-port)) +(df log (fstr #!rest args) + (synchronized swank-log-port + (apply format swank-log-port fstr args) + (force-output swank-log-port)) + #!void) + +;;;; Random helpers + +(df 1+ (x) (+ x 1)) +(df 1- (x) (- x 1)) + +(df len (x => ) + (typecase x + ( (length x)) + ( (! length x)) + ( (string-length x)) + ( (vector-length x)) + ( (! size x)) + ( (@ length x)))) + +;;(df put (tab key value) (hash-table-set! tab key value) tab) +;;(df get (tab key default) (hash-table-ref/default tab key default)) +;;(df del (tab key) (hash-table-delete! tab key) tab) +;;(df tab () (make-hash-table)) + +(df put (tab key value) (hashtable-set! tab key value) tab) +(df get (tab key default) (hashtable-ref tab key default)) +(df del (tab key) (hashtable-delete! tab key) tab) +(df tab () (make-eqv-hashtable)) + +(df equal (x y => ) (equal? x y)) + +(df current-thread (=> ) (!s java.lang.Thread currentThread)) +(df current-time (=> ) (!s java.lang.System currentTimeMillis)) + +(df nul? (x) (== x #!null)) + +(df read-from-string (str) + (call-with-input-string str read)) + +;;(df print-to-string (obj) (call-with-output-string (fun (p) (write obj p)))) + +(df pprint-to-string (obj) + (let* ((w ()) + (p ( w #t #f))) + (try-catch (print-object obj p) + (ex + (format p "#" + ex (class-name-sans-package ex)))) + (! flush p) + (to-string (! getBuffer w)))) + +(df print-object (obj stream) + (typecase obj + #; + ((or (eql #!null) (eql #!eof) + ) + (write obj stream)) + (#t + #;(print-unreadable-object obj stream) + (write obj stream) + ))) + +(df print-unreadable-object ((o ) stream) + (let* ((string (! to-string o)) + (class (! get-class o)) + (name (! get-name class)) + (simplename (! get-simple-name class))) + (cond ((! starts-with string "#<") + (format stream "~a" string)) + ((or (! starts-with string name) + (! starts-with string simplename)) + (format stream "#<~a>" string)) + (#t + (format stream "#<~a ~a>" name string))))) + +(define cat string-append) + +(df values-to-list (values) + (typecase values + ( (array-to-list (! getValues values))) + ( (list values)))) + +;; (to-list (as-list (values 1 2 2))) + +(df array-to-list ((array ) => ) + (packing (pack) + (dotimes (i (@ length array)) + (pack (array i))))) + +(df lisp-bool (obj) + (cond ((== obj 'nil) #f) + ((== obj 't) #t) + (#t (error "Can't map lisp boolean" obj)))) + +(df path-sans-extension ((p path) => ) + (let ((ex (! get-extension p)) + (str (! to-string p))) + (to-string (cond ((not ex) str) + (#t (! substring str 0 (- (len str) (len ex) 1))))))) + +(df class-name-sans-package ((obj )) + (cond ((nul? obj) "<#!null>") + (#t + (try-catch + (let* ((c (! get-class obj)) + (n (! get-simple-name c))) + (cond ((equal n "") (! get-name c)) + (#t n))) + (e + (format "#<~a: ~a>" e (! get-message e))))))) + +(df list-env (#!optional (env :: (!s current))) + (let ((enum (! enumerateAllLocations env))) + (packing (pack) + (while (! hasMoreElements enum) + (pack (! nextLocation enum)))))) + +(df list-file (filename) + (with (port (call-with-input-file filename)) + (let* ((lang (!s gnu.expr.Language getDefaultLanguage)) + (messages ()) + (comp (! parse lang (as port) messages 0))) + (! get-module comp)))) + +(df list-decls (file) + (let* ((module (as (list-file file)))) + (do ((decl :: + (! firstDecl module) (! nextDecl decl))) + ((nul? decl)) + (format #t "~a ~a:~d:~d\n" decl + (! getFileName decl) + (! getLineNumber decl) + (! getColumnNumber decl) + )))) + +(df %time (f) + (define-alias ) + (define-alias ) + (let* ((gcs (!s getGarbageCollectorMXBeans)) + (mem (!s getMemoryMXBean)) + (jit (!s getCompilationMXBean)) + (oldjit (! getTotalCompilationTime jit)) + (oldgc (packing (pack) + (iter gcs (fun ((gc )) + (pack (cons gc + (list (! getCollectionCount gc) + (! getCollectionTime gc)))))))) + (heap (!! getUsed getHeapMemoryUsage mem)) + (nonheap (!! getUsed getNonHeapMemoryUsage mem)) + (start (!s java.lang.System nanoTime)) + (values (f)) + (end (!s java.lang.System nanoTime)) + (newheap (!! getUsed getHeapMemoryUsage mem)) + (newnonheap (!! getUsed getNonHeapMemoryUsage mem))) + (format #t "~&") + (let ((njit (! getTotalCompilationTime jit))) + (format #t "; JIT compilation: ~:d ms (~:d)\n" (- njit oldjit) njit)) + (iter gcs (fun ((gc )) + (mlet ((_ count time) (assoc gc oldgc)) + (format #t "; GC ~a: ~:d ms (~d)\n" + (! getName gc) + (- (! getCollectionTime gc) time) + (- (! getCollectionCount gc) count))))) + (format #t "; Heap: ~@:d (~:d)\n" (- newheap heap) newheap) + (format #t "; Non-Heap: ~@:d (~:d)\n" (- newnonheap nonheap) newnonheap) + (format #t "; Elapsed time: ~:d us\n" (/ (- end start) 1000)) + values)) + +(define-syntax time + (syntax-rules () + ((time form) + (%time (lambda () form))))) + +(df gc () + (let* ((mem (!s java.lang.management.ManagementFactory getMemoryMXBean)) + (oheap (!! getUsed getHeapMemoryUsage mem)) + (onheap (!! getUsed getNonHeapMemoryUsage mem)) + (_ (! gc mem)) + (heap (!! getUsed getHeapMemoryUsage mem)) + (nheap (!! getUsed getNonHeapMemoryUsage mem))) + (format #t "; heap: ~@:d (~:d) non-heap: ~@:d (~:d)\n" + (- heap oheap) heap (- onheap nheap) nheap))) + +(df room () + (let* ((pools (!s java.lang.management.ManagementFactory + getMemoryPoolMXBeans)) + (mem (!s java.lang.management.ManagementFactory getMemoryMXBean)) + (heap (!! getUsed getHeapMemoryUsage mem)) + (nheap (!! getUsed getNonHeapMemoryUsage mem))) + (iter pools (fun ((p )) + (format #t "~&; ~a~1,16t: ~10:d\n" + (! getName p) + (!! getUsed getUsage p)))) + (format #t "; Heap~1,16t: ~10:d\n" heap) + (format #t "; Non-Heap~1,16t: ~10:d\n" nheap))) + +;; (df javap (class #!key method signature) +;; (let* (( ) +;; (bytes +;; (typecase class +;; ( (read-bytes ( (to-str class)))) +;; ( class) +;; ( (read-class-file class)))) +;; (cdata ( ( bytes))) +;; (p ( +;; ( bytes) +;; (current-output-port) +;; ()))) +;; (cond (method +;; (dolist ((m ) +;; (array-to-list (! getMethods cdata))) +;; (when (and (equal (to-str method) (! getName m)) +;; (or (not signature) +;; (equal signature (! getInternalSig m)))) +;; (! printMethodSignature p m (! getAccess m)) +;; (! printExceptions p m) +;; (newline) +;; (! printVerboseHeader p m) +;; (! printcodeSequence p m)))) +;; (#t (p:print))) +;; (values))) + +(df read-bytes ((is ) => ) + (let ((os ())) + (let loop () + (let ((c (! read is))) + (cond ((= c -1)) + (#t (! write os c) (loop))))) + (! to-byte-array os))) + +(df read-class-file ((name ) => ) + (let ((f (cat (! replace (to-str name) (as #\.) (as #\/)) + ".class"))) + (mcase (find-file-in-path f (class-path)) + ('#f (ferror "Can't find classfile for ~s" name)) + ((:zip zipfile entry) + (let* ((z ( (as zipfile))) + (e (! getEntry z (as entry)))) + (read-bytes (! getInputStream z e)))) + ((:file s) (read-bytes ( (as s))))))) + +(df all-instances ((vm ) (classname )) + (mappend (fun ((c )) (to-list (! instances c (as long 9999)))) + (%all-subclasses vm classname))) + +(df %all-subclasses ((vm ) (classname )) + (mappend (fun ((c )) (cons c (to-list (! subclasses c)))) + (to-list (! classes-by-name vm classname)))) + +(df with-output-to-string (thunk => ) + (call-with-output-string + (fun (s) (parameterize ((current-output-port s)) (thunk))))) + +(df find-if ((i ) test default) + (let ((iter (! iterator i)) + (found #f)) + (while (and (not found) (! has-next iter)) + (let ((e (! next iter))) + (when (test e) + (set found #t) + (set default e)))) + default)) + +(df filter ((i ) test => ) + (packing (pack) + (for ((e i)) + (when (test e) + (pack e))))) + +(df iter ((i ) f) + (for ((e i)) (f e))) + +(df mapi ((i ) f => ) + (packing (pack) (for ((e i)) (pack (f e))))) + +(df nth ((i ) (n )) + (let ((iter (! iterator i))) + (dotimes (i n) + (! next iter)) + (! next iter))) + +(df 1st ((i )) (!! next iterator i)) + +(df to-list ((i ) => ) + (packing (pack) (for ((e i)) (pack e)))) + +(df as-list ((o ) => ) + (!s java.util.Arrays asList o)) + +(df mappend (f list) + (apply append (map f list))) + +(df subseq (s from to) + (typecase s + ( (apply list (! sub-list s from to))) + ( (apply vector (! sub-list s from to))) + ( (! substring s from to)) + ( (let* ((len (as (- to from))) + (t ( #:length len))) + (!s java.lang.System arraycopy s from t 0 len) + t)))) + +(df to-string (obj => ) + (typecase obj + ( ( obj)) + ((satisfies string?) obj) + ((satisfies symbol?) (symbol->string obj)) + ( ( obj)) + ( ( obj)) + (#t (error "Not a string designator" obj + (class-name-sans-package obj))))) + +(df to-str (obj => ) + (cond ((instance? obj ) obj) + ((string? obj) (! toString obj)) + ((symbol? obj) (! getName (as obj))) + (#t (error "Not a string designator" obj + (class-name-sans-package obj))))) + +)) + +;; Local Variables: +;; mode: goo +;; compile-command: "\ +;; rm -rf classes && \ +;; JAVA_OPTS=-Xss2M kawa --r7rs -d classes -C swank-kawa.scm && \ +;; jar cf swank-kawa.jar -C classes ." +;; End: diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-larceny.scm b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-larceny.scm new file mode 100644 index 0000000..e4d730d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-larceny.scm @@ -0,0 +1,176 @@ +;; swank-larceny.scm --- Swank server for Larceny +;; +;; License: Public Domain +;; Author: Helmut Eller +;; +;; In a shell execute: +;; larceny -r6rs -program swank-larceny.scm +;; and then `M-x slime-connect' in Emacs. + +(library (swank os) + (export getpid make-server-socket accept local-port close-socket) + (import (rnrs) + (primitives foreign-procedure + ffi/handle->address + ffi/string->asciiz + sizeof:pointer + sizeof:int + %set-pointer + %get-int)) + + (define getpid (foreign-procedure "getpid" '() 'int)) + (define fork (foreign-procedure "fork" '() 'int)) + (define close (foreign-procedure "close" '(int) 'int)) + (define dup2 (foreign-procedure "dup2" '(int int) 'int)) + + (define bytevector-content-offset$ sizeof:pointer) + + (define execvp% (foreign-procedure "execvp" '(string boxed) 'int)) + (define (execvp file . args) + (let* ((nargs (length args)) + (argv (make-bytevector (* (+ nargs 1) + sizeof:pointer)))) + (do ((offset 0 (+ offset sizeof:pointer)) + (as args (cdr as))) + ((null? as)) + (%set-pointer argv + offset + (+ (ffi/handle->address (ffi/string->asciiz (car as))) + bytevector-content-offset$))) + (%set-pointer argv (* nargs sizeof:pointer) 0) + (execvp% file argv))) + + (define pipe% (foreign-procedure "pipe" '(boxed) 'int)) + (define (pipe) + (let ((array (make-bytevector (* sizeof:int 2)))) + (let ((r (pipe% array))) + (values r (%get-int array 0) (%get-int array sizeof:int))))) + + (define (fork/exec file . args) + (let ((pid (fork))) + (cond ((= pid 0) + (apply execvp file args)) + (#t pid)))) + + (define (start-process file . args) + (let-values (((r1 down-out down-in) (pipe)) + ((r2 up-out up-in) (pipe)) + ((r3 err-out err-in) (pipe))) + (assert (= 0 r1)) + (assert (= 0 r2)) + (assert (= 0 r3)) + (let ((pid (fork))) + (case pid + ((-1) + (error "Failed to fork a subprocess.")) + ((0) + (close up-out) + (close err-out) + (close down-in) + (dup2 down-out 0) + (dup2 up-in 1) + (dup2 err-in 2) + (apply execvp file args) + (exit 1)) + (else + (close down-out) + (close up-in) + (close err-in) + (list pid + (make-fd-io-stream up-out down-in) + (make-fd-io-stream err-out err-out))))))) + + (define (make-fd-io-stream in out) + (let ((write (lambda (bv start count) (fd-write out bv start count))) + (read (lambda (bv start count) (fd-read in bv start count))) + (closeit (lambda () (close in) (close out)))) + (make-custom-binary-input/output-port + "fd-stream" read write #f #f closeit))) + + (define write% (foreign-procedure "write" '(int ulong int) 'int)) + (define (fd-write fd bytevector start count) + (write% fd + (+ (ffi/handle->address bytevector) + bytevector-content-offset$ + start) + count)) + + (define read% (foreign-procedure "read" '(int ulong int) 'int)) + (define (fd-read fd bytevector start count) + ;;(printf "fd-read: ~a ~s ~a ~a\n" fd bytevector start count) + (read% fd + (+ (ffi/handle->address bytevector) + bytevector-content-offset$ + start) + count)) + + (define (make-server-socket port) + (let* ((args `("/bin/bash" "bash" + "-c" + ,(string-append + "netcat -s 127.0.0.1 -q 0 -l -v " + (if port + (string-append "-p " (number->string port)) + "")))) + (nc (apply start-process args)) + (err (transcoded-port (list-ref nc 2) + (make-transcoder (latin-1-codec)))) + (line (get-line err)) + (pos (last-index-of line '#\]))) + (cond (pos + (let* ((tail (substring line (+ pos 1) (string-length line))) + (port (get-datum (open-string-input-port tail)))) + (list (car nc) (cadr nc) err port))) + (#t (error "netcat failed: " line))))) + + (define (accept socket codec) + (let* ((line (get-line (caddr socket))) + (pos (last-index-of line #\]))) + (cond (pos + (close-port (caddr socket)) + (let ((stream (cadr socket))) + (let ((io (transcoded-port stream (make-transcoder codec)))) + (values io io)))) + (else (error "accept failed: " line))))) + + (define (local-port socket) + (list-ref socket 3)) + + (define (last-index-of str chr) + (let loop ((i (string-length str))) + (cond ((<= i 0) #f) + (#t (let ((i (- i 1))) + (cond ((char=? (string-ref str i) chr) + i) + (#t + (loop i)))))))) + + (define (close-socket socket) + ;;(close-port (cadr socket)) + #f + ) + + ) + +(library (swank sys) + (export implementation-name eval-in-interaction-environment) + (import (rnrs) + (primitives system-features + aeryn-evaluator)) + + (define (implementation-name) "larceny") + + ;; see $LARCENY/r6rsmode.sch: + ;; Larceny's ERR5RS and R6RS modes. + ;; Code names: + ;; Aeryn ERR5RS + ;; D'Argo R6RS-compatible + ;; Spanky R6RS-conforming (not yet implemented) + (define (eval-in-interaction-environment form) + (aeryn-evaluator form)) + + ) + +(import (rnrs) (rnrs eval) (larceny load)) +(load "swank-r6rs.scm") +(eval '(start-server #f) (environment '(swank))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-listener-hooks.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-listener-hooks.lisp new file mode 100644 index 0000000..f289c90 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-listener-hooks.lisp @@ -0,0 +1,91 @@ +;;; swank-listener-hooks.lisp --- listener with special hooks +;; +;; Author: Alan Ruttenberg + +;; Provides *slime-repl-eval-hooks* special variable which +;; can be used for easy interception of SLIME REPL form evaluation +;; for purposes such as integration with application event loop. + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-repl)) + +(defvar *slime-repl-advance-history* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from advancing the history - * ** *** etc.") + +(defvar *slime-repl-suppress-output* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from printing the result of the evalation.") + +(defvar *slime-repl-eval-hook-pass* (gensym "PASS") + "Token to indicate that a repl hook declines to evaluate the form") + +(defvar *slime-repl-eval-hooks* nil + "A list of functions. When the repl is about to eval a form, first try running each of + these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass* + is considered a replacement for calling eval. If there are no hooks, or all + pass, then eval is used.") + +(export '*slime-repl-eval-hooks*) + +(defslimefun repl-eval-hook-pass () + "call when repl hook declines to evaluate the form" + (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*)) + +(defslimefun repl-suppress-output () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from printing the result of the evalation." + (setq *slime-repl-suppress-output* t)) + +(defslimefun repl-suppress-advance-history () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from advancing the history - * ** *** etc." + (setq *slime-repl-advance-history* nil)) + +(defun %eval-region (string) + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (fresh-line) + (finish-output) + (return (values values -))) + (setq - form) + (if *slime-repl-eval-hooks* + (setq values (run-repl-eval-hooks form)) + (setq values (multiple-value-list (eval form)))) + (finish-output)))))) + +(defun run-repl-eval-hooks (form) + (loop for hook in *slime-repl-eval-hooks* + for res = (catch *slime-repl-eval-hook-pass* + (multiple-value-list (funcall hook form))) + until (not (eq res *slime-repl-eval-hook-pass*)) + finally (return + (if (eq res *slime-repl-eval-hook-pass*) + (multiple-value-list (eval form)) + res)))) + +(defun %listener-eval (string) + (clear-user-input) + (with-buffer-syntax () + (swank-repl::track-package + (lambda () + (let ((*slime-repl-suppress-output* :unset) + (*slime-repl-advance-history* :unset)) + (multiple-value-bind (values last-form) (%eval-region string) + (unless (or (and (eq values nil) (eq last-form nil)) + (eq *slime-repl-advance-history* nil)) + (setq *** ** ** * * (car values) + /// // // / / values)) + (setq +++ ++ ++ + + last-form) + (unless (eq *slime-repl-suppress-output* t) + (funcall swank-repl::*send-repl-results-function* values))))))) + nil) + +(setq swank-repl::*listener-eval-function* '%listener-eval) + +(provide :swank-listener-hooks) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-macrostep.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-macrostep.lisp new file mode 100644 index 0000000..7595e36 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-macrostep.lisp @@ -0,0 +1,227 @@ +;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el +;; +;; Authors: Luis Oliveira +;; Jon Oddie +;; +;; License: Public Domain + +(defpackage swank-macrostep + (:use cl swank) + (:import-from swank + #:*macroexpand-printer-bindings* + #:with-buffer-syntax + #:with-bindings + #:to-string + #:macroexpand-all + #:compiler-macroexpand-1 + #:defslimefun + #:collect-macro-forms) + (:export #:macrostep-expand-1 + #:macro-form-p)) + +(in-package #:swank-macrostep) + +(defslimefun macrostep-expand-1 (string compiler-macros? context) + (with-buffer-syntax () + (let ((form (read-from-string string))) + (multiple-value-bind (expansion error-message) + (expand-form-once form compiler-macros? context) + (if error-message + `(:error ,error-message) + (multiple-value-bind (macros compiler-macros) + (collect-macro-forms-in-context expansion context) + (let* ((all-macros (append macros compiler-macros)) + (pretty-expansion (pprint-to-string expansion)) + (positions (collect-form-positions expansion + pretty-expansion + all-macros)) + (subform-info + (loop + for form in all-macros + for (start end) in positions + when (and start end) + collect (let ((op-name (to-string (first form))) + (op-type + (if (member form macros) + :macro + :compiler-macro))) + (list op-name + op-type + start))))) + `(:ok ,pretty-expansion ,subform-info)))))))) + +(defun expand-form-once (form compiler-macros? context) + (multiple-value-bind (expansion expanded?) + (macroexpand-1-in-context form context) + (if expanded? + (values expansion nil) + (if (not compiler-macros?) + (values nil "Not a macro form") + (multiple-value-bind (expansion expanded?) + (compiler-macroexpand-1 form) + (if expanded? + (values expansion nil) + (values nil "Not a macro or compiler-macro form"))))))) + +(defslimefun macro-form-p (string compiler-macros? context) + (with-buffer-syntax () + (let ((form + (handler-case + (read-from-string string) + (error (condition) + (unless (debug-on-swank-error) + (return-from macro-form-p + `(:error ,(format nil "Read error: ~A" condition)))))))) + `(:ok ,(macro-form-type form compiler-macros? context))))) + +(defun macro-form-type (form compiler-macros? context) + (cond + ((or (not (consp form)) + (not (symbolp (car form)))) + nil) + ((multiple-value-bind (expansion expanded?) + (macroexpand-1-in-context form context) + (declare (ignore expansion)) + expanded?) + :macro) + ((and compiler-macros? + (multiple-value-bind (expansion expanded?) + (compiler-macroexpand-1 form) + (declare (ignore expansion)) + expanded?)) + :compiler-macro) + (t + nil))) + + +;;;; Hacks to support macro-expansion within local context + +(defparameter *macrostep-tag* (gensym)) + +(defparameter *macrostep-placeholder* '*macrostep-placeholder*) + +(define-condition expansion-in-context-failed (simple-error) + ()) + +(defmacro throw-expansion (form &environment env) + (throw *macrostep-tag* (macroexpand-1 form env))) + +(defmacro throw-collected-macro-forms (form &environment env) + (throw *macrostep-tag* (collect-macro-forms form env))) + +(defun macroexpand-1-in-context (form context) + (handler-case + (macroexpand-and-catch + `(throw-expansion ,form) context) + (error () + (macroexpand-1 form)))) + +(defun collect-macro-forms-in-context (form context) + (handler-case + (macroexpand-and-catch + `(throw-collected-macro-forms ,form) context) + (error () + (collect-macro-forms form)))) + +(defun macroexpand-and-catch (form context) + (catch *macrostep-tag* + (macroexpand-all (enclose-form-in-context form context)) + (error 'expansion-in-context-failed))) + +(defun enclose-form-in-context (form context) + (with-buffer-syntax () + (destructuring-bind (prefix suffix) context + (let* ((placeholder-form + (read-from-string + (concatenate + 'string + prefix (prin1-to-string *macrostep-placeholder*) suffix))) + (substituted-form (subst form *macrostep-placeholder* + placeholder-form))) + (if (not (equal placeholder-form substituted-form)) + substituted-form + (error 'expansion-in-context-failed)))))) + + +;;;; Tracking Pretty Printer + +(defun marker-char-p (char) + (<= #xe000 (char-code char) #xe8ff)) + +(defun make-marker-char (id) + ;; using the private-use characters U+E000..U+F8FF as markers, so + ;; that's our upper limit for how many we can use. + (assert (<= 0 id #x8ff)) + (code-char (+ #xe000 id))) + +(defun marker-char-id (char) + (assert (marker-char-p char)) + (- (char-code char) #xe000)) + +(defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32))) + +(defun whitespacep (char) + (member char +whitespace+)) + +(defun pprint-to-string (object &optional pprint-dispatch) + (let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*))) + (with-bindings *macroexpand-printer-bindings* + (to-string object)))) + +#-clisp +(defun collect-form-positions (expansion printed-expansion forms) + (loop for (start end) + in (collect-marker-positions + (pprint-to-string expansion (make-tracking-pprint-dispatch forms)) + (length forms)) + collect (when (and start end) + (list (find-non-whitespace-position printed-expansion start) + (find-non-whitespace-position printed-expansion end))))) + +;; The pprint-dispatch table constructed by +;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack +;; overflow under CLISP version 2.49. Make the COLLECT-FORM-POSITIONS +;; entry point a no-op in thi case, so that basic macro-expansion will +;; still work (without detection of inner macro forms) +#+clisp +(defun collect-form-positions (expansion printed-expansion forms) + nil) + +(defun make-tracking-pprint-dispatch (forms) + (let ((original-table *print-pprint-dispatch*) + (table (copy-pprint-dispatch))) + (flet ((maybe-write-marker (position stream) + (when position + (write-char (make-marker-char position) stream)))) + (set-pprint-dispatch 'cons + (lambda (stream cons) + (let ((pos (position cons forms))) + (maybe-write-marker pos stream) + ;; delegate printing to the original table. + (funcall (pprint-dispatch cons original-table) + stream + cons) + (maybe-write-marker pos stream))) + most-positive-fixnum + table)) + table)) + +(defun collect-marker-positions (string position-count) + (let ((positions (make-array position-count :initial-element nil))) + (loop with p = 0 + for char across string + unless (whitespacep char) + do (if (marker-char-p char) + (push p (aref positions (marker-char-id char))) + (incf p))) + (map 'list #'reverse positions))) + +(defun find-non-whitespace-position (string position) + (loop with non-whitespace-position = -1 + for i from 0 and char across string + unless (whitespacep char) + do (incf non-whitespace-position) + until (eql non-whitespace-position position) + finally (return i))) + +(provide :swank-macrostep) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-media.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-media.lisp new file mode 100644 index 0000000..3d5ef7c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-media.lisp @@ -0,0 +1,25 @@ +;;; swank-media.lisp --- insert other media (images) +;; +;; Authors: Christophe Rhodes +;; +;; Licence: GPLv2 or later +;; + +(in-package :swank) + +;; this file is empty of functionality. The slime-media contrib +;; allows swank to return messages other than :write-string as repl +;; results; this is used in the R implementation of swank to display R +;; objects with graphical representations (such as trellis objects) as +;; image presentations in the swank repl. In R, this is done by +;; having a hook function for the preparation of the repl results, in +;; addition to the already-existing hook for sending the repl results +;; (*send-repl-results-function*, used by swank-presentations.lisp). +;; The swank-media.R contrib implementation defines a generic function +;; for use as this hook, along with methods for commonly-encountered +;; graphical R objects. (This strategy is harder in CL, where methods +;; can only be defined if their specializers already exist; in R's S3 +;; object system, methods are ordinary functions with a special naming +;; convention) + +(provide :swank-media) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mit-scheme.scm b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mit-scheme.scm new file mode 100644 index 0000000..e7729ff --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mit-scheme.scm @@ -0,0 +1,870 @@ +;;; swank-mit-scheme.scm --- SLIME server for MIT Scheme +;; +;; Copyright (C) 2008 Helmut Eller +;; +;; This file is licensed under the terms of the GNU General Public +;; License as distributed with Emacs (press C-h C-c for details). + +;;;; Installation: +#| + +1. You need MIT Scheme 9.2 + +2. The Emacs side needs some fiddling. I have the following in + my .emacs: + +(setq slime-lisp-implementations + '((mit-scheme ("mit-scheme") :init mit-scheme-init))) + +(defun mit-scheme-init (file encoding) + (format "%S\n\n" + `(begin + (load-option 'format) + (load-option 'sos) + (eval + '(create-package-from-description + (make-package-description '(swank) (list (list)) + (vector) (vector) (vector) false)) + (->environment '(package))) + (load ,(expand-file-name + ".../contrib/swank-mit-scheme.scm" ; <-- insert your path + slime-path) + (->environment '(swank))) + (eval '(start-swank ,file) (->environment '(swank)))))) + +(defun mit-scheme () + (interactive) + (slime 'mit-scheme)) + +(defun find-mit-scheme-package () + (save-excursion + (let ((case-fold-search t)) + (and (re-search-backward "^[;]+ package: \\((.+)\\).*$" nil t) + (match-string-no-properties 1))))) + +(setq slime-find-buffer-package-function 'find-mit-scheme-package) +(add-hook 'scheme-mode-hook (lambda () (slime-mode 1))) + + The `mit-scheme-init' function first loads the SOS and FORMAT + libraries, then creates a package "(swank)", and loads this file + into that package. Finally it starts the server. + + `find-mit-scheme-package' tries to figure out which package the + buffer belongs to, assuming that ";;; package: (FOO)" appears + somewhere in the file. Luckily, this assumption is true for many of + MIT Scheme's own files. Alternatively, you could add Emacs style + -*- slime-buffer-package: "(FOO)" -*- file variables. + +4. Start everything with `M-x mit-scheme'. + +|# + +;;; package: (swank) + +(if (< (car (get-subsystem-version "Release")) + '9) + (error "This file requires MIT Scheme Release 9")) + +(define (swank port) + (accept-connections (or port 4005) #f)) + +;; ### hardcoded port number for now. netcat-openbsd doesn't print +;; the listener port anymore. +(define (start-swank port-file) + (accept-connections 4055 port-file) + ) + +;;;; Networking + +(define (accept-connections port port-file) + (let ((sock (open-tcp-server-socket port (host-address-loopback)))) + (format #t "Listening on port: ~s~%" port) + (if port-file (write-port-file port port-file)) + (dynamic-wind + (lambda () #f) + (lambda () (serve (tcp-server-connection-accept sock #t #f))) + (lambda () (close-tcp-server-socket sock))))) + +(define (write-port-file portnumber filename) + (call-with-output-file filename (lambda (p) (write portnumber p)))) + +(define *top-level-restart* #f) +(define (serve socket) + (with-simple-restart + 'disconnect "Close connection." + (lambda () + (with-keyboard-interrupt-handler + (lambda () (main-loop socket)))))) + +(define (disconnect) + (format #t "Disconnecting ...~%") + (invoke-restart (find-restart 'disconnect))) + +(define (main-loop socket) + (do () (#f) + (with-simple-restart + 'abort "Return to SLIME top-level." + (lambda () + (fluid-let ((*top-level-restart* (find-restart 'abort))) + (dispatch (read-packet socket) socket 0)))))) + +(define (with-keyboard-interrupt-handler fun) + (define (set-^G-handler exp) + (eval `(vector-set! keyboard-interrupt-vector (char->ascii #\G) ,exp) + (->environment '(runtime interrupt-handler)))) + (dynamic-wind + (lambda () #f) + (lambda () + (set-^G-handler + `(lambda (char) (with-simple-restart + 'continue "Continue from interrupt." + (lambda () (error "Keyboard Interrupt."))))) + (fun)) + (lambda () + (set-^G-handler '^G-interrupt-handler)))) + + +;;;; Reading/Writing of SLIME packets + +(define (read-packet in) + "Read an S-expression from STREAM using the SLIME protocol." + (let* ((len (read-length in)) + (buffer (make-string len))) + (fill-buffer! in buffer) + (read-from-string buffer))) + +(define (write-packet message out) + (let* ((string (write-to-string message))) + (log-event "WRITE: [~a]~s~%" (string-length string) string) + (write-length (string-length string) out) + (write-string string out) + (flush-output out))) + +(define (fill-buffer! in buffer) + (read-string! buffer in)) + +(define (read-length in) + (if (eof-object? (peek-char in)) (disconnect)) + (do ((len 6 (1- len)) + (sum 0 (+ (* sum 16) (char->hex-digit (read-char in))))) + ((zero? len) sum))) + +(define (ldb size position integer) + "LoaD a Byte of SIZE bits at bit position POSITION from INTEGER." + (fix:and (fix:lsh integer (- position)) + (1- (fix:lsh 1 size)))) + +(define (write-length len out) + (do ((pos 20 (- pos 4))) + ((< pos 0)) + (write-hex-digit (ldb 4 pos len) out))) + +(define (write-hex-digit n out) + (write-char (hex-digit->char n) out)) + +(define (hex-digit->char n) + (digit->char n 16)) + +(define (char->hex-digit c) + (char->digit c 16)) + + +;;;; Event dispatching + +(define (dispatch request socket level) + (log-event "READ: ~s~%" request) + (case (car request) + ((:emacs-rex) (apply emacs-rex socket level (cdr request))))) + +(define (swank-package) + (or (name->package '(swank)) + (name->package '(user)))) + +(define *buffer-package* #f) +(define (find-buffer-package name) + (if (elisp-false? name) + #f + (let ((v (ignore-errors + (lambda () (name->package (read-from-string name)))))) + (and (package? v) v)))) + +(define swank-env (->environment (swank-package))) +(define (user-env buffer-package) + (cond ((string? buffer-package) + (let ((p (find-buffer-package buffer-package))) + (if (not p) (error "Invalid package name: " buffer-package)) + (package/environment p))) + (else (nearest-repl/environment)))) + +;; quote keywords +(define (hack-quotes list) + (map (lambda (x) + (cond ((symbol? x) `(quote ,x)) + (#t x))) + list)) + +(define (emacs-rex socket level sexp package thread id) + (let ((ok? #f) (result #f) (condition #f)) + (dynamic-wind + (lambda () #f) + (lambda () + (bind-condition-handler + (list condition-type:serious-condition) + (lambda (c) (set! condition c) (invoke-sldb socket (1+ level) c)) + (lambda () + (fluid-let ((*buffer-package* package)) + (set! result + (eval (cons* (car sexp) socket (hack-quotes (cdr sexp))) + swank-env)) + (set! ok? #t))))) + (lambda () + (write-packet `(:return + ,(if ok? `(:ok ,result) + `(:abort + ,(if condition + (format #f "~a" + (condition/type condition)) + ""))) + ,id) + socket))))) + +(define (swank:connection-info _) + (let ((p (environment->package (user-env #f)))) + `(:pid ,(unix/current-pid) + :package (:name ,(write-to-string (package/name p)) + :prompt ,(write-to-string (package/name p))) + :lisp-implementation + (:type "MIT Scheme" :version ,(get-subsystem-version-string "release")) + :encoding (:coding-systems ("iso-8859-1")) + ))) + +(define (swank:quit-lisp _) + (%exit)) + + +;;;; Evaluation + +(define (swank-repl:listener-eval socket string) + ;;(call-with-values (lambda () (eval-region string socket)) + ;; (lambda values `(:values . ,(map write-to-string values)))) + `(:values ,(write-to-string (eval-region string socket)))) + +(define (eval-region string socket) + (let ((sexp (read-from-string string))) + (if (eof-object? exp) + (values) + (with-output-to-repl socket + (lambda () (eval sexp (user-env *buffer-package*))))))) + +(define (with-output-to-repl socket fun) + (let ((p (make-port repl-port-type socket))) + (dynamic-wind + (lambda () #f) + (lambda () (with-output-to-port p fun)) + (lambda () (flush-output p))))) + +(define (swank:interactive-eval socket string) + ;;(call-with-values (lambda () (eval-region string)) format-for-echo-area) + (format-values (eval-region string socket)) + ) + +(define (format-values . values) + (if (null? values) + "; No value" + (with-string-output-port + (lambda (out) + (write-string "=> " out) + (do ((vs values (cdr vs))) ((null? vs)) + (write (car vs) out) + (if (not (null? (cdr vs))) + (write-string ", " out))))))) + +(define (swank:pprint-eval _ string) + (pprint-to-string (eval (read-from-string string) + (user-env *buffer-package*)))) + +(define (swank:interactive-eval-region socket string) + (format-values (eval-region string socket))) + +(define (swank:set-package _ package) + (set-repl/environment! (nearest-repl) + (->environment (read-from-string package))) + (let* ((p (environment->package (user-env #f))) + (n (write-to-string (package/name p)))) + (list n n))) + + +(define (repl-write-substring port string start end) + (cond ((< start end) + (write-packet `(:write-string ,(substring string start end)) + (port/state port)))) + (- end start)) + +(define (repl-write-char port char) + (write-packet `(:write-string ,(string char)) + (port/state port))) + +(define repl-port-type + (make-port-type `((write-substring ,repl-write-substring) + (write-char ,repl-write-char)) #f)) + +(define (swank-repl:create-repl socket . _) + (let* ((env (user-env #f)) + (name (format #f "~a" (package/name (environment->package env))))) + (list name name))) + + +;;;; Compilation + +(define (swank:compile-string-for-emacs _ string . x) + (apply + (lambda (errors seconds) + `(:compilation-result ,errors t ,seconds nil nil)) + (call-compiler + (lambda () + (let* ((sexps (snarf-string string)) + (env (user-env *buffer-package*)) + (scode (syntax `(begin ,@sexps) env)) + (compiled-expression (compile-scode scode #t))) + (scode-eval compiled-expression env)))))) + +(define (snarf-string string) + (with-input-from-string string + (lambda () + (let loop () + (let ((e (read))) + (if (eof-object? e) '() (cons e (loop)))))))) + +(define (call-compiler fun) + (let ((time #f)) + (with-timings fun + (lambda (run-time gc-time real-time) + (set! time real-time))) + (list 'nil (internal-time/ticks->seconds time)))) + +(define (swank:compiler-notes-for-emacs _) nil) + +(define (swank:compile-file-for-emacs socket file load?) + (apply + (lambda (errors seconds) + (list ':compilation-result errors 't seconds load? + (->namestring (pathname-name file)))) + (call-compiler + (lambda () (with-output-to-repl socket (lambda () (compile-file file))))))) + +(define (swank:load-file socket file) + (with-output-to-repl socket + (lambda () + (pprint-to-string + (load file (user-env *buffer-package*)))))) + +(define (swank:disassemble-form _ string) + (let ((sexp (let ((sexp (read-from-string string))) + (cond ((and (pair? sexp) (eq? (car sexp) 'quote)) + (cadr sexp)) + (#t sexp))))) + (with-output-to-string + (lambda () + (compiler:disassemble + (eval sexp (user-env *buffer-package*))))))) + +(define (swank:disassemble-symbol _ string) + (with-output-to-string + (lambda () + (compiler:disassemble + (eval (read-from-string string) + (user-env *buffer-package*)))))) + + +;;;; Macroexpansion + +(define (swank:swank-macroexpand-all _ string) + (with-output-to-string + (lambda () + (pp (syntax (read-from-string string) + (user-env *buffer-package*)))))) +(define swank:swank-macroexpand-1 swank:swank-macroexpand-all) +(define swank:swank-macroexpand swank:swank-macroexpand-all) + + +;;; Arglist + +(define (swank:operator-arglist socket name pack) + (let ((v (ignore-errors + (lambda () + (string-trim-right + (with-output-to-string + (lambda () + (carefully-pa + (eval (read-from-string name) (user-env pack)))))))))) + (if (condition? v) 'nil v))) + +(define (carefully-pa o) + (cond ((arity-dispatched-procedure? o) + ;; MIT Scheme crashes for (pa /) + (display "arity-dispatched-procedure")) + ((procedure? o) (pa o)) + (else (error "Not a procedure")))) + + +;;; Some unimplemented stuff. +(define (swank:buffer-first-change . _) nil) +(define (swank:filename-to-modulename . _) nil) +(define (swank:swank-require . _) nil) + +;; M-. is beyond my capabilities. +(define (swank:find-definitions-for-emacs . _) nil) + + +;;; Debugger + +(define-structure (sldb-state (conc-name sldb-state.)) condition restarts) + +(define *sldb-state* #f) +(define (invoke-sldb socket level condition) + (fluid-let ((*sldb-state* (make-sldb-state condition (bound-restarts)))) + (dynamic-wind + (lambda () #f) + (lambda () + (write-packet `(:debug 0 ,level ,@(sldb-info *sldb-state* 0 20)) + socket) + (sldb-loop level socket)) + (lambda () + (write-packet `(:debug-return 0 ,level nil) socket))))) + +(define (sldb-loop level socket) + (write-packet `(:debug-activate 0 ,level) socket) + (with-simple-restart + 'abort (format #f "Return to SLDB level ~a." level) + (lambda () (dispatch (read-packet socket) socket level))) + (sldb-loop level socket)) + +(define (sldb-info state start end) + (let ((c (sldb-state.condition state)) + (rs (sldb-state.restarts state))) + (list (list (condition/report-string c) + (format #f " [~a]" (%condition-type/name (condition/type c))) + nil) + (sldb-restarts rs) + (sldb-backtrace c start end) + ;;'((0 "dummy frame")) + '()))) + +(define %condition-type/name + (eval '%condition-type/name (->environment '(runtime error-handler)))) + +(define (sldb-restarts restarts) + (map (lambda (r) + (list (symbol->string (restart/name r)) + (with-string-output-port + (lambda (p) (write-restart-report r p))))) + restarts)) + +(define (swank:throw-to-toplevel . _) + (invoke-restart *top-level-restart*)) + +(define (swank:sldb-abort . _) + (abort (sldb-state.restarts *sldb-state*))) + +(define (swank:sldb-continue . _) + (continue (sldb-state.restarts *sldb-state*))) + +(define (swank:invoke-nth-restart-for-emacs _ _sldb-level n) + (invoke-restart (list-ref (sldb-state.restarts *sldb-state*) n))) + +(define (swank:debugger-info-for-emacs _ from to) + (sldb-info *sldb-state* from to)) + +(define (swank:backtrace _ from to) + (sldb-backtrace (sldb-state.condition *sldb-state*) from to)) + +(define (sldb-backtrace condition from to) + (sldb-backtrace-aux (condition/continuation condition) from to)) + +(define (sldb-backtrace-aux k from to) + (let ((l (map frame>string (substream (continuation>frames k) from to)))) + (let loop ((i from) (l l)) + (if (null? l) + '() + (cons (list i (car l)) (loop (1+ i) (cdr l))))))) + +;; Stack parser fails for this: +;; (map (lambda (x) x) "/tmp/x.x") + +(define (continuation>frames k) + (let loop ((frame (continuation->stack-frame k))) + (cond ((not frame) (stream)) + (else + (let ((next (ignore-errors + (lambda () (stack-frame/next-subproblem frame))))) + (cons-stream frame + (if (condition? next) + (stream next) + (loop next)))))))) + +(define (frame>string frame) + (if (condition? frame) + (format #f "Bogus frame: ~a ~a" frame + (condition/report-string frame)) + (with-string-output-port (lambda (p) (print-frame frame p))))) + +(define (print-frame frame port) + (define (invalid-subexpression? subexpression) + (or (debugging-info/undefined-expression? subexpression) + (debugging-info/unknown-expression? subexpression))) + (define (invalid-expression? expression) + (or (debugging-info/undefined-expression? expression) + (debugging-info/compiled-code? expression))) + (with-values (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment subexpression) + (cond ((debugging-info/compiled-code? expression) + (write-string ";unknown compiled code" port)) + ((not (debugging-info/undefined-expression? expression)) + (fluid-let ((*unparse-primitives-by-name?* #t)) + (write + (unsyntax (if (invalid-subexpression? subexpression) + expression + subexpression)) + port))) + ((debugging-info/noise? expression) + (write-string ";" port) + (write-string ((debugging-info/noise expression) #f) + port)) + (else + (write-string ";undefined expression" port)))))) + +(define (substream s from to) + (let loop ((i 0) (l '()) (s s)) + (cond ((or (= i to) (stream-null? s)) (reverse l)) + ((< i from) (loop (1+ i) l (stream-cdr s))) + (else (loop (1+ i) (cons (stream-car s) l) (stream-cdr s)))))) + +(define (swank:frame-locals-and-catch-tags _ frame) + (list (map frame-var>elisp (frame-vars (sldb-get-frame frame))) + '())) + +(define (frame-vars frame) + (with-values (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment subexpression) + (cond ((environment? environment) + (environment>frame-vars environment)) + (else '()))))) + +(define (environment>frame-vars environment) + (let loop ((e environment)) + (cond ((environment->package e) '()) + (else (append (environment-bindings e) + (if (environment-has-parent? e) + (loop (environment-parent e)) + '())))))) + +(define (frame-var>elisp b) + (list ':name (write-to-string (car b)) + ':value (cond ((null? (cdr b)) "{unavailable}") + (else (>line (cadr b)))) + ':id 0)) + +(define (sldb-get-frame index) + (stream-ref (continuation>frames + (condition/continuation + (sldb-state.condition *sldb-state*))) + index)) + +(define (frame-var-value frame var) + (let ((binding (list-ref (frame-vars frame) var))) + (cond ((cdr binding) (cadr binding)) + (else unspecific)))) + +(define (swank:inspect-frame-var _ frame var) + (reset-inspector) + (inspect-object (frame-var-value (sldb-get-frame frame) var))) + + +;;;; Completion + +(define (swank:simple-completions _ string package) + (let ((strings (all-completions string (user-env package) string-prefix?))) + (list (sort strings stringstring (environment-names env)))) + (keep-matching-items ss (lambda (s) (match? pattern s))))) + +;; symbol->string is too slow +(define %symbol->string symbol-name) + +(define (environment-names env) + (append (environment-bound-names env) + (if (environment-has-parent? env) + (environment-names (environment-parent env)) + '()))) + +(define (longest-common-prefix strings) + (define (common-prefix s1 s2) + (substring s1 0 (string-match-forward s1 s2))) + (reduce common-prefix "" strings)) + + +;;;; Apropos + +(define (swank:apropos-list-for-emacs _ name #!optional + external-only case-sensitive package) + (let* ((pkg (and (string? package) + (find-package (read-from-string package)))) + (parent (and (not (default-object? external-only)) + (elisp-false? external-only))) + (ss (append-map (lambda (p) + (map (lambda (s) (cons p s)) + (apropos-list name p (and pkg parent)))) + (if pkg (list pkg) (all-packages)))) + (ss (sublist ss 0 (min (length ss) 200)))) + (map (lambda (e) + (let ((p (car e)) (s (cdr e))) + (list ':designator (format #f "~a ~a" s (package/name p)) + ':variable (>line + (ignore-errors + (lambda () (package-lookup p s))))))) + ss))) + +(define (swank:list-all-package-names . _) + (map (lambda (p) (write-to-string (package/name p))) + (all-packages))) + +(define (all-packages) + (define (package-and-children package) + (append (list package) + (append-map package-and-children (package/children package)))) + (package-and-children system-global-package)) + + +;;;; Inspector + +(define-structure (inspector-state (conc-name istate.)) + object parts next previous content) + +(define istate #f) + +(define (reset-inspector) + (set! istate #f)) + +(define (swank:init-inspector _ string) + (reset-inspector) + (inspect-object (eval (read-from-string string) + (user-env *buffer-package*)))) + +(define (inspect-object o) + (let ((previous istate) + (content (inspect o)) + (parts (make-eqv-hash-table))) + (set! istate (make-inspector-state o parts #f previous content)) + (if previous (set-istate.next! previous istate)) + (istate>elisp istate))) + +(define (istate>elisp istate) + (list ':title (>line (istate.object istate)) + ':id (assign-index (istate.object istate) (istate.parts istate)) + ':content (prepare-range (istate.parts istate) + (istate.content istate) + 0 500))) + +(define (assign-index o parts) + (let ((i (hash-table/count parts))) + (hash-table/put! parts i o) + i)) + +(define (prepare-range parts content from to) + (let* ((cs (substream content from to)) + (ps (prepare-parts cs parts))) + (list ps + (if (< (length cs) (- to from)) + (+ from (length cs)) + (+ to 1000)) + from to))) + +(define (prepare-parts ps parts) + (define (line label value) + `(,(format #f "~a: " label) + (:value ,(>line value) ,(assign-index value parts)) + "\n")) + (append-map (lambda (p) + (cond ((string? p) (list p)) + ((symbol? p) (list (symbol->string p))) + (#t + (case (car p) + ((line) (apply line (cdr p))) + (else (error "Invalid part:" p)))))) + ps)) + +(define (swank:inspect-nth-part _ index) + (inspect-object (hash-table/get (istate.parts istate) index 'no-such-part))) + +(define (swank:quit-inspector _) + (reset-inspector)) + +(define (swank:inspector-pop _) + (cond ((istate.previous istate) + (set! istate (istate.previous istate)) + (istate>elisp istate)) + (else 'nil))) + +(define (swank:inspector-next _) + (cond ((istate.next istate) + (set! istate (istate.next istate)) + (istate>elisp istate)) + (else 'nil))) + +(define (swank:inspector-range _ from to) + (prepare-range (istate.parts istate) + (istate.content istate) + from to)) + +(define-syntax stream* + (syntax-rules () + ((stream* tail) tail) + ((stream* e1 e2 ...) (cons-stream e1 (stream* e2 ...))))) + +(define (iline label value) `(line ,label ,value)) + +(define-generic inspect (o)) + +(define-method inspect ((o )) + (cond ((environment? o) (inspect-environment o)) + ((vector? o) (inspect-vector o)) + ((procedure? o) (inspect-procedure o)) + ((compiled-code-block? o) (inspect-code-block o)) + ;;((system-pair? o) (inspect-system-pair o)) + ((probably-scode? o) (inspect-scode o)) + (else (inspect-fallback o)))) + +(define (inspect-fallback o) + (let* ((class (object-class o)) + (slots (class-slots class))) + (stream* + (iline "Class" class) + (let loop ((slots slots)) + (cond ((null? slots) (stream)) + (else + (let ((n (slot-name (car slots)))) + (stream* (iline n (slot-value o n)) + (loop (cdr slots)))))))))) + +(define-method inspect ((o )) + (if (or (pair? (cdr o)) (null? (cdr o))) + (inspect-list o) + (inspect-cons o))) + +(define (inspect-cons o) + (stream (iline "car" (car o)) + (iline "cdr" (cdr o)))) + +(define (inspect-list o) + (let loop ((i 0) (o o)) + (cond ((null? o) (stream)) + ((or (pair? (cdr o)) (null? (cdr o))) + (stream* (iline i (car o)) + (loop (1+ i) (cdr o)))) + (else + (stream (iline i (car o)) + (iline "tail" (cdr o))))))) + +(define (inspect-environment o) + (stream* + (iline "(package)" (environment->package o)) + (let loop ((bs (environment-bindings o))) + (cond ((null? bs) + (if (environment-has-parent? o) + (stream (iline "()" (environment-parent o))) + (stream))) + (else + (let* ((b (car bs)) (s (car b))) + (cond ((null? (cdr b)) + (stream* s " {" (environment-reference-type o s) "}\n" + (loop (cdr bs)))) + (else + (stream* (iline s (cadr b)) + (loop (cdr bs))))))))))) + +(define (inspect-vector o) + (let ((len (vector-length o))) + (let loop ((i 0)) + (cond ((= i len) (stream)) + (else (stream* (iline i (vector-ref o i)) + (loop (1+ i)))))))) + +(define (inspect-procedure o) + (cond ((primitive-procedure? o) + (stream (iline "name" (primitive-procedure-name o)) + (iline "arity" (primitive-procedure-arity o)) + (iline "doc" (primitive-procedure-documentation o)))) + ((compound-procedure? o) + (stream (iline "arity" (procedure-arity o)) + (iline "lambda" (procedure-lambda o)) + (iline "env" (ignore-errors + (lambda () (procedure-environment o)))))) + (else + (stream + (iline "block" (compiled-entry/block o)) + (with-output-to-string (lambda () (compiler:disassemble o))))))) + +(define (inspect-code-block o) + (stream-append + (let loop ((i (compiled-code-block/constants-start o))) + (cond ((>= i (compiled-code-block/constants-end o)) (stream)) + (else + (stream* + (iline i (system-vector-ref o i)) + (loop (+ i compiled-code-block/bytes-per-object)))))) + (stream (iline "debuginfo" (compiled-code-block/debugging-info o)) + (iline "env" (compiled-code-block/environment o)) + (with-output-to-string (lambda () (compiler:disassemble o)))))) + +(define (inspect-scode o) + (stream (pprint-to-string o))) + +(define (probably-scode? o) + (define tests (list access? assignment? combination? comment? + conditional? definition? delay? disjunction? lambda? + quotation? sequence? the-environment? variable?)) + (let loop ((tests tests)) + (cond ((null? tests) #f) + (((car tests) o)) + (else (loop (cdr tests)))))) + +(define (inspect-system-pair o) + (stream (iline "car" (system-pair-car o)) + (iline "cdr" (system-pair-cdr o)))) + + +;;;; Auxilary functions + +(define nil '()) +(define t 't) +(define (elisp-false? o) (member o '(nil ()))) +(define (elisp-true? o) (not (elisp-false? o))) +(define (>line o) + (let ((r (write-to-string o 100))) + (cond ((not (car r)) (cdr r)) + (else (string-append (cdr r) " .."))))) +;; Must compile >line otherwise we can't write unassigend-reference-traps. +(set! >line (compile-procedure >line)) +(define (read-from-string s) (with-input-from-string s read)) +(define (pprint-to-string o) + (with-string-output-port + (lambda (p) + (fluid-let ((*unparser-list-breadth-limit* 10) + (*unparser-list-depth-limit* 4) + (*unparser-string-length-limit* 100)) + (pp o p))))) +;(define (1+ n) (+ n 1)) +(define (1- n) (- n 1)) +(define (package-lookup package name) + (let ((p (if (package? package) package (find-package package)))) + (environment-lookup (package/environment p) name))) +(define log-port (current-output-port)) +(define (log-event fstring . args) + ;;(apply format log-port fstring args) + #f + ) + +;;; swank-mit-scheme.scm ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mlworks.sml b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mlworks.sml new file mode 100644 index 0000000..3efac53 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mlworks.sml @@ -0,0 +1,348 @@ +(* swank-mlworks.sml -- SWANK server for MLWorks + * + * This code has been placed in the Public Domain. + *) + +(* This is an experiment to see how the interfaces/modules would look + * in a language with a supposedly "good" module system. + * + * MLWorks is probably the only SML implementation that tries to + * support "interactive programming". Since MLWorks wasn't maintained + * the last 15 or so years, big chunks of the SML Basis Library are + * missing or not the way as required by the standard. That makes it + * rather hard to do anything; it also shows that MLWorks hasn't been + * "used in anger" for a long time. + *) + +structure Swank = struct + + structure Util = struct + fun utf8ToString (v:Word8Vector.vector) : string = Byte.bytesToString v + fun stringToUtf8 s = Byte.stringToBytes s + end + + structure Map = struct + datatype ('a, 'b) map = Alist of {list: ('a * 'b) list ref, + eq: ('a * 'a) -> bool} + + fun stringMap () = + Alist {list = ref [], + eq = (fn (x:string,y:string) => x = y)} + + + fun lookup (Alist {list, eq}, key) = + let fun search [] = NONE + | search ((key', value) :: xs) = + if eq (key', key) then SOME value + else search xs + in search (!list) + end + + fun put (Alist {list, eq}, key, value) = + let val l = (key, value) :: (!list) + in list := l + end + + end + + structure CharBuffer = struct + local + structure C = CharArray + datatype buffer = B of {array : C.array ref, + index: int ref} + in + + fun new hint = B {array = ref (C.array (hint, #"\000")), + index = ref 0} + + fun append (buffer as B {array, index}, char) = + let val a = !array + val i = !index + val len = C.length a + in if i < len then + (C.update (a, i, char); + index := i + 1; + ()) + else let val aa = C.array (2 * len, #"\000") + fun copy (src, dst) = + let val len = C.length src + fun loop i = + if i = len then () + else (C.update (dst, i, C.sub (src, i)); + loop (i + 1)) + in loop 0 end + in copy (a, aa); + C.update (aa, i, char); + array := aa; + index := i + 1; + () + end + end + + fun toString (B {array, index}) = + let val a = !array + val i = !index + in CharVector.tabulate (i, fn i => C.sub (a, i)) end + + end + + end + + + structure Sexp = struct + structure Type = struct + datatype sexp = Int of int + | Str of string + | Lst of sexp list + | Sym of string + | QSym of string * string + | T + | Nil + | Quote + end + open Type + + exception ReadError + + fun fromUtf8 v = + let val len = Word8Vector.length v + val index = ref 0 + fun getc () = + case getc' () of + SOME c => c + | NONE => raise ReadError + and getc' () = + let val i = !index + in if i = len then NONE + else (index := i + 1; + SOME (Byte.byteToChar (Word8Vector.sub (v, i)))) + end + and ungetc () = index := !index - 1 + and sexp () : sexp = + case getc () of + #"\"" => string (CharBuffer.new 100) + | #"(" => lst () + | #"'" => Lst [Quote, sexp ()] + | _ => (ungetc(); token ()) + and string buf : sexp = + case getc () of + #"\"" => Str (CharBuffer.toString buf) + | #"\\" => (CharBuffer.append (buf, getc ()); string buf) + | c => (CharBuffer.append (buf, c); string buf) + and lst () = + let val x = sexp () + in case getc () of + #")" => Lst [x] + | #" " => let val Lst y = lst () in Lst (x :: y) end + | _ => raise ReadError + end + and token () = + let val tok = token' (CharBuffer.new 50) + val c0 = String.sub (tok, 0) + in if Char.isDigit c0 then (case Int.fromString tok of + SOME i => Int i + | NONE => raise ReadError) + else + Sym (tok) + end + and token' buf : string = + case getc' () of + NONE => CharBuffer.toString buf + | SOME #"\\" => (CharBuffer.append (buf, getc ()); + token' buf) + | SOME #" " => (ungetc (); CharBuffer.toString buf) + | SOME #")" => (ungetc (); CharBuffer.toString buf) + | SOME c => (CharBuffer.append (buf, c); token' buf) + in + sexp () + end + + fun toString sexp = + case sexp of + (Str s) => "\"" ^ String.toCString s ^ "\"" + | (Lst []) => "nil" + | (Lst xs) => "(" ^ String.concatWith " " (map toString xs) ^ ")" + | Sym (name) => name + | QSym (pkg, name) => pkg ^ ":" ^ name + | Quote => "quote" + | T => "t" + | Nil => "nil" + | Int i => Int.toString i + + fun toUtf8 sexp = Util.stringToUtf8 (toString sexp) + end + + structure Net = struct + local + structure S = Socket + structure I = INetSock + structure W = Word8Vector + + fun createSocket (port) = + let val sock : S.passive I.stream_sock = I.TCP.socket () + val SOME localhost = NetHostDB.fromString "127.0.0.1" + in + S.Ctl.setREUSEADDR (sock, true); + S.bind (sock, I.toAddr (localhost, port)); + S.listen (sock, 2); + sock + end + + fun addrToString sockAddr = + let val (ip, port) = I.fromAddr sockAddr + in NetHostDB.toString ip ^ ":" ^ Int.toString port + end + + exception ShortRead of W.vector + exception InvalidHexString of string + in + + fun acceptConnection port = + let val sock = createSocket port + val addr = S.Ctl.getSockName sock + val _ = print ("Listening on: " ^ addrToString addr ^ "\n") + val (peer, addr) = S.accept sock + in + S.close sock; + print ("Connection from: " ^ addrToString addr ^ "\n"); + peer + end + + fun receivePacket socket = + let val v = S.recvVec (socket, 6) + val _ = if W.length v = 6 then () + else raise ShortRead v + val s = Util.utf8ToString v + val _ = print ("s = " ^ s ^ "\n") + val len = + case StringCvt.scanString (Int.scan StringCvt.HEX) s of + SOME len => len + | NONE => raise InvalidHexString s + val _ = print ("len = " ^ Int.toString len ^ "\n") + val payload = S.recvVec (socket, len) + val plen = W.length payload + val _ = print ("plen = " ^ Int.toString plen ^ "\n") + val _ = if plen = len then () + else raise ShortRead payload + in + payload + end + + fun nibbleToHex i:string = Int.fmt StringCvt.HEX i + + fun loadNibble i pos = + Word32.toInt (Word32.andb (Word32.>> (Word32.fromInt i, + Word.fromInt (pos * 4)), + 0wxf)) + + fun hexDigit i pos = nibbleToHex (loadNibble i pos) + + fun lenToHex i = + concat [hexDigit i 5, + hexDigit i 4, + hexDigit i 3, + hexDigit i 2, + hexDigit i 1, + hexDigit i 0] + + fun sendPacket (payload:W.vector, socket) = + let val len = W.length payload + val header = Util.stringToUtf8 (lenToHex len) + val packet = W.concat [header, payload] + in print ("len = " ^ Int.toString len ^ "\n" + ^ "header = " ^ lenToHex len ^ "\n" + ^ "paylad = " ^ Util.utf8ToString payload ^ "\n"); + S.sendVec (socket, {buf = packet, i = 0, sz = NONE}) + end + + end + end + + structure Rpc = struct + open Sexp.Type + + val funTable : (string, sexp list -> sexp) Map.map + = Map.stringMap () + + fun define name f = Map.put (funTable, name, f) + + exception UnknownFunction of string + fun call (name, args) = + (print ("call: " ^ name ^ "\n"); + case Map.lookup (funTable, name) of + SOME f => f args + | NONE => raise UnknownFunction name) + + + local fun getpid () = + Word32.toInt (Posix.Process.pidToWord (Posix.ProcEnv.getpid ())) + in + fun connectionInfo [] = + Lst [Sym ":pid", Int (getpid ()), + Sym ":lisp-implementation", Lst [Sym ":type", Str "MLWorks", + Sym ":name", Str "mlworks", + Sym ":version", Str "2.x"], + Sym ":machine", Lst [Sym ":instance", Str "", + Sym ":type", Str "", + Sym ":version", Str ""], + Sym ":features", Nil, + Sym ":package", Lst [Sym ":name", Str "root", + Sym ":prompt", Str "-"]] + end + + fun nyi _ = Nil + + local structure D = Shell.Dynamic + in + fun interactiveEval [Str string] = + let val x = D.eval string + in Str (concat [D.printValue x, " : ", D.printType (D.getType x)]) + end + end + + val _ = + (define "swank:connection-info" connectionInfo; + define "swank:swank-require" nyi; + define "swank:interactive-eval" interactiveEval; + ()) + end + + structure EventLoop = struct + open Sexp.Type + + fun execute (sexp, pkg) = + (print ("sexp = " ^ (Sexp.toString sexp) ^ "\n"); + case sexp of + Lst (Sym name :: args) => Rpc.call (name, args)) + + fun emacsRex (sexp, pkg, id as Int _, sock) = + let val result = (Lst [Sym (":ok"), execute (sexp, pkg)] + handle exn => (Lst [Sym ":abort", + Str (exnName exn ^ ": " + ^ exnMessage exn)])) + val reply = Lst [Sym ":return", result, id] + in Net.sendPacket (Sexp.toUtf8 reply, sock) + end + + fun dispatch (Lst ((Sym key) :: args), sock) = + case key of + ":emacs-rex" => let val [sexp, pkg, _, id] = args + in emacsRex (sexp, pkg, id, sock) + end + + fun processRequests socket:unit = + let val sexp = Sexp.fromUtf8 (Net.receivePacket socket) + in print ("request: " + ^ Util.utf8ToString (Sexp.toUtf8 sexp) + ^ "\n"); + dispatch (sexp, socket); + processRequests socket + end + + end + + (* val _ = EventLoop.processRequests (Net.acceptConnection 4005) *) + val _ = () + end + +(* (Swank.EventLoop.processRequests (Swank.Net.acceptConnection 4005)) *) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mrepl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mrepl.lisp new file mode 100644 index 0000000..cc8ce81 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mrepl.lisp @@ -0,0 +1,162 @@ +;;; swank-mrepl.lisp +;; +;; Licence: public domain + +(in-package :swank) +(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((api '( + *emacs-connection* + channel + channel-id + define-channel-method + defslimefun + dcase + log-event + process-requests + send-to-remote-channel + use-threads-p + wait-for-event + with-bindings + with-connection + with-top-level-restart + with-slime-interrupts + ))) + (eval `(defpackage #:swank-api + (:use) + (:import-from #:swank . ,api) + (:export . ,api))))) + +(defpackage :swank-mrepl + (:use :cl :swank-api) + (:export #:create-mrepl)) + +(in-package :swank-mrepl) + +(defclass listener-channel (channel) + ((remote :initarg :remote) + (env :initarg :env) + (mode :initform :eval) + (tag :initform nil))) + +(defun package-prompt (package) + (reduce (lambda (x y) (if (<= (length x) (length y)) x y)) + (cons (package-name package) (package-nicknames package)))) + +(defslimefun create-mrepl (remote) + (let* ((pkg *package*) + (conn *emacs-connection*) + (thread (if (use-threads-p) + (spawn-listener-thread conn) + nil)) + (ch (make-instance 'listener-channel :remote remote :thread thread))) + (setf (slot-value ch 'env) (initial-listener-env ch)) + (when thread + (swank/backend:send thread `(:serve-channel ,ch))) + (list (channel-id ch) + (swank/backend:thread-id (or thread (swank/backend:current-thread))) + (package-name pkg) + (package-prompt pkg)))) + +(defun initial-listener-env (listener) + `((*package* . ,*package*) + (*standard-output* . ,(make-listener-output-stream listener)) + (*standard-input* . ,(make-listener-input-stream listener)))) + +(defun spawn-listener-thread (connection) + (swank/backend:spawn + (lambda () + (with-connection (connection) + (dcase (swank/backend:receive) + ((:serve-channel c) + (loop + (with-top-level-restart (connection (drop-unprocessed-events c)) + (process-requests nil))))))) + :name "mrepl thread")) + +(defun drop-unprocessed-events (channel) + (with-slots (mode) channel + (let ((old-mode mode)) + (setf mode :drop) + (unwind-protect + (process-requests t) + (setf mode old-mode))) + (send-prompt channel))) + +(define-channel-method :process ((c listener-channel) string) + (log-event ":process ~s~%" string) + (with-slots (mode remote) c + (ecase mode + (:eval (mrepl-eval c string)) + (:read (mrepl-read c string)) + (:drop)))) + +(defun mrepl-eval (channel string) + (with-slots (remote env) channel + (let ((aborted t)) + (with-bindings env + (unwind-protect + (let ((result (with-slime-interrupts (read-eval-print string)))) + (send-to-remote-channel remote `(:write-result ,result)) + (setq aborted nil)) + (setf env (loop for (sym) in env + collect (cons sym (symbol-value sym)))) + (cond (aborted + (send-to-remote-channel remote `(:evaluation-aborted))) + (t + (send-prompt channel)))))))) + +(defun send-prompt (channel) + (with-slots (env remote) channel + (let ((pkg (or (cdr (assoc '*package* env)) *package*)) + (out (cdr (assoc '*standard-output* env))) + (in (cdr (assoc '*standard-input* env)))) + (when out (force-output out)) + (when in (clear-input in)) + (send-to-remote-channel remote `(:prompt ,(package-name pkg) + ,(package-prompt pkg)))))) + +(defun mrepl-read (channel string) + (with-slots (tag) channel + (assert tag) + (throw tag string))) + +(defun read-eval-print (string) + (with-input-from-string (in string) + (setq / ()) + (loop + (let* ((form (read in nil in))) + (cond ((eq form in) (return)) + (t (setq / (multiple-value-list (eval (setq + form)))))))) + (force-output) + (if / + (format nil "~{~s~%~}" /) + "; No values"))) + +(defun make-listener-output-stream (channel) + (let ((remote (slot-value channel 'remote))) + (swank/backend:make-output-stream + (lambda (string) + (send-to-remote-channel remote `(:write-string ,string)))))) + +(defun make-listener-input-stream (channel) + (swank/backend:make-input-stream (lambda () (read-input channel)))) + +(defun set-mode (channel new-mode) + (with-slots (mode remote) channel + (unless (eq mode new-mode) + (send-to-remote-channel remote `(:set-read-mode ,new-mode))) + (setf mode new-mode))) + +(defun read-input (channel) + (with-slots (mode tag remote) channel + (force-output) + (let ((old-mode mode) + (old-tag tag)) + (setf tag (cons nil nil)) + (set-mode channel :read) + (unwind-protect + (catch tag (process-requests nil)) + (setf tag old-tag) + (set-mode channel old-mode))))) + +(provide :swank-mrepl) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-package-fu.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-package-fu.lisp new file mode 100644 index 0000000..a22807a --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-package-fu.lisp @@ -0,0 +1,65 @@ + +(in-package :swank) + +(defslimefun package= (string1 string2) + (let* ((pkg1 (guess-package string1)) + (pkg2 (guess-package string2))) + (and pkg1 pkg2 (eq pkg1 pkg2)))) + +(defslimefun export-symbol-for-emacs (symbol-str package-str) + (let ((package (guess-package package-str))) + (when package + (let ((*buffer-package* package)) + (export `(,(from-string symbol-str)) package))))) + +(defslimefun unexport-symbol-for-emacs (symbol-str package-str) + (let ((package (guess-package package-str))) + (when package + (let ((*buffer-package* package)) + (unexport `(,(from-string symbol-str)) package))))) + +#+sbcl +(defun list-structure-symbols (name) + (let ((dd (sb-kernel:find-defstruct-description name ))) + (list* name + (sb-kernel:dd-default-constructor dd) + (sb-kernel:dd-predicate-name dd) + (sb-kernel::dd-copier-name dd) + (mapcar #'sb-kernel:dsd-accessor-name + (sb-kernel:dd-slots dd))))) + +#+ccl +(defun list-structure-symbols (name) + (let ((definition (gethash name ccl::%defstructs%))) + (list* name + (ccl::sd-constructor definition) + (ccl::sd-refnames definition)))) + +(defun list-class-symbols (name) + (let* ((class (find-class name)) + (slots (swank-mop:class-direct-slots class))) + (labels ((extract-symbol (name) + (if (and (consp name) (eql (car name) 'setf)) + (cadr name) + name)) + (slot-accessors (slot) + (nintersection (copy-list (swank-mop:slot-definition-readers slot)) + (copy-list (swank-mop:slot-definition-readers slot)) + :key #'extract-symbol))) + (list* (class-name class) + (mapcan #'slot-accessors slots))))) + +(defslimefun export-structure (name package) + (let ((*package* (guess-package package))) + (when *package* + (let* ((name (from-string name)) + (symbols (cond #+(or sbcl ccl) + ((or (not (find-class name nil)) + (subtypep name 'structure-object)) + (list-structure-symbols name)) + (t + (list-class-symbols name))))) + (export symbols) + symbols)))) + +(provide :swank-package-fu) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-presentation-streams.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-presentation-streams.lisp new file mode 100644 index 0000000..93a6d1d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-presentation-streams.lisp @@ -0,0 +1,334 @@ +;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities +;;; to portions of output +;;; +;;; Authors: Alan Ruttenberg +;;; Matthias Koeppe +;;; Helmut Eller +;;; +;;; License: This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-presentations)) + +;; This file contains a mechanism for printing to the slime repl so +;; that the printed result remembers what object it is associated +;; with. This extends the recording of REPL results. +;; +;; There are two methods: +;; +;; 1. Depends on the ilisp bridge code being installed and ready to +;; intercept messages in the printed stream. We encode the +;; information with a message saying that we are starting to print +;; an object corresponding to a given id and another when we are +;; done. The process filter notices these and adds the necessary +;; text properties to the output. +;; +;; 2. Use separate protocol messages :presentation-start and +;; :presentation-end for sending presentations. +;; +;; We only do this if we know we are printing to a slime stream, +;; checked with the method slime-stream-p. Initially this checks for +;; the knows slime streams looking at *connections*. In cmucl, sbcl, and +;; openmcl it also checks if it is a pretty-printing stream which +;; ultimately prints to a slime stream. +;; +;; Method 1 seems to be faster, but the printed escape sequences can +;; disturb the column counting, and thus the layout in pretty-printing. +;; We use method 1 when a dedicated output stream is used. +;; +;; Method 2 is cleaner and works with pretty printing if the pretty +;; printers support "annotations". We use method 2 when no dedicated +;; output stream is used. + +;; Control +(defvar *enable-presenting-readable-objects* t + "set this to enable automatically printing presentations for some +subset of readable objects, such as pathnames." ) + +;; doing it + +(defmacro presenting-object (object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl" + `(presenting-object-1 ,object ,stream #'(lambda () ,@body))) + +(defmacro presenting-object-if (predicate object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl if predicate is true" + (let ((continue (gensym))) + `(let ((,continue #'(lambda () ,@body))) + (if ,predicate + (presenting-object-1 ,object ,stream ,continue) + (funcall ,continue))))) + +;;; Get pretty printer patches for SBCL at load (not compile) time. +#+#:disable-dangerous-patching ; #+sbcl +(eval-when (:load-toplevel) + (handler-bind ((simple-error + (lambda (c) + (declare (ignore c)) + (let ((clobber-it (find-restart 'sb-kernel::clobber-it))) + (when clobber-it (invoke-restart clobber-it)))))) + (sb-ext:without-package-locks + (swank/sbcl::with-debootstrapping + (load (make-pathname + :name "sbcl-pprint-patch" + :type "lisp" + :directory (pathname-directory + swank-loader:*source-directory*))))))) + +(let ((last-stream nil) + (last-answer nil)) + (defun slime-stream-p (stream) + "Check if stream is one of the slime streams, since if it isn't we +don't want to present anything. +Two special return values: +:DEDICATED -- Output ends up on a dedicated output stream +:REPL-RESULT -- Output ends up on the :repl-results target. +" + (if (eq last-stream stream) + last-answer + (progn + (setq last-stream stream) + (if (eq stream t) + (setq stream *standard-output*)) + (setq last-answer + (or #+openmcl + (and (typep stream 'ccl::xp-stream) + ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) + (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) + #+cmu + (or (and (typep stream 'lisp::indenting-stream) + (slime-stream-p (lisp::indenting-stream-stream stream))) + (and (typep stream 'pretty-print::pretty-stream) + (fboundp 'pretty-print::enqueue-annotation) + (let ((slime-stream-p + (slime-stream-p (pretty-print::pretty-stream-target stream)))) + (and ;; Printing through CMUCL pretty + ;; streams is only cleanly + ;; possible if we are using the + ;; bridge-less protocol with + ;; annotations, because the bridge + ;; escape sequences disturb the + ;; pretty printer layout. + (not (eql slime-stream-p :dedicated-output)) + ;; If OK, return the return value + ;; we got from slime-stream-p on + ;; the target stream (could be + ;; :repl-result): + slime-stream-p)))) + #+sbcl + (let () + (declare (notinline sb-pretty::pretty-stream-target)) + (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)) + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty) + (not *use-dedicated-output-stream*) + (slime-stream-p (sb-pretty::pretty-stream-target stream)))) + #+allegro + (and (typep stream 'excl:xp-simple-stream) + (slime-stream-p (excl::stream-output-handle stream))) + (loop for connection in *connections* + thereis (or (and (eq stream (connection.dedicated-output connection)) + :dedicated) + (eq stream (connection.socket-io connection)) + (eq stream (connection.user-output connection)) + (eq stream (connection.user-io connection)) + (and (eq stream (connection.repl-results connection)) + :repl-result))))))))) + +(defun can-present-readable-objects (&optional stream) + (declare (ignore stream)) + *enable-presenting-readable-objects*) + +;; If we are printing to an XP (pretty printing) stream, printing the +;; escape sequences directly would mess up the layout because column +;; counting is disturbed. Use "annotations" instead. +#+allegro +(defun write-annotation (stream function arg) + (if (typep stream 'excl:xp-simple-stream) + (excl::schedule-annotation stream function arg) + (funcall function arg stream nil))) +#+cmu +(defun write-annotation (stream function arg) + (if (and (typep stream 'pp:pretty-stream) + (fboundp 'pp::enqueue-annotation)) + (pp::enqueue-annotation stream function arg) + (funcall function arg stream nil))) +#+sbcl +(defun write-annotation (stream function arg) + (let ((enqueue-annotation + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty))) + (if (and enqueue-annotation + (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))) + (funcall enqueue-annotation stream function arg) + (funcall function arg stream nil)))) +#-(or allegro cmu sbcl) +(defun write-annotation (stream function arg) + (funcall function arg stream nil)) + +(defstruct presentation-record + (id) + (printed-p) + (target)) + +(defun presentation-start (record stream truncatep) + (unless truncatep + ;; Don't start new presentations when nothing is going to be + ;; printed due to *print-lines*. + (let ((pid (presentation-record-id record)) + (target (presentation-record-target record))) + (case target + (:dedicated + ;; Use bridge protocol + (write-string "<" stream) + (prin1 pid stream) + (write-string "" stream)) + (t + (finish-output stream) + (send-to-emacs `(:presentation-start ,pid ,target))))) + (setf (presentation-record-printed-p record) t))) + +(defun presentation-end (record stream truncatep) + (declare (ignore truncatep)) + ;; Always end old presentations that were started. + (when (presentation-record-printed-p record) + (let ((pid (presentation-record-id record)) + (target (presentation-record-target record))) + (case target + (:dedicated + ;; Use bridge protocol + (write-string ">" stream) + (prin1 pid stream) + (write-string "" stream)) + (t + (finish-output stream) + (send-to-emacs `(:presentation-end ,pid ,target))))))) + +(defun presenting-object-1 (object stream continue) + "Uses the bridge mechanism with two messages >id and ) + (pp-end-block stream ">")) + nil)) + (defmethod print-object :around ((pathname pathname) stream) + (swank::presenting-object-if + (swank::can-present-readable-objects stream) + pathname stream (call-next-method)))) + (ccl::def-load-pointers clear-presentations () + (swank::clear-presentation-tables))) + +(in-package :swank) + +#+cmu +(progn + (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body) + (presenting-object object stream + (fwrappers:call-next-function))) + + (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (fwrappers:call-next-function))) + + (defun monkey-patch-stream-printing () + (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) + (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper))) + +#+sbcl +(progn + (defvar *saved-%print-unreadable-object* + (fdefinition 'sb-impl::%print-unreadable-object)) + + (defun monkey-patch-stream-printing () + (sb-ext:without-package-locks + (when (eq (fdefinition 'sb-impl::%print-unreadable-object) + *saved-%print-unreadable-object*) + (setf (fdefinition 'sb-impl::%print-unreadable-object) + (lambda (object stream &rest args) + (presenting-object object stream + (apply *saved-%print-unreadable-object* + object stream args))))) + (defmethod print-object :around ((object pathname) stream) + (presenting-object object stream + (call-next-method)))))) + +#+allegro +(progn + (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation) + (swank::presenting-object object stream (excl:call-next-fwrapper))) + (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (excl:call-next-fwrapper))) + (defun monkey-patch-stream-printing () + (excl:fwrap 'excl::print-unreadable-object-1 + 'print-unreadable-present 'presenting-unreadable-wrapper) + (excl:fwrap 'excl::pathname-printer + 'print-pathname-present 'presenting-pathname-wrapper))) + +#-(or allegro sbcl cmu openmcl) +(defun monkey-patch-stream-printing () + (values)) + +;; Hook into SWANK. + +(defslimefun init-presentation-streams () + (monkey-patch-stream-printing) + ;; FIXME: import/use swank-repl to avoid package qualifier. + (setq swank-repl:*send-repl-results-function* + 'present-repl-results-via-presentation-streams)) + +(provide :swank-presentation-streams) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-presentations.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-presentations.lisp new file mode 100644 index 0000000..11326af --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-presentations.lisp @@ -0,0 +1,246 @@ +;;; swank-presentations.lisp --- imitate LispM's presentations +;; +;; Authors: Alan Ruttenberg +;; Luke Gorrie +;; Helmut Eller +;; Matthias Koeppe +;; +;; License: This code has been placed in the Public Domain. All warranties +;; are disclaimed. +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-repl)) + +;;;; Recording and accessing results of computations + +(defvar *record-repl-results* t + "Non-nil means that REPL results are saved for later lookup.") + +(defvar *object-to-presentation-id* + (make-weak-key-hash-table :test 'eq) + "Store the mapping of objects to numeric identifiers") + +(defvar *presentation-id-to-object* + (make-weak-value-hash-table :test 'eql) + "Store the mapping of numeric identifiers to objects") + +(defun clear-presentation-tables () + (clrhash *object-to-presentation-id*) + (clrhash *presentation-id-to-object*)) + +(defvar *presentation-counter* 0 "identifier counter") + +(defvar *nil-surrogate* (make-symbol "nil-surrogate")) + +;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the +;; rest of slime isn't thread safe either), do we really care? +(defun save-presented-object (object) + "Save OBJECT and return the assigned id. +If OBJECT was saved previously return the old id." + (let ((object (if (null object) *nil-surrogate* object))) + ;; We store *nil-surrogate* instead of nil, to distinguish it from + ;; an object that was garbage collected. + (or (gethash object *object-to-presentation-id*) + (let ((id (incf *presentation-counter*))) + (setf (gethash id *presentation-id-to-object*) object) + (setf (gethash object *object-to-presentation-id*) id) + id)))) + +(defslimefun lookup-presented-object (id) + "Retrieve the object corresponding to ID. +The secondary value indicates the absence of an entry." + (etypecase id + (integer + ;; + (multiple-value-bind (object foundp) + (gethash id *presentation-id-to-object*) + (cond + ((eql object *nil-surrogate*) + ;; A stored nil object + (values nil t)) + ((null object) + ;; Object that was replaced by nil in the weak hash table + ;; when the object was garbage collected. + (values nil nil)) + (t + (values object foundp))))) + (cons + (dcase id + ((:frame-var thread-id frame index) + (declare (ignore thread-id)) ; later + (handler-case + (frame-var-value frame index) + (t (condition) + (declare (ignore condition)) + (values nil nil)) + (:no-error (value) + (values value t)))) + ((:inspected-part part-index) + (inspector-nth-part part-index)))))) + +(defslimefun lookup-presented-object-or-lose (id) + "Get the result of the previous REPL evaluation with ID." + (multiple-value-bind (object foundp) (lookup-presented-object id) + (cond (foundp object) + (t (error "Attempt to access unrecorded object (id ~D)." id))))) + +(defslimefun lookup-and-save-presented-object-or-lose (id) + "Get the object associated with ID and save it in the presentation tables." + (let ((obj (lookup-presented-object-or-lose id))) + (save-presented-object obj))) + +(defslimefun clear-repl-results () + "Forget the results of all previous REPL evaluations." + (clear-presentation-tables) + t) + +(defun present-repl-results (values) + ;; Override a function in swank.lisp, so that + ;; presentations are associated with every REPL result. + (flet ((send (value) + (let ((id (and *record-repl-results* + (save-presented-object value)))) + (send-to-emacs `(:presentation-start ,id :repl-result)) + (send-to-emacs `(:write-string ,(prin1-to-string value) + :repl-result)) + (send-to-emacs `(:presentation-end ,id :repl-result)) + (send-to-emacs `(:write-string ,(string #\Newline) + :repl-result))))) + (fresh-line) + (finish-output) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (mapc #'send values)))) + + +;;;; Presentation menu protocol +;; +;; To define a menu for a type of object, define a method +;; menu-choices-for-presentation on that object type. This function +;; should return a list of two element lists where the first element is +;; the name of the menu action and the second is a function that will be +;; called if the menu is chosen. The function will be called with 3 +;; arguments: +;; +;; choice: The string naming the action from above +;; +;; object: The object +;; +;; id: The presentation id of the object +;; +;; You might want append (when (next-method-p) (call-next-method)) to +;; pick up the Menu actions of superclasses. +;; + +(defvar *presentation-active-menu* nil) + +(defun menu-choices-for-presentation-id (id) + (multiple-value-bind (ob presentp) (lookup-presented-object id) + (cond ((not presentp) 'not-present) + (t + (let ((menu-and-actions (menu-choices-for-presentation ob))) + (setq *presentation-active-menu* (cons id menu-and-actions)) + (mapcar 'car menu-and-actions)))))) + +(defun swank-ioify (thing) + (cond ((keywordp thing) thing) + ((and (symbolp thing)(not (find #\: (symbol-name thing)))) + (intern (symbol-name thing) 'swank-io-package)) + ((consp thing) (cons (swank-ioify (car thing)) + (swank-ioify (cdr thing)))) + (t thing))) + +(defun execute-menu-choice-for-presentation-id (id count item) + (let ((ob (lookup-presented-object id))) + (assert (equal id (car *presentation-active-menu*)) () + "Bug: Execute menu call for id ~a but menu has id ~a" + id (car *presentation-active-menu*)) + (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) + (swank-ioify (funcall action item ob id))))) + + +(defgeneric menu-choices-for-presentation (object) + (:method (ob) (declare (ignore ob)) nil)) ; default method + +;; Pathname +(defmethod menu-choices-for-presentation ((ob pathname)) + (let* ((file-exists (ignore-errors (probe-file ob))) + (lisp-type (make-pathname :type "lisp")) + (source-file (and (not (member (pathname-type ob) '("lisp" "cl") + :test 'equal)) + (let ((source (merge-pathnames lisp-type ob))) + (and (ignore-errors (probe-file source)) + source)))) + (fasl-file (and file-exists + (equal (ignore-errors + (namestring + (truename + (compile-file-pathname + (merge-pathnames lisp-type ob))))) + (namestring (truename ob)))))) + (remove nil + (list* + (and (and file-exists (not fasl-file)) + (list "Edit this file" + (lambda(choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring (truename object))) + nil))) + (and file-exists + (list "Dired containing directory" + (lambda (choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring + (truename + (merge-pathnames + (make-pathname :name "" :type "") + object)))) + nil))) + (and fasl-file + (list "Load this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (load ob) + nil))) + (and fasl-file + (list "Delete this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (let ((nt (namestring (truename ob)))) + (when (y-or-n-p-in-emacs "Delete ~a? " nt) + (delete-file nt))) + nil))) + (and source-file + (list "Edit lisp source file" + (lambda (choice object id) + (declare (ignore choice id object)) + (ed-in-emacs (namestring (truename source-file))) + nil))) + (and source-file + (list "Load lisp source file" + (lambda(choice object id) + (declare (ignore choice id object)) + (load source-file) + nil))) + (and (next-method-p) (call-next-method)))))) + +(defmethod menu-choices-for-presentation ((ob function)) + (list (list "Disassemble" + (lambda (choice object id) + (declare (ignore choice id)) + (disassemble object))))) + +(defslimefun inspect-presentation (id reset-p) + (let ((what (lookup-presented-object-or-lose id))) + (when reset-p + (reset-inspector)) + (inspect-object what))) + +(defslimefun init-presentations () + ;; FIXME: import/use swank-repl to avoid package qualifier. + (setq swank-repl:*send-repl-results-function* 'present-repl-results)) + +(provide :swank-presentations) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-quicklisp.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-quicklisp.lisp new file mode 100644 index 0000000..3654599 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-quicklisp.lisp @@ -0,0 +1,17 @@ +;;; swank-quicklisp.lisp -- Quicklisp support +;; +;; Authors: Matthew Kennedy +;; License: Public Domain +;; + +(in-package :swank) + +(defslimefun list-quicklisp-systems () + "Returns the Quicklisp systems list." + (if (member :quicklisp *features*) + (let ((ql-dist-name (find-symbol "NAME" "QL-DIST")) + (ql-system-list (find-symbol "SYSTEM-LIST" "QL"))) + (mapcar ql-dist-name (funcall ql-system-list))) + (error "Could not find Quicklisp already loaded."))) + +(provide :swank-quicklisp) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-r6rs.scm b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-r6rs.scm new file mode 100644 index 0000000..4e48050 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-r6rs.scm @@ -0,0 +1,416 @@ +;; swank-r6rs.sls --- Shareable code between swank-ikarus and swank-larceny +;; +;; Licence: public domain +;; Author: Helmut Eller +;; +;; This is a Swank server barely capable enough to process simple eval +;; requests from Emacs before dying. No fancy features like +;; backtraces, module redefintion, M-. etc. are implemented. Don't +;; even think about pc-to-source mapping. +;; +;; Despite standard modules, this file uses (swank os) and (swank sys) +;; which define implementation dependend functionality. There are +;; multiple modules in this files, which is probably not standardized. +;; + +;; Naive FORMAT implementation which supports: ~a ~s ~d ~x ~c +(library (swank format) + (export format printf fprintf) + (import (rnrs)) + + (define (format f . args) + (call-with-string-output-port + (lambda (port) (apply fprintf port f args)))) + + (define (printf f . args) + (let ((port (current-output-port))) + (apply fprintf port f args) + (flush-output-port port))) + + (define (fprintf port f . args) + (let ((len (string-length f))) + (let loop ((i 0) (args args)) + (cond ((= i len) (assert (null? args))) + ((and (char=? (string-ref f i) #\~) + (< (+ i 1) len)) + (dispatch-format (string-ref f (+ i 1)) port (car args)) + (loop (+ i 2) (cdr args))) + (else + (put-char port (string-ref f i)) + (loop (+ i 1) args)))))) + + (define (dispatch-format char port arg) + (let ((probe (assoc char format-dispatch-table))) + (cond (probe ((cdr probe) arg port)) + (else (error "invalid format char: " char))))) + + (define format-dispatch-table + `((#\a . ,display) + (#\s . ,write) + (#\d . ,(lambda (arg port) (put-string port (number->string arg 10)))) + (#\x . ,(lambda (arg port) (put-string port (number->string arg 16)))) + (#\c . ,(lambda (arg port) (put-char port arg)))))) + + +;; CL-style restarts to let us continue after errors. +(library (swank restarts) + (export with-simple-restart compute-restarts invoke-restart restart-name + write-restart-report) + (import (rnrs)) + + (define *restarts* '()) + + (define-record-type restart + (fields name reporter continuation)) + + (define (with-simple-restart name reporter thunk) + (call/cc + (lambda (k) + (let ((old-restarts *restarts*) + (restart (make-restart name (coerce-to-reporter reporter) k))) + (dynamic-wind + (lambda () (set! *restarts* (cons restart old-restarts))) + thunk + (lambda () (set! *restarts* old-restarts))))))) + + (define (compute-restarts) *restarts*) + + (define (invoke-restart restart . args) + (apply (restart-continuation restart) args)) + + (define (write-restart-report restart port) + ((restart-reporter restart) port)) + + (define (coerce-to-reporter obj) + (cond ((string? obj) (lambda (port) (put-string port obj))) + (#t (assert (procedure? obj)) obj))) + + ) + +;; This module encodes & decodes messages from the wire and queues them. +(library (swank event-queue) + (export make-event-queue wait-for-event enqueue-event + read-event write-event) + (import (rnrs) + (rnrs mutable-pairs) + (swank format)) + + (define-record-type event-queue + (fields (mutable q) wait-fun) + (protocol (lambda (init) + (lambda (wait-fun) + (init '() wait-fun))))) + + (define (wait-for-event q pattern) + (or (poll q pattern) + (begin + ((event-queue-wait-fun q) q) + (wait-for-event q pattern)))) + + (define (poll q pattern) + (let loop ((lag #f) + (l (event-queue-q q))) + (cond ((null? l) #f) + ((event-match? (car l) pattern) + (cond (lag + (set-cdr! lag (cdr l)) + (car l)) + (else + (event-queue-q-set! q (cdr l)) + (car l)))) + (else (loop l (cdr l)))))) + + (define (event-match? event pattern) + (cond ((or (number? pattern) + (member pattern '(t nil))) + (equal? event pattern)) + ((symbol? pattern) #t) + ((pair? pattern) + (case (car pattern) + ((quote) (equal? event (cadr pattern))) + ((or) (exists (lambda (p) (event-match? event p)) (cdr pattern))) + (else (and (pair? event) + (event-match? (car event) (car pattern)) + (event-match? (cdr event) (cdr pattern)))))) + (else (error "Invalid pattern: " pattern)))) + + (define (enqueue-event q event) + (event-queue-q-set! q + (append (event-queue-q q) + (list event)))) + + (define (write-event event port) + (let ((payload (call-with-string-output-port + (lambda (port) (write event port))))) + (write-length (string-length payload) port) + (put-string port payload) + (flush-output-port port))) + + (define (write-length len port) + (do ((i 24 (- i 4))) + ((= i 0)) + (put-string port + (number->string (bitwise-bit-field len (- i 4) i) + 16)))) + + (define (read-event port) + (let* ((header (string-append (get-string-n port 2) + (get-string-n port 2) + (get-string-n port 2))) + (_ (printf "header: ~s\n" header)) + (len (string->number header 16)) + (_ (printf "len: ~s\n" len)) + (payload (get-string-n port len))) + (printf "payload: ~s\n" payload) + (read (open-string-input-port payload)))) + + ) + +;; Entry points for SLIME commands. +(library (swank rpc) + (export connection-info interactive-eval + ;;compile-string-for-emacs + throw-to-toplevel sldb-abort + operator-arglist buffer-first-change + create-repl listener-eval) + (import (rnrs) + (rnrs eval) + (only (rnrs r5rs) scheme-report-environment) + (swank os) + (swank format) + (swank restarts) + (swank sys) + ) + + (define (connection-info . _) + `(,@'() + :pid ,(getpid) + :package (:name ">" :prompt ">") + :lisp-implementation (,@'() + :name ,(implementation-name) + :type "R6RS-Scheme"))) + + (define (interactive-eval string) + (call-with-values + (lambda () + (eval-in-interaction-environment (read-from-string string))) + (case-lambda + (() "; no value") + ((value) (format "~s" value)) + (values (format "values: ~s" values))))) + + (define (throw-to-toplevel) (invoke-restart-by-name-or-nil 'toplevel)) + + (define (sldb-abort) (invoke-restart-by-name-or-nil 'abort)) + + (define (invoke-restart-by-name-or-nil name) + (let ((r (find (lambda (r) (eq? (restart-name r) name)) + (compute-restarts)))) + (if r (invoke-restart r) 'nil))) + + (define (create-repl target) + (list "" "")) + + (define (listener-eval string) + (call-with-values (lambda () (eval-region string)) + (lambda values `(:values ,@(map (lambda (v) (format "~s" v)) values))))) + + (define (eval-region string) + (let ((sexp (read-from-string string))) + (if (eof-object? exp) + (values) + (eval-in-interaction-environment sexp)))) + + (define (read-from-string string) + (call-with-port (open-string-input-port string) read)) + + (define (operator-arglist . _) 'nil) + (define (buffer-first-change . _) 'nil) + + ) + +;; The server proper. Does the TCP stuff and exception handling. +(library (swank) + (export start-server) + (import (rnrs) + (rnrs eval) + (swank os) + (swank format) + (swank event-queue) + (swank restarts)) + + (define-record-type connection + (fields in-port out-port event-queue)) + + (define (start-server port) + (accept-connections (or port 4005) #f)) + + (define (start-server/port-file port-file) + (accept-connections #f port-file)) + + (define (accept-connections port port-file) + (let ((sock (make-server-socket port))) + (printf "Listening on port: ~s\n" (local-port sock)) + (when port-file + (write-port-file (local-port sock) port-file)) + (let-values (((in out) (accept sock (latin-1-codec)))) + (dynamic-wind + (lambda () #f) + (lambda () + (close-socket sock) + (serve in out)) + (lambda () + (close-port in) + (close-port out)))))) + + (define (write-port-file port port-file) + (call-with-output-file + (lambda (file) + (write port file)))) + + (define (serve in out) + (let ((err (current-error-port)) + (q (make-event-queue + (lambda (q) + (let ((e (read-event in))) + (printf "read: ~s\n" e) + (enqueue-event q e)))))) + (dispatch-loop (make-connection in out q)))) + + (define-record-type sldb-state + (fields level condition continuation next)) + + (define (dispatch-loop conn) + (let ((event (wait-for-event (connection-event-queue conn) 'x))) + (case (car event) + ((:emacs-rex) + (with-simple-restart + 'toplevel "Return to SLIME's toplevel" + (lambda () + (apply emacs-rex conn #f (cdr event))))) + (else (error "Unhandled event: ~s" event)))) + (dispatch-loop conn)) + + (define (recover thunk on-error-thunk) + (let ((ok #f)) + (dynamic-wind + (lambda () #f) + (lambda () + (call-with-values thunk + (lambda vals + (set! ok #t) + (apply values vals)))) + (lambda () + (unless ok + (on-error-thunk)))))) + + ;; Couldn't resist to exploit the prefix feature. + (define rpc-entries (environment '(prefix (swank rpc) swank:))) + + (define (emacs-rex conn sldb-state form package thread tag) + (let ((out (connection-out-port conn))) + (recover + (lambda () + (with-exception-handler + (lambda (condition) + (call/cc + (lambda (k) + (sldb-exception-handler conn condition k sldb-state)))) + (lambda () + (let ((value (apply (eval (car form) rpc-entries) (cdr form)))) + (write-event `(:return (:ok ,value) ,tag) out))))) + (lambda () + (write-event `(:return (:abort) ,tag) out))))) + + (define (sldb-exception-handler connection condition k sldb-state) + (when (serious-condition? condition) + (let ((level (if sldb-state (+ (sldb-state-level sldb-state) 1) 1)) + (out (connection-out-port connection))) + (write-event `(:debug 0 ,level ,@(debugger-info condition connection)) + out) + (dynamic-wind + (lambda () #f) + (lambda () + (sldb-loop connection + (make-sldb-state level condition k sldb-state))) + (lambda () (write-event `(:debug-return 0 ,level nil) out)))))) + + (define (sldb-loop connection state) + (apply emacs-rex connection state + (cdr (wait-for-event (connection-event-queue connection) + '(':emacs-rex . _)))) + (sldb-loop connection state)) + + (define (debugger-info condition connection) + (list `(,(call-with-string-output-port + (lambda (port) (print-condition condition port))) + ,(format " [type ~s]" (if (record? condition) + (record-type-name (record-rtd condition)) + )) + ()) + (map (lambda (r) + (list (format "~a" (restart-name r)) + (call-with-string-output-port + (lambda (port) + (write-restart-report r port))))) + (compute-restarts)) + '() + '())) + + (define (print-condition obj port) + (cond ((condition? obj) + (let ((list (simple-conditions obj))) + (case (length list) + ((0) + (display "Compuond condition with zero components" port)) + ((1) + (assert (eq? obj (car list))) + (print-simple-condition (car list) port)) + (else + (display "Compound condition:\n" port) + (for-each (lambda (c) + (display " " port) + (print-simple-condition c port) + (newline port)) + list))))) + (#t + (fprintf port "Non-condition object: ~s" obj)))) + + (define (print-simple-condition condition port) + (fprintf port "~a" (record-type-name (record-rtd condition))) + (case (count-record-fields condition) + ((0) #f) + ((1) + (fprintf port ": ") + (do-record-fields condition (lambda (name value) (write value port)))) + (else + (fprintf port ":") + (do-record-fields condition (lambda (name value) + (fprintf port "\n~a: ~s" name value)))))) + + ;; Call FUN with RECORD's rtd and parent rtds. + (define (do-record-rtds record fun) + (do ((rtd (record-rtd record) (record-type-parent rtd))) + ((not rtd)) + (fun rtd))) + + ;; Call FUN with RECORD's field names and values. + (define (do-record-fields record fun) + (do-record-rtds + record + (lambda (rtd) + (let* ((names (record-type-field-names rtd)) + (len (vector-length names))) + (do ((i 0 (+ 1 i))) + ((= i len)) + (fun (vector-ref names i) ((record-accessor rtd i) record))))))) + + ;; Return the number of fields in RECORD + (define (count-record-fields record) + (let ((i 0)) + (do-record-rtds + record (lambda (rtd) + (set! i (+ i (vector-length (record-type-field-names rtd)))))) + i)) + + ) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-repl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-repl.lisp new file mode 100644 index 0000000..259c9ea --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-repl.lisp @@ -0,0 +1,441 @@ +;;; swank-repl.lisp --- Server side part of the Lisp listener. +;; +;; License: public domain +(in-package swank) + +(defpackage swank-repl + (:use cl swank/backend) + (:export *send-repl-results-function*) + (:import-from + swank + + *default-worker-thread-bindings* + + *loopback-interface* + + add-hook + *connection-closed-hook* + + eval-region + with-buffer-syntax + + connection + connection.socket-io + connection.repl-results + connection.user-input + connection.user-output + connection.user-io + connection.trace-output + connection.dedicated-output + connection.env + + multithreaded-connection + mconn.active-threads + mconn.repl-thread + mconn.auto-flush-thread + use-threads-p + + *emacs-connection* + default-connection + with-connection + + send-to-emacs + *communication-style* + handle-requests + wait-for-event + make-tag + thread-for-evaluation + socket-quest + + authenticate-client + encode-message + + auto-flush-loop + clear-user-input + + current-thread-id + cat + with-struct* + with-retry-restart + with-bindings + + package-string-for-prompt + find-external-format-or-lose + + defslimefun + + ;; FIXME: those should be exported from swank-repl only, but how to + ;; do that whithout breaking init files? + *use-dedicated-output-stream* + *dedicated-output-stream-port* + *globally-redirect-io*)) + +(in-package swank-repl) + +(defvar *use-dedicated-output-stream* nil + "When T swank will attempt to create a second connection to Emacs +which is used just to send output.") + +(defvar *dedicated-output-stream-port* 0 + "Which port we should use for the dedicated output stream.") + +(defvar *dedicated-output-stream-buffering* + (if (eq *communication-style* :spawn) t nil) + "The buffering scheme that should be used for the output stream. +Valid values are nil, t, :line") + +(defvar *globally-redirect-io* :started-from-emacs + "When T globally redirect all standard streams to Emacs. +When :STARTED-FROM-EMACS redirect when launched by M-x slime") + +(defun globally-redirect-io-p () + (case *globally-redirect-io* + ((t) t) + (:started-from-emacs swank-loader:*started-from-emacs*))) + +(defun open-streams (connection properties) + "Return the 5 streams for IO redirection: +DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" + (let* ((input-fn + (lambda () + (with-connection (connection) + (with-simple-restart (abort-read + "Abort reading input from Emacs.") + (read-user-input-from-emacs))))) + (dedicated-output (if *use-dedicated-output-stream* + (open-dedicated-output-stream + connection + (getf properties :coding-system)))) + (in (make-input-stream input-fn)) + (out (or dedicated-output + (make-output-stream (make-output-function connection)))) + (io (make-two-way-stream in out)) + (repl-results (swank:make-output-stream-for-target connection + :repl-result))) + (typecase connection + (multithreaded-connection + (setf (mconn.auto-flush-thread connection) + (make-auto-flush-thread out)))) + (values dedicated-output in out io repl-results))) + +(defun make-output-function (connection) + "Create function to send user output to Emacs." + (lambda (string) + (with-connection (connection) + (send-to-emacs `(:write-string ,string))))) + +(defun open-dedicated-output-stream (connection coding-system) + "Open a dedicated output connection to the Emacs on SOCKET-IO. +Return an output stream suitable for writing program output. + +This is an optimized way for Lisp to deliver output to Emacs." + (let ((socket (socket-quest *dedicated-output-stream-port* nil)) + (ef (find-external-format-or-lose coding-system))) + (unwind-protect + (let ((port (local-port socket))) + (encode-message `(:open-dedicated-output-stream ,port + ,coding-system) + (connection.socket-io connection)) + (let ((dedicated (accept-connection + socket + :external-format ef + :buffering *dedicated-output-stream-buffering* + :timeout 30))) + (authenticate-client dedicated) + (close-socket socket) + (setf socket nil) + dedicated)) + (when socket + (close-socket socket))))) + +(defmethod thread-for-evaluation ((connection multithreaded-connection) + (id (eql :find-existing))) + (or (car (mconn.active-threads connection)) + (find-repl-thread connection))) + +(defmethod thread-for-evaluation ((connection multithreaded-connection) + (id (eql :repl-thread))) + (find-repl-thread connection)) + +(defun find-repl-thread (connection) + (cond ((not (use-threads-p)) + (current-thread)) + (t + (let ((thread (mconn.repl-thread connection))) + (cond ((not thread) nil) + ((thread-alive-p thread) thread) + (t + (setf (mconn.repl-thread connection) + (spawn-repl-thread connection "new-repl-thread")))))))) + +(defun spawn-repl-thread (connection name) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (repl-loop connection))) + :name name)) + +(defun repl-loop (connection) + (handle-requests connection)) + +;;;;; Redirection during requests +;;; +;;; We always redirect the standard streams to Emacs while evaluating +;;; an RPC. This is done with simple dynamic bindings. + +(defslimefun create-repl (target &key coding-system) + (assert (eq target nil)) + (let ((conn *emacs-connection*)) + (initialize-streams-for-connection conn `(:coding-system ,coding-system)) + (with-struct* (connection. @ conn) + (setf (@ env) + `((*standard-input* . ,(@ user-input)) + ,@(unless (globally-redirect-io-p) + `((*standard-output* . ,(@ user-output)) + (*trace-output* . ,(or (@ trace-output) (@ user-output))) + (*error-output* . ,(@ user-output)) + (*debug-io* . ,(@ user-io)) + (*query-io* . ,(@ user-io)) + (*terminal-io* . ,(@ user-io)))))) + (maybe-redirect-global-io conn) + (add-hook *connection-closed-hook* 'update-redirection-after-close) + (typecase conn + (multithreaded-connection + (setf (mconn.repl-thread conn) + (spawn-repl-thread conn "repl-thread")))) + (list (package-name *package*) + (package-string-for-prompt *package*))))) + +(defun initialize-streams-for-connection (connection properties) + (multiple-value-bind (dedicated in out io repl-results) + (open-streams connection properties) + (setf (connection.dedicated-output connection) dedicated + (connection.user-io connection) io + (connection.user-output connection) out + (connection.user-input connection) in + (connection.repl-results connection) repl-results) + connection)) + +(defun read-user-input-from-emacs () + (let ((tag (make-tag))) + (force-output) + (send-to-emacs `(:read-string ,(current-thread-id) ,tag)) + (let ((ok nil)) + (unwind-protect + (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value))) + (setq ok t)) + (unless ok + (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag))))))) + +;;;;; Listener eval + +(defvar *listener-eval-function* 'repl-eval) + +(defvar *listener-saved-value* nil) + +(defslimefun listener-save-value (slimefun &rest args) + "Apply SLIMEFUN to ARGS and save the value. +The saved value should be visible to all threads and retrieved via +LISTENER-GET-VALUE." + (setq *listener-saved-value* (apply slimefun args)) + t) + +(defslimefun listener-get-value () + "Get the last value saved by LISTENER-SAVE-VALUE. +The value should be produced as if it were requested through +LISTENER-EVAL directly, so that spacial variables *, etc are set." + (listener-eval (let ((*package* (find-package :keyword))) + (write-to-string '*listener-saved-value*)))) + +(defslimefun listener-eval (string &key (window-width nil window-width-p)) + (if window-width-p + (let ((*print-right-margin* window-width)) + (funcall *listener-eval-function* string)) + (funcall *listener-eval-function* string))) + +(defslimefun clear-repl-variables () + (let ((variables '(*** ** * /// // / +++ ++ +))) + (loop for variable in variables + do (setf (symbol-value variable) nil)))) + +(defvar *send-repl-results-function* 'send-repl-results-to-emacs) + +(defun repl-eval (string) + (clear-user-input) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME REPL evaluation request.") + (track-package + (lambda () + (multiple-value-bind (values last-form) (eval-region string) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + last-form) + (funcall *send-repl-results-function* values)))))) + nil) + +(defun track-package (fun) + (let ((p *package*)) + (unwind-protect (funcall fun) + (unless (eq *package* p) + (send-to-emacs (list :new-package (package-name *package*) + (package-string-for-prompt *package*))))))) + +(defun send-repl-results-to-emacs (values) + (finish-output) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (dolist (v values) + (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline) + :repl-result))))) + +(defslimefun redirect-trace-output (target) + (setf (connection.trace-output *emacs-connection*) + (swank:make-output-stream-for-target *emacs-connection* target)) + nil) + + + +;;;; IO to Emacs +;;; +;;; This code handles redirection of the standard I/O streams +;;; (`*standard-output*', etc) into Emacs. The `connection' structure +;;; contains the appropriate streams, so all we have to do is make the +;;; right bindings. + +;;;;; Global I/O redirection framework +;;; +;;; Optionally, the top-level global bindings of the standard streams +;;; can be assigned to be redirected to Emacs. When Emacs connects we +;;; redirect the streams into the connection, and they keep going into +;;; that connection even if more are established. If the connection +;;; handling the streams closes then another is chosen, or if there +;;; are no connections then we revert to the original (real) streams. +;;; +;;; It is slightly tricky to assign the global values of standard +;;; streams because they are often shadowed by dynamic bindings. We +;;; solve this problem by introducing an extra indirection via synonym +;;; streams, so that *STANDARD-INPUT* is a synonym stream to +;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current" +;;; variables, so they can always be assigned to affect a global +;;; change. + +;;;;; Global redirection setup + +(defvar *saved-global-streams* '() + "A plist to save and restore redirected stream objects. +E.g. the value for '*standard-output* holds the stream object +for *standard-output* before we install our redirection.") + +(defun setup-stream-indirection (stream-var &optional stream) + "Setup redirection scaffolding for a global stream variable. +Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro: + +1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'. + +2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as +*STANDARD-INPUT*. + +3. Assigns *STANDARD-INPUT* to a synonym stream pointing to +*CURRENT-STANDARD-INPUT*. + +This has the effect of making *CURRENT-STANDARD-INPUT* contain the +effective global value for *STANDARD-INPUT*. This way we can assign +the effective global value even when *STANDARD-INPUT* is shadowed by a +dynamic binding." + (let ((current-stream-var (prefixed-var '#:current stream-var)) + (stream (or stream (symbol-value stream-var)))) + ;; Save the real stream value for the future. + (setf (getf *saved-global-streams* stream-var) stream) + ;; Define a new variable for the effective stream. + ;; This can be reassigned. + (proclaim `(special ,current-stream-var)) + (set current-stream-var stream) + ;; Assign the real binding as a synonym for the current one. + (let ((stream (make-synonym-stream current-stream-var))) + (set stream-var stream) + (set-default-initial-binding stream-var `(quote ,stream))))) + +(defun prefixed-var (prefix variable-symbol) + "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*" + (let ((basename (subseq (symbol-name variable-symbol) 1))) + (intern (format nil "*~A-~A" (string prefix) basename) :swank))) + +(defvar *standard-output-streams* + '(*standard-output* *error-output* *trace-output*) + "The symbols naming standard output streams.") + +(defvar *standard-input-streams* + '(*standard-input*) + "The symbols naming standard input streams.") + +(defvar *standard-io-streams* + '(*debug-io* *query-io* *terminal-io*) + "The symbols naming standard io streams.") + +(defun init-global-stream-redirection () + (when (globally-redirect-io-p) + (cond (*saved-global-streams* + (warn "Streams already redirected.")) + (t + (mapc #'setup-stream-indirection + (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)))))) + +(defun globally-redirect-io-to-connection (connection) + "Set the standard I/O streams to redirect to CONNECTION. +Assigns *CURRENT-* for all standard streams." + (dolist (o *standard-output-streams*) + (set (prefixed-var '#:current o) + (connection.user-output connection))) + ;; FIXME: If we redirect standard input to Emacs then we get the + ;; regular Lisp top-level trying to read from our REPL. + ;; + ;; Perhaps the ideal would be for the real top-level to run in a + ;; thread with local bindings for all the standard streams. Failing + ;; that we probably would like to inhibit it from reading while + ;; Emacs is connected. + ;; + ;; Meanwhile we just leave *standard-input* alone. + #+NIL + (dolist (i *standard-input-streams*) + (set (prefixed-var '#:current i) + (connection.user-input connection))) + (dolist (io *standard-io-streams*) + (set (prefixed-var '#:current io) + (connection.user-io connection)))) + +(defun revert-global-io-redirection () + "Set *CURRENT-* to *REAL-* for all standard streams." + (dolist (stream-var (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)) + (set (prefixed-var '#:current stream-var) + (getf *saved-global-streams* stream-var)))) + +;;;;; Global redirection hooks + +(defvar *global-stdio-connection* nil + "The connection to which standard I/O streams are globally redirected. +NIL if streams are not globally redirected.") + +(defun maybe-redirect-global-io (connection) + "Consider globally redirecting to CONNECTION." + (when (and (globally-redirect-io-p) (null *global-stdio-connection*) + (connection.user-io connection)) + (unless *saved-global-streams* + (init-global-stream-redirection)) + (setq *global-stdio-connection* connection) + (globally-redirect-io-to-connection connection))) + +(defun update-redirection-after-close (closed-connection) + "Update redirection after a connection closes." + (check-type closed-connection connection) + (when (eq *global-stdio-connection* closed-connection) + (if (and (default-connection) (globally-redirect-io-p)) + ;; Redirect to another connection. + (globally-redirect-io-to-connection (default-connection)) + ;; No more connections, revert to the real streams. + (progn (revert-global-io-redirection) + (setq *global-stdio-connection* nil))))) + +(provide :swank-repl) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-sbcl-exts.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-sbcl-exts.lisp new file mode 100644 index 0000000..6cbe09d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-sbcl-exts.lisp @@ -0,0 +1,67 @@ +;;; swank-sbcl-exts.lisp --- Misc extensions for SBCL +;; +;; Authors: Tobias C. Rittweiler +;; +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-arglists)) + +;; We need to do this so users can place `slime-sbcl-exts' into their +;; ~/.emacs, and still use any implementation they want. +#+sbcl +(progn + +;;; Display arglist of instructions. +;;; +(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'sb-assem:inst)) + argument-forms) + (flet ((decode-instruction-arglist (instr-name instr-arglist) + (let ((decoded-arglist (decode-arglist instr-arglist))) + ;; The arglist of INST is (instruction ...INSTR-ARGLIST...). + (push 'sb-assem::instruction (arglist.required-args decoded-arglist)) + (values decoded-arglist + (list instr-name) + t)))) + (if (null argument-forms) + (call-next-method) + (destructuring-bind (instruction &rest args) argument-forms + (declare (ignore args)) + (let* ((instr-name + (typecase instruction + (arglist-dummy + (string-upcase (arglist-dummy.string-representation instruction))) + (symbol + (string-downcase instruction)))) + (instr-fn + #+#.(swank/backend:with-symbol 'op-encoder-name 'sb-assem) + (or (sb-assem::op-encoder-name instr-name) + (sb-assem::op-encoder-name (string-upcase instr-name))) + #+#.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem) + (sb-assem::inst-emitter-symbol instr-name) + #+(and + (not #.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem)) + #.(swank/backend:with-symbol '*assem-instructions* 'sb-assem)) + (gethash instr-name sb-assem:*assem-instructions*))) + (cond ((functionp instr-fn) + (with-available-arglist (arglist) (arglist instr-fn) + (decode-instruction-arglist instr-name arglist))) + ((fboundp instr-fn) + (with-available-arglist (arglist) (arglist instr-fn) + ;; SB-ASSEM:INST invokes a symbolic INSTR-FN with + ;; current segment and current vop implicitly. + (decode-instruction-arglist instr-name + (if (or (get instr-fn :macro) + (macro-function instr-fn)) + arglist + (cddr arglist))))) + (t + (call-next-method)))))))) + + +) ; PROGN + +(provide :swank-sbcl-exts) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-snapshot.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-snapshot.lisp new file mode 100644 index 0000000..52a87ed --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-snapshot.lisp @@ -0,0 +1,67 @@ + +(defpackage swank-snapshot + (:use cl) + (:export restore-snapshot save-snapshot background-save-snapshot) + (:import-from swank defslimefun)) +(in-package swank-snapshot) + +(defslimefun save-snapshot (image-file) + (swank/backend:save-image image-file + (let ((c swank::*emacs-connection*)) + (lambda () (resurrect c)))) + (format nil "Dumped lisp to ~A" image-file)) + +(defslimefun restore-snapshot (image-file) + (let* ((conn swank::*emacs-connection*) + (stream (swank::connection.socket-io conn)) + (clone (swank/backend:dup (swank/backend:socket-fd stream))) + (style (swank::connection.communication-style conn)) + (repl (if (swank::connection.user-io conn) t)) + (args (list "--swank-fd" (format nil "~d" clone) + "--swank-style" (format nil "~s" style) + "--swank-repl" (format nil "~s" repl)))) + (swank::close-connection conn nil nil) + (swank/backend:exec-image image-file args))) + +(defslimefun background-save-snapshot (image-file) + (let ((connection swank::*emacs-connection*)) + (flet ((complete (success) + (let ((swank::*emacs-connection* connection)) + (swank::background-message + "Dumping lisp image ~A ~:[failed!~;succeeded.~]" + image-file success))) + (awaken () + (resurrect connection))) + (swank/backend:background-save-image image-file + :restart-function #'awaken + :completion-function #'complete) + (format nil "Started dumping lisp to ~A..." image-file)))) + +(in-package :swank) + +(defun swank-snapshot::resurrect (old-connection) + (setq *log-output* nil) + (init-log-output) + (clear-event-history) + (setq *connections* (delete old-connection *connections*)) + (format *error-output* "args: ~s~%" (command-line-args)) + (let* ((fd (read-command-line-arg "--swank-fd")) + (style (read-command-line-arg "--swank-style")) + (repl (read-command-line-arg "--swank-repl")) + (* (format *error-output* "fd=~s style=~s~%" fd style)) + (stream (make-fd-stream fd nil)) + (connection (make-connection nil stream style))) + (let ((*emacs-connection* connection)) + (when repl (swank-repl:create-repl nil)) + (background-message "~A" "Lisp image restored")) + (serve-requests connection) + (simple-repl))) + +(defun read-command-line-arg (name) + (let* ((args (command-line-args)) + (pos (position name args :test #'equal))) + (read-from-string (elt args (1+ pos))))) + +(in-package :swank-snapshot) + +(provide :swank-snapshot) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-sprof.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-sprof.lisp new file mode 100644 index 0000000..675240f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-sprof.lisp @@ -0,0 +1,154 @@ +;;; swank-sprof.lisp +;; +;; Authors: Juho Snellman +;; +;; License: MIT +;; + +(in-package :swank) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sb-sprof)) + +#+sbcl(progn + +(defvar *call-graph* nil) +(defvar *node-numbers* nil) +(defvar *number-nodes* nil) + +(defun frame-name (name) + (if (consp name) + (case (first name) + ((sb-c::xep sb-c::tl-xep + sb-c::&more-processor + sb-c::top-level-form + sb-c::&optional-processor) + (second name)) + (sb-pcl::fast-method + (cdr name)) + ((flet labels lambda) + (let* ((in (member :in name))) + (if (stringp (cadr in)) + (append (ldiff name in) (cddr in)) + name))) + (t + name)) + name)) + +(defun pretty-name (name) + (let ((*package* (find-package :common-lisp-user)) + (*print-right-margin* most-positive-fixnum)) + (format nil "~S" (frame-name name)))) + +(defun samples-percent (count) + (sb-sprof::samples-percent *call-graph* count)) + +(defun node-values (node) + (values (pretty-name (sb-sprof::node-name node)) + (samples-percent (sb-sprof::node-count node)) + (samples-percent (sb-sprof::node-accrued-count node)))) + +(defun filter-swank-nodes (nodes) + (let ((swank-packages (load-time-value + (mapcar #'find-package + '(swank swank/rpc swank/mop + swank/match swank/backend))))) + (remove-if (lambda (node) + (let ((name (sb-sprof::node-name node))) + (and (symbolp name) + (member (symbol-package name) swank-packages + :test #'eq)))) + nodes))) + +(defun serialize-call-graph (&key exclude-swank) + (let ((nodes (sb-sprof::call-graph-flat-nodes *call-graph*))) + (when exclude-swank + (setf nodes (filter-swank-nodes nodes))) + (setf nodes (sort (copy-list nodes) #'> + ;; :key #'sb-sprof::node-count))) + :key #'sb-sprof::node-accrued-count)) + (setf *number-nodes* (make-hash-table)) + (setf *node-numbers* (make-hash-table)) + (loop for node in nodes + for i from 1 + with total = 0 + collect (multiple-value-bind (name self cumulative) + (node-values node) + (setf (gethash node *node-numbers*) i + (gethash i *number-nodes*) node) + (incf total self) + (list i name self cumulative total)) into list + finally (return + (let ((rest (- 100 total))) + (return (append list + `((nil "Elsewhere" ,rest nil nil))))))))) + +(defslimefun swank-sprof-get-call-graph (&key exclude-swank) + (when (setf *call-graph* (sb-sprof:report :type nil)) + (serialize-call-graph :exclude-swank exclude-swank))) + +(defslimefun swank-sprof-expand-node (index) + (let* ((node (gethash index *number-nodes*))) + (labels ((caller-count (v) + (loop for e in (sb-sprof::vertex-edges v) do + (when (eq (sb-sprof::edge-vertex e) node) + (return-from caller-count (sb-sprof::call-count e)))) + 0) + (serialize-node (node count) + (etypecase node + (sb-sprof::cycle + (list (sb-sprof::cycle-index node) + (sb-sprof::cycle-name node) + (samples-percent count))) + (sb-sprof::node + (let ((name (node-values node))) + (list (gethash node *node-numbers*) + name + (samples-percent count))))))) + (list :callers (loop for node in + (sort (copy-list (sb-sprof::node-callers node)) #'> + :key #'caller-count) + collect (serialize-node node + (caller-count node))) + :calls (let ((edges (sort (copy-list (sb-sprof::vertex-edges node)) + #'> + :key #'sb-sprof::call-count))) + (loop for edge in edges + collect + (serialize-node (sb-sprof::edge-vertex edge) + (sb-sprof::call-count edge)))))))) + +(defslimefun swank-sprof-disassemble (index) + (let* ((node (gethash index *number-nodes*)) + (debug-info (sb-sprof::node-debug-info node))) + (with-output-to-string (s) + (typecase debug-info + (sb-impl::code-component + (sb-disassem::disassemble-memory (sb-vm::code-instructions debug-info) + (sb-vm::%code-code-size debug-info) + :stream s)) + (sb-di::compiled-debug-fun + (let ((component (sb-di::compiled-debug-fun-component debug-info))) + (sb-disassem::disassemble-code-component component :stream s))) + (t `(:error "No disassembly available")))))) + +(defslimefun swank-sprof-source-location (index) + (let* ((node (gethash index *number-nodes*)) + (debug-info (sb-sprof::node-debug-info node))) + (or (when (typep debug-info 'sb-di::compiled-debug-fun) + (let* ((component (sb-di::compiled-debug-fun-component debug-info)) + (function (sb-kernel::%code-entry-points component))) + (when function + (find-source-location function)))) + `(:error "No source location available")))) + +(defslimefun swank-sprof-start (&key (mode :cpu)) + (sb-sprof:start-profiling :mode mode)) + +(defslimefun swank-sprof-stop () + (sb-sprof:stop-profiling)) + +) + +(provide :swank-sprof) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-trace-dialog.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-trace-dialog.lisp new file mode 100644 index 0000000..5cf95fd --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-trace-dialog.lisp @@ -0,0 +1,264 @@ +(defpackage :swank-trace-dialog + (:use :cl) + (:import-from :swank :defslimefun :from-string :to-string) + (:export #:clear-trace-tree + #:dialog-toggle-trace + #:dialog-trace + #:dialog-traced-p + #:dialog-untrace + #:dialog-untrace-all + #:inspect-trace-part + #:report-partial-tree + #:report-specs + #:report-total + #:report-trace-detail + #:report-specs + #:trace-format + #:still-inside + #:exited-non-locally + #:*record-backtrace* + #:*traces-per-report* + #:*dialog-trace-follows-trace* + #:find-trace-part + #:find-trace)) + +(in-package :swank-trace-dialog) + +(defparameter *record-backtrace* nil + "Record a backtrace of the last 20 calls for each trace. + +Beware that this may have a drastic performance impact on your +program.") + +(defparameter *traces-per-report* 150 + "Number of traces to report to emacs in each batch.") + + +;;;; `trace-entry' model +;;;; +(defvar *traces* (make-array 1000 :fill-pointer 0 + :adjustable t)) + +(defvar *trace-lock* (swank/backend:make-lock :name "swank-trace-dialog lock")) + +(defvar *current-trace-by-thread* (make-hash-table)) + +(defclass trace-entry () + ((id :reader id-of) + (children :accessor children-of :initform nil) + (backtrace :accessor backtrace-of :initform (when *record-backtrace* + (useful-backtrace))) + + (spec :initarg :spec :accessor spec-of + :initform (error "must provide a spec")) + (args :initarg :args :accessor args-of + :initform (error "must provide args")) + (parent :initarg :parent :reader parent-of + :initform (error "must provide a parent, even if nil")) + (retlist :initarg :retlist :accessor retlist-of + :initform 'still-inside))) + +(defmethod initialize-instance :after ((entry trace-entry) &rest initargs) + (declare (ignore initargs)) + (if (parent-of entry) + (nconc (children-of (parent-of entry)) (list entry))) + (swank/backend:call-with-lock-held + *trace-lock* + #'(lambda () + (setf (slot-value entry 'id) (fill-pointer *traces*)) + (vector-push-extend entry *traces*)))) + +(defmethod print-object ((entry trace-entry) stream) + (print-unreadable-object (entry stream) + (format stream "~a: ~a" (id-of entry) (spec-of entry)))) + +(defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside))) + +(defun find-trace (id) + (when (<= 0 id (1- (length *traces*))) + (aref *traces* id))) + +(defun find-trace-part (id part-id type) + (let* ((trace (find-trace id)) + (l (and trace + (ecase type + (:arg (args-of trace)) + (:retval (swank::ensure-list (retlist-of trace))))))) + (values (nth part-id l) + (< part-id (length l))))) + +(defun useful-backtrace () + (swank/backend:call-with-debugging-environment + #'(lambda () + (loop for i from 0 + for frame in (swank/backend:compute-backtrace 0 20) + collect (list i (swank::frame-to-string frame)))))) + +(defun current-trace () + (gethash (swank/backend:current-thread) *current-trace-by-thread*)) + +(defun (setf current-trace) (trace) + (setf (gethash (swank/backend:current-thread) *current-trace-by-thread*) + trace)) + + +;;;; Control of traced specs +;;; +(defvar *traced-specs* '()) + +(defslimefun dialog-trace (spec) + (flet ((before-hook (args) + (setf (current-trace) (make-instance 'trace-entry + :spec spec + :args args + :parent (current-trace)))) + (after-hook (retlist) + (let ((trace (current-trace))) + (when trace + ;; the current trace might have been wiped away if the + ;; user cleared the tree in the meantime. no biggie, + ;; don't do anything. + ;; + (setf (retlist-of trace) retlist + (current-trace) (parent-of trace)))))) + (when (dialog-traced-p spec) + (warn "~a is apparently already traced! Untracing and retracing." spec) + (dialog-untrace spec)) + (swank/backend:wrap spec 'trace-dialog + :before #'before-hook + :after #'after-hook) + (pushnew spec *traced-specs*) + (format nil "~a is now traced for trace dialog" spec))) + +(defslimefun dialog-untrace (spec) + (swank/backend:unwrap spec 'trace-dialog) + (setq *traced-specs* (remove spec *traced-specs* :test #'equal)) + (format nil "~a is now untraced for trace dialog" spec)) + +(defslimefun dialog-toggle-trace (spec) + (if (dialog-traced-p spec) + (dialog-untrace spec) + (dialog-trace spec))) + +(defslimefun dialog-traced-p (spec) + (find spec *traced-specs* :test #'equal)) + +(defslimefun dialog-untrace-all () + (untrace) + (mapcar #'dialog-untrace *traced-specs*)) + +(defparameter *dialog-trace-follows-trace* nil) + +(setq swank:*after-toggle-trace-hook* + #'(lambda (spec traced-p) + (when *dialog-trace-follows-trace* + (cond (traced-p + (dialog-trace spec) + "traced for trace dialog as well") + (t + (dialog-untrace spec) + "untraced for the trace dialog as well"))))) + + +;;;; A special kind of trace call +;;; +(defun trace-format (format-spec &rest format-args) + "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace." + (let* ((line (apply #'format nil format-spec format-args))) + (make-instance 'trace-entry :spec line + :args format-args + :parent (current-trace) + :retlist nil))) + + +;;;; Reporting to emacs +;;; +(defparameter *visitor-idx* 0) + +(defparameter *visitor-key* nil) + +(defvar *unfinished-traces* '()) + +(defun describe-trace-for-emacs (trace) + `(,(id-of trace) + ,(and (parent-of trace) (id-of (parent-of trace))) + ,(spec-of trace) + ,(loop for arg in (args-of trace) + for i from 0 + collect (list i (swank::to-line arg))) + ,(loop for retval in (swank::ensure-list (retlist-of trace)) + for i from 0 + collect (list i (swank::to-line retval))))) + +(defslimefun report-partial-tree (key) + (unless (equal key *visitor-key*) + (setq *visitor-idx* 0 + *visitor-key* key)) + (let* ((recently-finished + (loop with i = 0 + for trace in *unfinished-traces* + while (< i *traces-per-report*) + when (completed-p trace) + collect trace + and do + (incf i) + (setq *unfinished-traces* + (remove trace *unfinished-traces*)))) + (new (loop for i + from (length recently-finished) + below *traces-per-report* + while (< *visitor-idx* (length *traces*)) + for trace = (aref *traces* *visitor-idx*) + collect trace + unless (completed-p trace) + do (push trace *unfinished-traces*) + do (incf *visitor-idx*)))) + (list + (mapcar #'describe-trace-for-emacs + (append recently-finished new)) + (- (length *traces*) *visitor-idx*) + key))) + +(defslimefun report-trace-detail (trace-id) + (swank::call-with-bindings + swank::*inspector-printer-bindings* + #'(lambda () + (let ((trace (find-trace trace-id))) + (when trace + (append + (describe-trace-for-emacs trace) + (list (backtrace-of trace) + (swank::to-line trace)))))))) + +(defslimefun report-specs () + (sort (copy-list *traced-specs*) + #'string< + :key #'princ-to-string)) + +(defslimefun report-total () + (length *traces*)) + +(defslimefun clear-trace-tree () + (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*) + *visitor-key* nil + *unfinished-traces* nil) + (swank/backend:call-with-lock-held + *trace-lock* + #'(lambda () (setf (fill-pointer *traces*) 0))) + nil) + +;; HACK: `swank::*inspector-history*' is unbound by default and needs +;; a reset in that case so that it won't error `swank::inspect-object' +;; before any other object is inspected in the slime session. +;; +(unless (boundp 'swank::*inspector-history*) + (swank::reset-inspector)) + +(defslimefun inspect-trace-part (trace-id part-id type) + (multiple-value-bind (obj found) + (find-trace-part trace-id part-id type) + (if found + (swank::inspect-object obj) + (error "No object found with ~a, ~a and ~a" trace-id part-id type)))) + +(provide :swank-trace-dialog) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-util.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-util.lisp new file mode 100644 index 0000000..72743ba --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-util.lisp @@ -0,0 +1,63 @@ +;;; swank-util.lisp --- stuff of questionable utility +;; +;; License: public domain + +(in-package :swank) + +(defmacro do-symbols* ((var &optional (package '*package*) result-form) + &body body) + "Just like do-symbols, but makes sure a symbol is visited only once." + (let ((seen-ht (gensym "SEEN-HT"))) + `(let ((,seen-ht (make-hash-table :test #'eq))) + (do-symbols (,var ,package ,result-form) + (unless (gethash ,var ,seen-ht) + (setf (gethash ,var ,seen-ht) t) + (tagbody ,@body)))))) + +(defun classify-symbol (symbol) + "Returns a list of classifiers that classify SYMBOL according to its +underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special +variable.) The list may contain the following classification +keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION, +:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE" + (check-type symbol symbol) + (flet ((type-specifier-p (s) + (or (documentation s 'type) + (not (eq (type-specifier-arglist s) :not-available))))) + (let (result) + (when (boundp symbol) (push (if (constantp symbol) + :constant :boundp) result)) + (when (fboundp symbol) (push :fboundp result)) + (when (type-specifier-p symbol) (push :typespec result)) + (when (find-class symbol nil) (push :class result)) + (when (macro-function symbol) (push :macro result)) + (when (special-operator-p symbol) (push :special-operator result)) + (when (find-package symbol) (push :package result)) + (when (and (fboundp symbol) + (typep (ignore-errors (fdefinition symbol)) + 'generic-function)) + (push :generic-function result)) + result))) + +(defun symbol-classification-string (symbol) + "Return a string in the form -f-c---- where each letter stands for +boundp fboundp generic-function class macro special-operator package" + (let ((letters "bfgctmsp") + (result (copy-seq "--------"))) + (flet ((flip (letter) + (setf (char result (position letter letters)) + letter))) + (when (boundp symbol) (flip #\b)) + (when (fboundp symbol) + (flip #\f) + (when (typep (ignore-errors (fdefinition symbol)) + 'generic-function) + (flip #\g))) + (when (type-specifier-p symbol) (flip #\t)) + (when (find-class symbol nil) (flip #\c) ) + (when (macro-function symbol) (flip #\m)) + (when (special-operator-p symbol) (flip #\s)) + (when (find-package symbol) (flip #\p)) + result))) + +(provide :swank-util) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank.rb b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank.rb new file mode 100644 index 0000000..6993649 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank.rb @@ -0,0 +1,385 @@ +# swank.rb --- swank server for Ruby. +# +# This is my first Ruby program and looks probably rather strange. Some +# people write Scheme interpreters when learning new languages, I +# write swank backends. +# +# Only a few things work. +# 1. Start the server with something like: ruby -r swank -e swank +# 2. Use M-x slime-connect to establish a connection + +require "socket" + +def swank(port=4005) + accept_connections port, false +end + +def start_swank(port_file) + accept_connections false, port_file +end + +def accept_connections(port, port_file) + server = TCPServer.new("localhost", port || 0) + puts "Listening on #{server.addr.inspect}\n" + if port_file + write_port_file server.addr[1], port_file + end + socket = begin server.accept ensure server.close end + begin + serve socket.to_io + ensure + socket.close + end +end + +def write_port_file(port, filename) + File.open(filename, File::CREAT|File::EXCL|File::WRONLY) do |f| + f.puts port + end +end + +def serve(io) + main_loop(io) +end + +def main_loop(io) + c = Connection.new(io) + while true + catch :swank_top_level do + c.dispatch(read_packet(io)) + end + end +end + +class Connection + + def initialize(io) + @io = io + end + + def dispatch(event) + puts "dispatch: %s\n" % event.inspect + case event[0] + when :":emacs-rex" + emacs_rex *event[1..4] + else raise "Unhandled event: #{event.inspect}" + end + end + + def send_to_emacs(obj) + payload = write_sexp_to_string(obj) + @io.write("%06x" % payload.length) + @io.write payload + @io.flush + end + + def emacs_rex(form, pkg, thread, id) + proc = $rpc_entries[form[0]] + args = form[1..-1]; + begin + raise "Undefined function: #{form[0]}" unless proc + value = proc[*args] + rescue Exception => exc + begin + pseudo_debug exc + ensure + send_to_emacs [:":return", [:":abort"], id] + end + else + send_to_emacs [:":return", [:":ok", value], id] + end + end + + def pseudo_debug(exc) + level = 1 + send_to_emacs [:":debug", 0, level] + sldb_info(exc, 0, 20) + begin + sldb_loop exc + ensure + send_to_emacs [:":debug-return", 0, level, :nil] + end + end + + def sldb_loop(exc) + $sldb_context = [self,exc] + while true + dispatch(read_packet(@io)) + end + end + + def sldb_info(exc, start, _end) + [[exc.to_s, + " [%s]" % exc.class.name, + :nil], + sldb_restarts(exc), + sldb_backtrace(exc, start, _end), + []] + end + + def sldb_restarts(exc) + [["Quit", "SLIME top-level."]] + end + + def sldb_backtrace(exc, start, _end) + bt = [] + exc.backtrace[start.._end].each_with_index do |frame, i| + bt << [i, frame] + end + bt + end + + def frame_src_loc(exc, frame) + string = exc.backtrace[frame] + match = /([^:]+):([0-9]+)/.match(string) + if match + file,line = match[1..2] + [:":location", [:":file", file], [:":line", line.to_i], :nil] + else + [:":error", "no src-loc for frame: #{string}"] + end + end + +end + +$rpc_entries = Hash.new + +$rpc_entries[:"swank:connection-info"] = lambda do || + [:":pid", $$, + :":package", [:":name", "ruby", :":prompt", "ruby> "], + :":lisp-implementation", [:":type", "Ruby", + :":name", "ruby", + :":version", RUBY_VERSION]] +end + +def swank_interactive_eval(string) + eval(string,TOPLEVEL_BINDING).inspect +end + +$rpc_entries[:"swank:interactive-eval"] = \ +$rpc_entries[:"swank:interactive-eval-region"] = \ +$rpc_entries[:"swank:pprint-eval"] = lambda { |string| + swank_interactive_eval string +} + +$rpc_entries[:"swank:throw-to-toplevel"] = lambda { + throw :swank_top_level +} + +$rpc_entries[:"swank:backtrace"] = lambda do |from, to| + conn, exc = $sldb_context + conn.sldb_backtrace(exc, from, to) +end + +$rpc_entries[:"swank:frame-source-location"] = lambda do |frame| + conn, exc = $sldb_context + conn.frame_src_loc(exc, frame) +end + +#ignored +$rpc_entries[:"swank:buffer-first-change"] = \ +$rpc_entries[:"swank:operator-arglist"] = lambda do + :nil +end + +$rpc_entries[:"swank:simple-completions"] = lambda do |prefix, pkg| + swank_simple_completions prefix, pkg +end + +# def swank_simple_completions(prefix, pkg) + +def read_packet(io) + header = read_chunk(io, 6) + len = header.hex + payload = read_chunk(io, len) + #$deferr.puts payload.inspect + read_sexp_from_string(payload) +end + +def read_chunk(io, len) + buffer = io.read(len) + raise "short read" if buffer.length != len + buffer +end + +def write_sexp_to_string(obj) + string = "" + write_sexp_to_string_loop obj, string + string +end + +def write_sexp_to_string_loop(obj, string) + if obj.is_a? String + string << "\"" + string << obj.gsub(/(["\\])/,'\\\\\1') + string << "\"" + elsif obj.is_a? Array + string << "(" + max = obj.length-1 + obj.each_with_index do |e,i| + write_sexp_to_string_loop e, string + string << " " unless i == max + end + string << ")" + elsif obj.is_a? Symbol or obj.is_a? Numeric + string << obj.to_s + elsif obj == false + string << "nil" + elsif obj == true + string << "t" + else raise "Can't write: #{obj.inspect}" + end +end + +def read_sexp_from_string(string) + stream = StringInputStream.new(string) + reader = LispReader.new(stream) + reader.read +end + +class LispReader + def initialize(io) + @io = io + end + + def read(allow_consing_dot=false) + skip_whitespace + c = @io.getc + case c + when ?( then read_list(true) + when ?" then read_string + when ?' then read_quote + when nil then raise EOFError.new("EOF during read") + else + @io.ungetc(c) + obj = read_number_or_symbol + if obj == :"." and not allow_consing_dot + raise "Consing-dot in invalid context" + end + obj + end + end + + def read_list(head) + list = [] + loop do + skip_whitespace + c = @io.readchar + if c == ?) + break + else + @io.ungetc(c) + obj = read(!head) + if obj == :"." + error "Consing-dot not implemented" # would need real conses + end + head = false + list << obj + end + end + list + end + + def read_string + string = "" + loop do + c = @io.getc + case c + when ?" + break + when ?\\ + c = @io.getc + case c + when ?\\, ?" then string << c + else raise "Invalid escape char: \\%c" % c + end + else + string << c + end + end + string + end + + def read_quote + [:quote, read] + end + + def read_number_or_symbol + token = read_token + if token.empty? + raise EOFError.new + elsif /^[0-9]+$/.match(token) + token.to_i + elsif /^[0-9]+\.[0-9]+$/.match(token) + token.to_f + else + token.intern + end + end + + def read_token + token = "" + loop do + c = @io.getc + if c.nil? + break + elsif terminating?(c) + @io.ungetc(c) + break + else + token << c + end + end + token + end + + def skip_whitespace + loop do + c = @io.getc + case c + when ?\s, ?\n, ?\t then next + when nil then break + else @io.ungetc(c); break + end + end + end + + def terminating?(char) + " \n\t()\"'".include?(char) + end + +end + + +class StringInputStream + def initialize(string) + @string = string + @pos = 0 + @max = string.length + end + + def pos() @pos end + + def getc + if @pos == @max + nil + else + c = @string[@pos] + @pos += 1 + c + end + end + + def readchar + getc or raise EOFError.new + end + + def ungetc(c) + if @pos > 0 && @string[@pos-1] == c + @pos -= 1 + else + raise "Invalid argument: %c [at %d]" % [c, @pos] + end + end + +end + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-autodoc-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-autodoc-tests.el new file mode 100644 index 0000000..1f4b199 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-autodoc-tests.el @@ -0,0 +1,199 @@ +(require 'slime-autodoc) +(require 'slime-tests) +(require 'cl-lib) + +(defun slime-autodoc-to-string () + "Retrieve and return autodoc for form at point." + (let ((autodoc (car (slime-eval + `(swank:autodoc + ',(slime-autodoc--parse-context) + :print-right-margin + ,(window-width (minibuffer-window))))))) + (if (eq autodoc :not-available) + :not-available + (slime-autodoc--canonicalize-whitespace autodoc)))) + +(defun slime-check-autodoc-at-point (arglist) + (slime-test-expect (format "Autodoc in `%s' (at %d) is as expected" + (buffer-string) (point)) + arglist + (slime-autodoc-to-string))) + +(defmacro define-autodoc-tests (&rest specs) + `(progn + ,@(cl-loop + for (buffer-sexpr wished-arglist . options) + in specs + for fails-for = (plist-get options :fails-for) + for skip-trailing-test-p = (plist-get options :skip-trailing-test-p) + for i from 1 + when (featurep 'ert) + collect `(define-slime-ert-test ,(intern (format "autodoc-tests-%d" i)) + () + ,(format "Check autodoc works ok for %s" buffer-sexpr) + ,@(if fails-for + `(:expected-result + '(satisfies + (lambda (result) + (ert-test-result-type-p + result + (if (member (slime-lisp-implementation-name) + ',fails-for) + :failed + :passed)))))) + (slime-sync-to-top-level 0.3) + (slime-check-top-level) + (with-temp-buffer + (setq slime-buffer-package "COMMON-LISP-USER") + (lisp-mode) + (insert ,buffer-sexpr) + (search-backward "*HERE*") + (delete-region (match-beginning 0) (match-end 0)) + (should (equal ,wished-arglist + (slime-autodoc-to-string))) + (unless ,skip-trailing-test-p + (insert ")") (backward-char) + (should (equal ,wished-arglist + (slime-autodoc-to-string))))) + (slime-sync-to-top-level 0.3))))) + +(define-autodoc-tests + ;; Test basics + ("(swank::emacs-connected*HERE*" "(emacs-connected)") + ("(swank::emacs-connected *HERE*" "(emacs-connected)") + ("(swank::create-socket*HERE*" + "(create-socket host port &key backlog)") + ("(swank::create-socket *HERE*" + "(create-socket ===> host <=== port &key backlog)") + ("(swank::create-socket foo *HERE*" + "(create-socket host ===> port <=== &key backlog)") + + ;; Test that autodoc differentiates between exported and + ;; unexported symbols. + ("(swank:create-socket*HERE*" :not-available) + + ;; Test if cursor is on non-existing required parameter + ("(swank::create-socket foo bar *HERE*" + "(create-socket host port &key backlog)") + + ;; Test cursor in front of opening parenthesis + ("(swank::with-struct *HERE*(foo. x y) *struct* body1)" + "(with-struct (conc-name &rest names) obj &body body)" + :skip-trailing-test-p t) + + ;; Test variable content display + ("(progn swank::default-server-port*HERE*" + "DEFAULT-SERVER-PORT => 4005") + + ;; Test that "variable content display" is not triggered for + ;; trivial constants. + ("(swank::create-socket t*HERE*" + "(create-socket ===> host <=== port &key backlog)") + ("(swank::create-socket :foo*HERE*" + "(create-socket ===> host <=== port &key backlog)") + + ;; Test with syntactic sugar + ("#'(lambda () (swank::create-socket*HERE*" + "(create-socket host port &key backlog)") + ("`(lambda () ,(swank::create-socket*HERE*" + "(create-socket host port &key backlog)") + ("(remove-if #'(lambda () (swank::create-socket*HERE*" + "(create-socket host port &key backlog)") + ("`(remove-if #'(lambda () ,@(swank::create-socket*HERE*" + "(create-socket host port &key backlog)") + + ;; Test &optional + ("(swank::symbol-status foo *HERE*" + "(symbol-status symbol &optional\ + ===> (package (symbol-package symbol)) <===)" :fails-for ("allegro" "ccl")) + + ;; Test context-sensitive autodoc (DEFMETHOD) + ("(defmethod swank::arglist-dispatch (*HERE*" + "(defmethod arglist-dispatch\ + (===> operator <=== arguments) &body body)") + ("(defmethod swank::arglist-dispatch :before (*HERE*" + "(defmethod arglist-dispatch :before\ + (===> operator <=== arguments) &body body)") + + ;; Test context-sensitive autodoc (APPLY) + ("(apply 'swank::eval-for-emacs*HERE*" + "(apply 'eval-for-emacs &optional form buffer-package id &rest args)") + ("(apply #'swank::eval-for-emacs*HERE*" + "(apply #'eval-for-emacs &optional form buffer-package id &rest args)" :fails-for ("ccl")) + ("(apply 'swank::eval-for-emacs foo *HERE*" + "(apply 'eval-for-emacs &optional form\ + ===> buffer-package <=== id &rest args)") + ("(apply #'swank::eval-for-emacs foo *HERE*" + "(apply #'eval-for-emacs &optional form\ + ===> buffer-package <=== id &rest args)" :fails-for ("ccl")) + + ;; Test context-sensitive autodoc (ERROR, CERROR) + ("(error 'simple-condition*HERE*" + "(error 'simple-condition &rest arguments\ + &key format-arguments format-control)" :fails-for ("ccl")) + ("(cerror \"Foo\" 'simple-condition*HERE*" + "(cerror \"Foo\" 'simple-condition\ + &rest arguments &key format-arguments format-control)" + :fails-for ("allegro" "ccl")) + + ;; Test &KEY and nested arglists + ("(swank::with-retry-restart (:msg *HERE*" + "(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)" + :fails-for ("allegro" "ccl")) + ("(swank::with-retry-restart (:msg *HERE*(foo" + "(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)" + :skip-trailing-test-p t + :fails-for ("allegro" "ccl")) + ("(swank::start-server \"/tmp/foo\" :dont-close *HERE*" + "(start-server port-file &key (style swank:*communication-style*)\ + ===> (dont-close swank:*dont-close*) <===)" + :fails-for ("allegro" "ccl")) + + ;; Test declarations and type specifiers + ("(declare (string *HERE*" + "(declare (string &rest ===> variables <===))" + :fails-for ("allegro") :fails-for ("ccl")) + ("(declare ((string *HERE*" + "(declare ((string &optional ===> size <===) &rest variables))") + ("(declare (type (string *HERE*" + "(declare (type (string &optional ===> size <===) &rest variables))") + + ;; Test local functions + ("(flet ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)") + ("(macrolet ((foo (x y) `(+ ,x ,y))) (foo *HERE*" "(foo ===> x <=== y)") + ("(labels ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)") + ("(labels ((foo (x y) (+ x y)) + (bar (y) (foo *HERE*" + "(foo ===> x <=== y)" :fails-for ("cmucl" "sbcl" "allegro" "ccl"))) + +(def-slime-test autodoc-space + (input-keys expected-message) + "Emulate the inserting something followed by the space key +event and verify that the right thing appears in the echo +area (after a short delay)." + '(("( s w a n k : : o p e r a t o r - a r g l i s t SPC" + "(operator-arglist name package)")) + (when noninteractive + (slime-skip-test "Can't use unread-command-events in batch mode")) + (let* ((keys (eval `(kbd ,input-keys))) + (tag (cons nil nil)) + (timerfun (lambda (tag) (throw tag nil))) + (timer (run-with-timer 0.1 nil timerfun tag))) + (with-temp-buffer + (lisp-mode) + (unwind-protect + (catch tag + (message nil) + (select-window (display-buffer (current-buffer) t)) + (setq unread-command-events (listify-key-sequence keys)) + (accept-process-output) + (recursive-edit)) + (setq unread-command-events nil) + (cancel-timer timer)) + (slime-test-expect "Message after SPC" + expected-message (current-message)) + (accept-process-output nil (* eldoc-idle-delay 2)) + (slime-test-expect "Message after edloc delay" + expected-message (current-message))))) + +(provide 'slime-autodoc-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-c-p-c-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-c-p-c-tests.el new file mode 100644 index 0000000..772cc40 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-c-p-c-tests.el @@ -0,0 +1,140 @@ +(require 'slime-c-p-c) +(require 'slime-tests) + +(def-slime-test completions + (prefix expected-completions) + "Find the completions of a symbol-name prefix." + '(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname" + "cl:compiled-function" "cl:compiled-function-p" + "cl:compiler-macro" "cl:compiler-macro-function") + "cl:compile")) + ("cl:foobar" nil) + ("swank::compile-file" (("swank::compile-file" + "swank::compile-file-for-emacs" + "swank::compile-file-if-needed" + "swank::compile-file-output" + "swank::compile-file-pathname") + "swank::compile-file")) + ("cl:m-v-l" (("cl:multiple-value-list" "cl:multiple-values-limit") "cl:multiple-value")) + ("common-lisp" (("common-lisp-user:" "common-lisp:") "common-lisp"))) + (let ((completions (slime-completions prefix))) + (slime-test-expect "Completion set" expected-completions completions))) + +(def-slime-test complete-symbol* + (buffer-sexp wished-completion &optional chosen-completion fancy unambiguous) + "Ensure that completions are correctly inserted." + '(("cl:and" "cl:and") + ("(cl:and" "(cl:and") + ("(cl:and)" "(cl:and)") + ("(cl:and)" "(cl:and)" nil nil t) + ;; Fancy completion of a form that accepts arguments should + ;; insert a space after the completed form. + ("(cl:and)" "(cl:and )" nil t) + ;; ...but only for symbols in the funcall position. + ("cl:and" "cl:and" nil t) + ;; Fancy completion of a form without arguments should insert a + ;; closing paren. + ("(cl:get-internal-run-time" "(cl:get-internal-run-time)" nil t) + ;; ...but only for symbols in the funcall position. + ("cl:get-internal-run-time" "cl:get-internal-run-time" nil t) + ("cl:m-v-b" "cl:multiple-value-bind") + ("cl:m-v-l" "cl:multiple-value-list" "cl:multiple-value-list") + ;; Fancy completion is only done for unique completions. This is + ;; not a hard requirement, and might change in the future. This + ;; test is included merely to document the current behavior. + ("(cl:m-v-l)" "(cl:multiple-value-list)" "cl:multiple-value-list" t) + ("cl:mult" "cl:multiple-value-call" "cl:multiple-value-call") + ("cl:multiple-value" "cl:multiple-value-setq" "cl:multiple-value-setq") + ("cl:compile" "cl:compile" "cl:compile") + ("cl:compile" "cl:compile-file" "cl:compile-file") + ("cl:f-o" "cl:force-output" "cl:force-output") + ;; When `slime-c-p-c-unambiguous-prefix-p' is non nil, + ;; `slime-complete-symbol*' will move point back to the + ;; unambiguous portion of the prefix; however, the final result + ;; after choosing a completion candidate should be the same. + ("cl:f-o" "cl:force-output" "cl:force-output" nil t) + ("(cl:f-o)" "(cl:force-output)" "cl:force-output" nil t) + ;; Character completions + ("#\\N" "#\\Newline") + ("#\\R" "#\\Return" "#\\Return") + ("#\\R" "#\\Rubout" "#\\Rubout" nil t) + ;; Keyword completions + ("(cl:find 'x '() :)" "(cl:find 'x '() :START)" ":START") + ("(cl:find 'x '() :S)" "(cl:find 'x '() :START)") + ("(cl:find 'x '() :s)" "(cl:find 'x '() :start)") + ("(cl:find 'x '() :s)" "(cl:find 'x '() :start)" nil t) + ("(cl:find 'x '() :t)" "(cl:find 'x '() :test)" ":test") + ("(cl:find 'x '() :t)" "(cl:find 'x '() :test-not)" ":test-not" nil t)) + (slime-check-top-level) + (save-window-excursion + (with-temp-buffer + (lisp-mode) + (setq slime-buffer-package "SWANK") + (insert buffer-sexp) + (when (eq (char-before) ?\)) + (backward-char)) + (let ((slime-c-p-c-unambiguous-prefix-p unambiguous) + (slime-complete-symbol*-fancy fancy)) + (if (not fancy) + (slime-complete-symbol*) + ;; `slime-complete-symbol*-fancy-bit' may call + ;; `execute-kbd-macro', which ultimately operates on the + ;; buffer associated with the selected window, not + ;; necessarily the current buffer. Call `pop-to-buffer' to + ;; ensure that the current buffer is in the selected window + ;; before calling `slime-complete-symbol*'. Fancy completion + ;; might also kick off a `slime-eval-async' in + ;; `slime-echo-arglist', so ensure the output is consumed + ;; with `slime-sync-to-top-level' before continuing. + (pop-to-buffer (current-buffer)) + (slime-complete-symbol*) + (slime-sync-to-top-level 1))) + (when chosen-completion + (with-selected-window slime-completions-window + (goto-char (point-min)) + (search-forward chosen-completion) + (choose-completion))) + (slime-check-completed-form buffer-sexp wished-completion)))) + +(def-slime-test complete-form + (buffer-sexpr wished-completion &optional skip-trailing-test-p) + "" + '(("(defmethod arglist-dispatch *HERE*" + "(defmethod arglist-dispatch (operator arguments) body...)") + ("(with-struct *HERE*" + "(with-struct (conc-name names...) obj body...)") + ("(with-struct *HERE*" + "(with-struct (conc-name names...) obj body...)") + ("(with-struct (*HERE*" + "(with-struct (conc-name names...)" t) + ("(with-struct (foo. bar baz *HERE*" + "(with-struct (foo. bar baz names...)" t)) + (slime-check-top-level) + (with-temp-buffer + (lisp-mode) + (setq slime-buffer-package "SWANK") + (insert buffer-sexpr) + (search-backward "*HERE*") + (delete-region (match-beginning 0) (match-end 0)) + (slime-complete-form) + (slime-check-completed-form buffer-sexpr wished-completion) + + ;; Now the same but with trailing `)' for paredit users... + (unless skip-trailing-test-p + (erase-buffer) + (insert buffer-sexpr) + (search-backward "*HERE*") + (delete-region (match-beginning 0) (match-end 0)) + (insert ")") (backward-char) + (slime-complete-form) + (slime-check-completed-form (concat buffer-sexpr ")") wished-completion)) + )) + +(defun slime-check-completed-form (buffer-sexpr wished-completion) + (slime-test-expect (format "Completed form for `%s' is as expected" + buffer-sexpr) + wished-completion + (buffer-string) + 'equal)) + +(provide 'slime-c-p-c-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-cl-indent-test.txt b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-cl-indent-test.txt new file mode 100644 index 0000000..71f8744 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-cl-indent-test.txt @@ -0,0 +1,1006 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; This file is .txt, because it's not meant to be evaluated. +;;;; common-lisp-run-indentation-tests in slime-cl-ident.el +;;;; parses this and runs the specified tests. + +;;; Test: indent-1 + +(defun foo () + t) + +;;; Test: indent-2 +;; +;; lisp-lambda-list-keyword-parameter-alignment: nil +;; lisp-lambda-list-keyword-alignment: nil + +(defun foo (foo &optional opt1 + opt2 + &rest rest) + (list foo opt1 opt2 + rest)) + +;;; Test: indent-3 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: nil + +(defun foo (foo &optional opt1 + opt2 + &rest rest) + (list foo opt1 opt2 + rest)) + +;;; Test: indent-4 +;; +;; lisp-lambda-list-keyword-parameter-alignment: nil +;; lisp-lambda-list-keyword-alignment: t + +(defun foo (foo &optional opt1 + opt2 + &rest rest) + (list foo opt1 opt2 + rest)) + +;;; Test: indent-5 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defun foo (foo &optional opt1 + opt2 + &rest rest) + (list foo opt1 opt2 + rest)) + +;;; Test: indent-6 +;; +;; lisp-lambda-list-keyword-parameter-alignment: nil +;; lisp-lambda-list-keyword-alignment: nil + +(defmacro foo ((foo &optional opt1 + opt2 + &rest rest)) + (list foo opt1 opt2 + rest)) + +;;; Test: indent-7 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: nil + +(defmacro foo ((foo &optional opt1 + opt2 + &rest rest)) + (list foo opt1 opt2 + rest)) + +;;; Test: indent-8 +;; +;; lisp-lambda-list-keyword-parameter-alignment: nil +;; lisp-lambda-list-keyword-alignment: t + +(defmacro foo ((foo &optional opt1 + opt2 + &rest rest)) + (list foo opt1 opt2 + rest)) + +;;; Test: indent-9 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defmacro foo ((foo &optional opt1 + opt2 + &rest rest)) + (list foo opt1 opt2 + rest)) + +;;; Test: indent-10 + +(let ((x y) + (foo #-foo (no-foo) + #+foo (yes-foo)) + (bar #-bar + (no-bar) + #+bar + (yes-bar))) + (list foo bar + x)) + +;;; Test: indent-11 +;; +;; lisp-loop-indent-subclauses: t + +(loop for i from 0 below 2 + for j from 0 below 2 + when foo + do (fubar) + (bar) + (moo) + and collect cash + into honduras + else do ;; this is the body of the first else + ;; the body is ... + (indented to the above comment) + (ZMACS gets this wrong) + and do this + and do that + and when foo + do the-other + and cry + when this-is-a-short-condition do + (body code of the when) + when here's something I used to botch do (here is a body) + (rest of body indented same) + do + (exdented loop body) + (I'm not sure I like this but it's compatible) + when funny-predicate do ;; Here's a comment + (body filled to comment)) + +;;; Test: indent-12 + +(defun foo (x) + (tagbody + foo + (bar) + baz + (when (losing) + (with-big-loser + (yow) + ((lambda () + foo) + big))) + (flet ((foo (bar baz zap) + (zip)) + (zot () + quux)) + (do () + ((lose) + (foo 1)) + (quux) + foo + (lose)) + (cond ((x) + (win 1 2 + (foo))) + (t + (lose + 3)))))) + +;;; Test: indent-13 + +(if* (eq t nil) + then () + () + elseif (dsf) + thenret x + else (balbkj) + (sdf)) + +;;; Test: indent-14 + +(list foo #+foo (foo) + #-foo (no-foo)) + +;;; Test: indent-15 +;; +;; lisp-loop-indent-subclauses: t + +(loop for x in foo1 + for y in quux1 + ) + +;;; Test: indent-16 +;; +;; lisp-loop-indent-subclauses: nil + +(loop for x in foo1 + for y in quux1 + ) + +;;; Test: indent-17 +;; +;; lisp-loop-indent-subclauses: nil +;; lisp-loop-indent-forms-like-keywords: t + +(loop for x in foo + for y in quux + finally (foo) + (fo) + (zoo) + do + (print x) + (print y) + (print 'ok!)) + +;;; Test: indent-18 +;; +;; lisp-loop-indent-subclauses: nil +;; lisp-loop-indent-forms-like-keywords: nil + +(loop for x in foo + for y in quux + finally (foo) + (fo) + (zoo) + do + (print x) + (print y) + (print 'ok!)) + +;;; Test: indent-19 +;; +;; lisp-loop-indent-subclauses: t +;; lisp-loop-indent-forms-like-keywords: nil + +(loop for x in foo + for y in quux + finally (foo) + (fo) + (zoo) + do + (print x) + (print y) + (print 'ok!)) + +;;; Test: indent-20 +;; +;; lisp-loop-indent-subclauses: nil +;; lisp-loop-indent-forms-like-keywords: nil + +(loop for f in files + collect (open f + :direction :output) + do (foo) (bar) + (quux)) + +;;; Test: indent-21 +;; +;; lisp-loop-indent-subclauses: t + +(loop for f in files + collect (open f + :direction :output) + do (foo) (bar) + (quux)) + +;;; Test: indent-22 + +(defsetf foo bar + "the doc string") + +;;; Test: indent-23 + +(defsetf foo + bar + "the doc string") + +;;; Test: indent-24 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t + +(defsetf foo (x y &optional a + z) + (a b c) + stuff) + +;;; Test: indent-25 +;; +;; lisp-align-keywords-in-calls: t + +(make-instance 'foo :bar t :quux t + :zot t) + +;;; Test: indent-26 +;; +;; lisp-align-keywords-in-calls: nil + +(make-instance 'foo :bar t :quux t + :zot t) + +;;; Test: indent-27 +;; +;; lisp-lambda-list-indentation: nil + +(defun example (a b &optional o1 o2 + o3 o4 + &rest r + &key k1 k2 + k3 k4) + 'hello) + +;;; Test: indent-28 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(destructuring-bind (foo &optional x + y + &key bar + quux) + foo + body) + +;;; Test: indent-29 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(named-lambda foo + (x &optional y + z + &rest more) + body) + +;;; Test: indent-30 + +(foo fii + (or x + y) t + bar) + +;;; Test: indent-31 + +(foo + (bar)) + +;;; Test: indent-32 +;; +;; comment-indent-function: (lambda () nil) +;; comment-column: nil + +(unknown (;; KLUDGE: comment-indent hackery to get + ;; the comment right. Otherwise we get a + ;; space before the first ;. + bar quux + zot) + (#|fii|# + zot) + ( + quux)) + +;;; Test: indent-33 + +(complex-indent.1 ((x z + f + ((fox foo + foo)) + :note (ding bar quux + zot) + :wait (this! is + a funcall)) + ;; Not 100% sure this should not be a step left. + (abbb) + (abb)) + (bodyform) + (another)) + +;;; Test: indent-34 + +(complex-indent.2 (bar quux + zot) + (a b + c d) + (form1) + (form2)) + +;;; Test: indent-35 + +(complex-indent.3 (:wait fii + (this is + a funcall)) + (bodyform) + (another)) + +;;; Test: indent-36 + +(defmacro foo (body) + `(let (,@(stuff) + ,(more-stuff) + ,(even-more) + (foo foo)) + ,@bofy)) + +;;; Test: indent-37 + +(defun foo () + `(list foo bar + ,@(quux fo + foo))) + +;;; Test: indent-38 + +(defmacro foofoo (body) + `(foo + `(let (,',@,(stuff) + ,(more-stuff) + ,(even-more) + (foo foo)) + ,@bofy))) + +;;; Test: indent-39 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defstruct (foo (:constructor make-foo (&optional bar + quux + &key zot + fii))) + bar + quux + zot + fii) + +;;; Test: indent-40 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defmethod foo :around (zot &key x + y) + (list zot)) + +;;; Test: indent-41 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(progn + (defmethod foo :around (fii &key x + y) + (list fii))) + +;;; Test: indent-42 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(progn + (defgeneric foo (x y &optional a + b) + (:method :around (a b &optional x + y) + (list a b x y)))) + +;;; Test: indent-43 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defgeneric foo (x &optional a b) + (:method (x y &optional a + b) + (list x y a b))) + +;;; Test: indent-44 + +(let (definer + foo + bar + quux) + ...) + +;;; Test: indent-45 + +(let (definition + foo + bar + quux) + ...) + +;;; Test: indent-46 + +(let (foo bar + quux) + ...) + +;;; Test: indent-47 + +(with-compilation-unit + (:foo t + :quux nil) + ...) + +;;; Test: indent-48 + +(cond + ((> x y) (foo) + ;; This isn't ideal -- I at least would align with (FOO here. + (bar) (quux) + (zot)) + (qux (foo) + (bar) + (zot)) + (zot + (foo) + (foo2)) + (t (foo) + (bar))) + +;;; Test: indent-49 + +(cond ((> x y) (foo) + ;; This isn't ideal -- I at least would align with (FOO here. + (bar)) + (qux (foo) + (bar)) + (zot + (foo)) + (t (foo) + (bar))) + +;;; Test: indent-50 +;; +;; lisp-lambda-list-keyword-parameter-alignment: nil +;; lisp-lambda-list-keyword-alignment: nil + +(defun foo (x &optional opt1 + opt2 + &rest rest + &allow-other-keys) + (list opt1 opt2 + rest)) + +;;; Test: indent-51 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: nil + +(defun foo (x &optional opt1 + opt2 + &rest rest + &allow-other-keys) + (list opt1 opt2 + rest)) + +;;; Test: indent-52 +;; +;; lisp-lambda-list-keyword-parameter-alignment: nil +;; lisp-lambda-list-keyword-alignment: t + +(defun foo (x &optional opt1 + opt2 + &rest rest + &allow-other-keys) + (list opt1 opt2 + rest)) + +;;; Test: indent-53 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defun foo (x &optional opt1 + opt2 + &rest rest + &allow-other-keys) + (list opt1 opt2 + rest)) + +;;; Test: indent-54 +;; + +(loop (foo) + ;; comment + (bar) + (quux)) + +;;; Test: indent-55 +;; + +(loop ;; comment + (foo) + (bar)) + +;;; Test: indent-56 +;; + +(loop + (foo) + ;; comment + (bar)) + + +;;; Test: indent-57 +;; + +(loop + ;; comment + (foo) + (bar)) + +;;; Test: indent-58 +;; +;; lisp-loop-indent-subclauses: t + +(loop ;; comment at toplevel of the loop + with foo = t + do (foo foo) + (foo)) + +;;; Test: indent-59 +;; +;; lisp-loop-indent-subclauses: nil + +(loop ;; comment at toplevel of the loop + with foo = t + do (foo foo) + (foo)) + +;;; Test: indent-60 +;; +;; lisp-loop-indent-subclauses: t + +(loop + ;; comment at toplevel of the loop + with foo = t + do (foo foo)) + +;;; Test: indent-61 +;; +;; lisp-loop-indent-subclauses: nil + +(loop + ;; comment at toplevel of the loop + with foo = t + do (foo foo) + (foo)) + +;;; Test: indent-62 +;; +;; lisp-loop-indent-subclauses: t + +(loop with foo = t + do (foo foo) + ;; comment inside clause + (bar)) + +;;; Test: indent-63 +;; +;; lisp-loop-indent-subclauses: nil + +(loop with foo = t + do (foo foo) + ;; comment inside clause + (bar)) + + +;;; Test: indent-64 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defmethod (setf foo) :around (zot &key x + y) + (list zot)) + +;;; Test: indent-65 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defmethod (setf foo) + :around (zot &key x y) + (list zot)) + +;;; Test: indent-66 +;; + +(define-condition + foo + (bar quux + zot) + () + (:report "foo")) + +;;; Test: indent-67 +;; + +(defclass + foo + (bar quxx + xoo) + () + (:metaclass foo-class)) + + +;;; Test: indent-68 +;; +;; lisp-loop-indent-subclauses: nil + +(progn + (loop + repeat 1000 + do ;; This is the + ;; beginning + (foo)) + (loop repeat 100 ;; This too + ;; is a beginning + do (foo))) + +;;; Test: indent-69 +;; +;; lisp-loop-indent-subclauses: t + +(progn + (loop + repeat 1000 + do ;; This is the + ;; beginning + (foo)) + (loop repeat 100 ;; This too + ;; is a beginning + do (foo))) + +;;; Test: indent-70 +;; +;; lisp-loop-indent-subclauses: nil + +(progn + (loop + :repeat 1000 + #:do ;; This is the + ;; beginning + (foo)) + (loop #:repeat 100 ;; This too + ;; is a beginning + :do (foo))) + +;;; Test: indent-71 +;; +;; lisp-loop-indent-subclauses: t + +(progn + (loop + #:repeat 1000 + #:do ;; This is the + ;; beginning + (foo)) + (loop :repeat 100 ;; This too + ;; is a beginning + #:do (foo))) + +;;; Test: indent-72 +;; +;; lisp-lambda-list-keyword-parameter-alignment: nil +;; lisp-lambda-list-keyword-alignment: nil + +(flet ((foo (foo &optional opt1 + opt2 + &rest rest) + (list foo opt1 opt2 + rest))) + ...) + +;;; Test: indent-73 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: nil + +(flet ((foo (foo &optional opt1 + opt2 + &rest rest) + (list foo opt1 opt2 + rest))) + ...) + +;;; Test: indent-74 +;; +;; lisp-lambda-list-keyword-parameter-alignment: nil +;; lisp-lambda-list-keyword-alignment: t + +(flet ((foo (foo &optional opt1 + opt2 + &rest rest) + (list foo opt1 opt2 + rest))) + ...) + +;;; Test: indent-75 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(flet ((foo (foo &optional opt1 + opt2 + &rest rest) + (list foo opt1 opt2 + rest))) + ...) + +;;; Test: indent-76 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(macrolet ((foo + (foo (&optional xopt1 + xopt2 + &rest xrest) + &optional opt1 + opt2 + &rest rest) + (list foo opt1 opt2 + rest))) + ...) + +;;; Test: indent-77 +;; +;; lisp-align-keywords-in-calls: t + +(foo *foo* + :bar t + :quux #+quux t + #-quux nil + :zot t) + +;;; Test: indent-78 +;; +;; lisp-align-keywords-in-calls: t + +(foo *foo* :fii t + :bar t + :quux #+quux t + #+zot nil + :zot t) + +;;; Test: indent-79 + +(foo #+quux :quux #+quux t + #-quux :zoo #-quux t) + +;;; Test: indent-80 +;; +;; lisp-align-keywords-in-calls: t + +(foo *foo* :fii t + :bar t + #+quux :quux #+quux t + :zot t) + +;;; Test: indent-81 +;; +;; lisp-align-keywords-in-calls: t + +(foo *foo* :fii t + :bar t + #+quux #+quux :quux t + :zot t) + +;;; Test: indent-82 +;; +;; lisp-align-keywords-in-calls: t + +(foo *foo* :fii t + :bar t + #+quux + :quux #+quux t + :zot t) + +;;; Test: indent-83 +;; +;; lisp-align-keywords-in-calls: t + +(foo *foo* :fii t + :bar t + #+quux #+quux + :quux t + :zot t) + +;;; Test: indent-84 + +(and ;; Foo + (something) + ;; Quux + (more)) + +;;; Test: indent-85 + +(and ;; Foo + (something) + ;; Quux + (more)) + +;;; Test: indent-86 + +(foo ( + bar quux + zor)) + +;;; Test: indent-87 +;; +;; lisp-lambda-list-keyword-parameter-alignment: t +;; lisp-lambda-list-keyword-alignment: t + +(defmacro foo ((foo &optional (opt1 (or (this) + (that))) + (opt2 (the-default) + opt2-p) + (opt3 + (the-default (foo) + (bar))) + &rest rest)) + (list foo opt1 opt2 + rest)) + +;;; Test: indent-88 + +(defstruct (foo + (:constructor make-foo + (bar &aux (quux (quux-from-bar bar + :for 'foo))))) + bar + quux) + +;;; Test: indent-89 + +(define-tentative-thing foo + (bar) + quux) + +;;; Test: indent-90 + +(define-tentative-thing foo + bar + quux) + +;;; Test: indent-91 +;; +;; lisp-loop-indent-body-forms-relative-to-loop-start: t + +(loop for foo in bar + do + (progn foo + bar + baz)) + +;;; Test: indent-92 +;; +;; lisp-loop-indent-body-forms-relative-to-loop-start: t +;; lisp-loop-clauses-indentation: 4 + +(loop + for foo in bar + do + (progn foo + bar + baz)) + +;;; Test: indent-93 +;; +;; lisp-loop-clauses-indentation: 4 + +(loop + for foo in bar + doing + (progn foo + bar + baz)) + +;;; Test: indent-94 +;; +;; lisp-loop-clauses-indentation: 4 +;; lisp-loop-body-forms-indentation: 1 + +(loop + for foo in bar + doing + (list foo + bar + baz)) + +;;; Test: indent-95 +;; +;; lisp-loop-body-forms-indentation: 1 +;; lisp-loop-indent-body-forms-relative-to-loop-start: t + +(loop + for foo in bar + do + (list foo + bar + baz)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-enclosing-context-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-enclosing-context-tests.el new file mode 100644 index 0000000..41f50a7 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-enclosing-context-tests.el @@ -0,0 +1,46 @@ +(require 'slime-enclosing-context) +(require 'slime-tests) +(require 'cl-lib) + +(def-slime-test enclosing-context.1 + (buffer-sexpr wished-bound-names wished-bound-functions) + "Check that finding local definitions work." + '(("(flet ((,nil ())) + (let ((bar 13) + (,foo 42)) + *HERE*))" + ;; We used to return ,foo here, but we do not anymore. We + ;; still return ,nil for the `slime-enclosing-bound-functions', + ;; though. The first one is used for local M-., whereas the + ;; latter is used for local autodoc. It does not seem too + ;; important for local M-. to work on such names. \(The reason + ;; that it does not work anymore, is that + ;; `slime-symbol-at-point' now does TRT and does not return a + ;; leading comma anymore.\) + ("bar" nil nil) + ((",nil" "()"))) + ("(flet ((foo ())) + (quux) + (bar *HERE*))" + ("foo") + (("foo" "()")))) + (slime-check-top-level) + (with-temp-buffer + (let ((tmpbuf (current-buffer))) + (lisp-mode) + (insert buffer-sexpr) + (search-backward "*HERE*") + (cl-multiple-value-bind (bound-names points) + (slime-enclosing-bound-names) + (slime-check "Check enclosing bound names" + (cl-loop for name in wished-bound-names + always (member name bound-names)))) + (cl-multiple-value-bind (fn-names fn-arglists points) + (slime-enclosing-bound-functions) + (slime-check "Check enclosing bound functions" + (cl-loop for (name arglist) in wished-bound-functions + always (and (member name fn-names) + (member arglist fn-arglists))))) + ))) + +(provide 'slime-enclosing-context-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-fontifying-fu-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-fontifying-fu-tests.el new file mode 100644 index 0000000..9bc99af --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-fontifying-fu-tests.el @@ -0,0 +1,120 @@ +(require 'slime-fontifying-fu) +(require 'slime-tests) + +(def-slime-test font-lock-magic (buffer-content) + "Some testing for the font-lock-magic. *YES* should be + highlighted as a suppressed form, *NO* should not." + + '(("(defun *NO* (x y) (+ x y))") + ("(defun *NO*") + ("*NO*) #-(and) (*YES*) (*NO* *NO*") + ("\( +\(defun *NO*") + ("\) +\(defun *NO* + \( +\)") + ("#+#.foo +\(defun *NO* (x y) (+ x y))") + ("#+#.foo +\(defun *NO* (x ") + ("#+( +\(defun *NO* (x ") + ("#+(test) +\(defun *NO* (x ") + + ("(eval-when (...) +\(defun *NO* (x ") + + ("(eval-when (...) +#+(and) +\(defun *NO* (x ") + + ("#-(and) (defun *YES* (x y) (+ x y))") + (" +#-(and) (defun *YES* (x y) (+ x y)) +#+(and) (defun *NO* (x y) (+ x y))") + + ("#+(and) (defun *NO* (x y) #-(and) (+ *YES* y))") + ("#| #+(or) |# *NO*") + ("#| #+(or) x |# *NO*") + ("*NO* \"#| *NO* #+(or) x |# *NO*\" *NO*") + ("#+#.foo (defun foo (bar)) +#-(and) *YES* *NO* bar +") + ("#+(foo) (defun foo (bar)) +#-(and) *YES* *NO* bar") + ("#| #+(or) |# *NO* foo +#-(and) *YES* *NO*") + ("#- (and) +\(*YES*) +\(*NO*) +#-(and) +\(*YES*) +\(*NO*)") + ("#+nil (foo) + +#-(and) +#+nil ( + asdf *YES* a + fsdfad) + +\( asdf *YES* + + ) +\(*NO*) + +") + ("*NO* + +#-(and) \(progn + #-(and) + (defun *YES* ...) + + #+(and) + (defun *YES* ...) + + (defun *YES* ...) + + *YES* + + *YES* + + *YES* + + *YES* +\) + +*NO*") + ("#-(not) *YES* *NO* + +*NO* + +#+(not) *NO* *NO* + +*NO* + +#+(not a b c) *NO* *NO* + +*NO*")) + (slime-check-top-level) + (with-temp-buffer + (insert buffer-content) + (slime-initialize-lisp-buffer-for-test-suite + :autodoc t :font-lock-magic t) + ;; Can't use `font-lock-fontify-buffer' because for the case when + ;; `jit-lock-mode' is enabled. Jit-lock-mode fontifies only on + ;; actual display. + (font-lock-default-fontify-buffer) + (when (search-backward "*NO*" nil t) + (slime-test-expect "Not suppressed by reader conditional?" + 'slime-reader-conditional-face + (get-text-property (point) 'face) + #'(lambda (x y) (not (eq x y))))) + (goto-char (point-max)) + (when (search-backward "*YES*" nil t) + (slime-test-expect "Suppressed by reader conditional?" + 'slime-reader-conditional-face + (get-text-property (point) 'face))))) + +(provide 'slime-fontifying-fu-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-indentation-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-indentation-tests.el new file mode 100644 index 0000000..ad1e2c5 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-indentation-tests.el @@ -0,0 +1,81 @@ +(require 'slime-indentation) +(require 'slime-tests) + +(define-common-lisp-style "common-lisp-indent-test" + ;; Used to specify a few complex indentation specs for testing. + (:inherit "basic") + (:indentation + (complex-indent.1 ((&whole 4 (&whole 1 1 1 1 (&whole 1 1) &rest 1) + &body) &body)) + (complex-indent.2 (4 (&whole 4 &rest 1) &body)) + (complex-indent.3 (4 &body)))) + +(defun slime-indentation-mess-up-indentation () + (while (not (eobp)) + (forward-line 1) + (unless (looking-at "^$") + (cl-case (random 2) + (0 + ;; Delete all leading whitespace -- except for + ;; comment lines. + (while (and (looking-at " ") (not (looking-at " ;"))) + (delete-char 1))) + (1 + ;; Insert whitespace random. + (let ((n (1+ (random 24)))) + (while (> n 0) (cl-decf n) (insert " "))))))) + (buffer-string)) + +(eval-and-compile + (defun slime-indentation-test-form (test-name bindings expected) + `(define-slime-ert-test ,test-name () + ,(format "An indentation test named `%s'" test-name) + (with-temp-buffer + (lisp-mode) + (setq indent-tabs-mode nil) + (common-lisp-set-style "common-lisp-indent-test") + (let ,(cons `(expected ,expected) bindings) + (insert expected) + (goto-char (point-min)) + (let ((mess (slime-indentation-mess-up-indentation))) + (when (string= mess expected) + (ert-fail "Could not mess up indentation?")) + (indent-region (point-min) (point-max)) + (delete-trailing-whitespace) + (should (equal expected (buffer-string)))))))) + + (defun slime-indentation-test-forms-for-file (file) + (with-current-buffer + (find-file-noselect (concat slime-path + "/contrib/test/slime-cl-indent-test.txt")) + (goto-char (point-min)) + (cl-loop + while (re-search-forward ";;; Test:[\t\n\s]*\\(.*\\)[\t\n\s]" nil t) + for test-name = (intern (match-string-no-properties 1)) + for bindings = + (save-restriction + (narrow-to-region (point) + (progn (forward-comment + (point-max)) + (point))) + (save-excursion + (goto-char (point-min)) + (cl-loop while + (re-search-forward + "\\([^\s]*\\)[\t\n\s]*:[\t\n\s]*\\(.*\\)[\t\n\s]" nil t) + collect (list + (intern (match-string-no-properties 1)) + (car + (read-from-string (match-string-no-properties 2))))))) + for expected = (buffer-substring-no-properties (point) + (scan-sexps (point) + 1)) + collect (slime-indentation-test-form test-name bindings expected))))) + +(defmacro slime-indentation-define-tests () + `(progn + ,@(slime-indentation-test-forms-for-file "slime-cl-indent-test.txt"))) + +(slime-indentation-define-tests) + +(provide 'slime-indentation-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-macrostep-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-macrostep-tests.el new file mode 100644 index 0000000..3ceadd8 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-macrostep-tests.el @@ -0,0 +1,287 @@ +;; Tests for slime-macrostep. The following are expected failures: + +;; - Under CLISP, highlighting of macro sub-forms fails because our +;; pretty-printer dispatch table hacking causes infinite recursion: +;; see comment in swank-macrostep.lisp + +;; - COLLECT-MACRO-FORMS does not catch compiler macros under CLISP +;; and ABCL + +;; - Under CCL and ECL, compiler macro calls returned by +;; COLLECT-MACRO-FORMS are not EQ to the original form, and so are +;; not detected by the tracking pretty-printer mechanism. This +;; could be fixed by adding :TEST #'EQUAL to the POSITION call +;; within MAKE-TRACKING-PPRINT-DISPATCH, at the cost of introducing +;; false positives. + +;; ECL has two other issues: + +;; - it currently lacks a working SLIME defimplementation for +;; MACROEXPAND-ALL (Github issue #157), without which none of the +;; expand-in-context stuff works. + +;; - the environments consed up by its WALKER:MACROEXPAND-ALL +;; function are slightly broken, and do not work when passed to +;; MACROEXPAND-1 unless fixed up via + +;; (subst 'si::macro 'walker::macro env) + +(require 'slime-macrostep) +(require 'slime-tests) +(require 'cl-lib) + +(defun slime-macrostep-eval-definitions (definitions) + (slime-check-top-level) + (slime-compile-string definitions 0) + (slime-sync-to-top-level 5)) + +(defmacro slime-macrostep-with-text (buffer-text &rest body) + (declare (indent 1)) + `(with-temp-buffer + (lisp-mode) + (save-excursion + (insert ,buffer-text)) + ,@body)) + +(defun slime-macrostep-search (form) + "Search forward for FORM, leaving point at its first character." + (let ((case-fold-search t) + (search-spaces-regexp "\\s-+")) + (re-search-forward (regexp-quote form))) + (goto-char (match-beginning 0))) + + + +(def-slime-test (slime-macrostep-expand-defmacro) + (definition buffer-text original expansion) + "Test that simple macrostep expansion works." + '(("(defmacro macrostep-dummy-macro (&rest args) + `(expansion of ,@args))" + + "(progn + (first body form) + (second body form) + (macrostep-dummy-macro (first (argument)) second (third argument)) + (remaining body forms))" + + "(macrostep-dummy-macro (first (argument)) second (third argument))" + + "(expansion of (first (argument)) second (third argument))")) + (slime-macrostep-eval-definitions definition) + (slime-macrostep-with-text buffer-text + (slime-macrostep-search original) + (macrostep-expand) + (slime-test-expect "Macroexpansion is correct" + expansion + (downcase (slime-sexp-at-point)) + #'slime-test-macroexpansion=))) + +(def-slime-test (slime-macrostep-fontify-macros + (:fails-for "clisp" "ECL")) + (definition buffer-text original subform) + "Test that macro forms in expansions are font-locked" + '(("(defmacro macrostep-dummy-1 (&rest args) + `(expansion including (macrostep-dummy-2 ,@args))) + (defmacro macrostep-dummy-2 (&rest args) + `(final expansion of ,@args))" + + "(progn + (first body form) + (second body form) + (macrostep-dummy-1 (first (argument)) second (third argument)) + (remaining body forms))" + + "(macrostep-dummy-1 (first (argument)) second (third argument))" + + "(macrostep-dummy-2 (first (argument)) second (third argument))")) + (slime-macrostep-eval-definitions definition) + (slime-macrostep-with-text buffer-text + (slime-macrostep-search original) + (macrostep-expand) + (slime-macrostep-search subform) + (forward-char) ; move over open paren + (slime-check "Head of macro form in expansion is fontified correctly" + (eq (get-char-property (point) 'font-lock-face) + 'macrostep-macro-face)))) + +(def-slime-test (slime-macrostep-fontify-compiler-macros + (:fails-for "armedbear" "clisp" "ccl" "ECL")) + (definition buffer-text original subform) + "Test that compiler-macro forms in expansions are font-locked" + '(("(defmacro macrostep-dummy-3 (&rest args) + `(expansion including (macrostep-dummy-4 ,@args))) + (defun macrostep-dummy-4 (&rest args) + args) + (define-compiler-macro macrostep-dummy-4 (&rest args) + `(compile-time expansion of ,@args))" + + "(progn + (first body form) + (second body form) + (macrostep-dummy-3 first second third) + (remaining body forms))" + + "(macrostep-dummy-3 first second third)" + + "(macrostep-dummy-4 first second third)")) + (slime-macrostep-eval-definitions definition) + (slime-macrostep-with-text buffer-text + (slime-macrostep-search original) + (let ((macrostep-expand-compiler-macros t)) + (macrostep-expand)) + (slime-macrostep-search subform) + (forward-char) ; move over open paren + (slime-check "Head of compiler-macro in expansion is fontified correctly" + (eq (get-char-property (point) 'font-lock-face) + 'macrostep-compiler-macro-face)))) + +(def-slime-test (slime-macrostep-expand-macrolet + (:fails-for "ECL")) + (definitions buffer-text expansions) + "Test that calls to macrolet-defined macros are expanded." + '((nil + "(macrolet + ((test (&rest args) `(expansion of ,@args))) + (first body form) + (second body form) + (test (strawberry pie) and (apple pie)) + (final body form))" + (("(test (strawberry pie) and (apple pie))" + "(EXPANSION OF (STRAWBERRY PIE) AND (APPLE PIE))"))) + + ;; From swank.lisp: + (nil + "(macrolet ((define-xref-action (xref-type handler) + `(defmethod xref-doit ((type (eql ,xref-type)) thing) + (declare (ignorable type)) + (funcall ,handler thing)))) + (define-xref-action :calls #'who-calls) + (define-xref-action :calls-who #'calls-who) + (define-xref-action :references #'who-references) + (define-xref-action :binds #'who-binds) + (define-xref-action :macroexpands #'who-macroexpands) + (define-xref-action :specializes #'who-specializes) + (define-xref-action :callers #'list-callers) + (define-xref-action :callees #'list-callees))" + (("(define-xref-action :calls #'who-calls)" + "(DEFMETHOD XREF-DOIT ((TYPE (EQL :CALLS)) THING) + (DECLARE (IGNORABLE TYPE)) + (FUNCALL #'WHO-CALLS THING))") + ("(define-xref-action :macroexpands #'who-macroexpands)" + "(DEFMETHOD XREF-DOIT ((TYPE (EQL :MACROEXPANDS)) THING) + (DECLARE (IGNORABLE TYPE)) + (FUNCALL #'WHO-MACROEXPANDS THING))") + ("(define-xref-action :callees #'list-callees)" + "(DEFMETHOD XREF-DOIT ((TYPE (EQL :CALLEES)) THING) + (DECLARE (IGNORABLE TYPE)) + (FUNCALL #'LIST-CALLEES THING))"))) + + ;; Test expansion of shadowed definitions + (nil + "(macrolet + ((test-macro (&rest forms) (cons 'outer-definition forms))) + (test-macro first (call)) + (macrolet + ((test-macro (&rest forms) (cons 'inner-definition forms))) + (test-macro (second (call)))))" + (("(test-macro first (call))" + "(OUTER-DEFINITION FIRST (CALL))") + ("(test-macro (second (call)))" + "(INNER-DEFINITION (SECOND (CALL)))"))) + + ;; Expansion of macro-defined local macros + ("(defmacro with-local-dummy-macro (&rest body) + `(macrolet ((dummy (&rest args) `(expansion (of) ,@args))) + ,@body))" + "(with-local-dummy-macro + (dummy form (one)) + (dummy (form two)))" + (("(dummy form (one))" + "(EXPANSION (OF) FORM (ONE))") + ("(dummy (form two))" + "(EXPANSION (OF) (FORM TWO))")))) + + (when definitions + (slime-macrostep-eval-definitions definitions)) + (slime-macrostep-with-text buffer-text + ;; slime-test-macroexpansion= does not expect tab characters, + ;; so make sure that Emacs does not insert them + (let ((indent-tabs-mode nil)) + (cl-loop + for (original expansion) in expansions + do + (goto-char (point-min)) + (slime-macrostep-search original) + (macrostep-expand) + (slime-test-expect "Macroexpansion is correct" + expansion + (slime-sexp-at-point) + #'slime-test-macroexpansion=))))) + +(def-slime-test (slime-macrostep-fontify-local-macros + (:fails-for "clisp" "ECL")) + () + "Test that locally-bound macros are highlighted in expansions." + '(()) + (slime-macrostep-with-text + "(macrolet ((frob (&rest args) + (if (zerop (length args)) + nil + `(cons ,(car args) (frob ,@(cdr args)))))) + (frob 1 2 3 4 5))" + (let ((expansions + '(("(frob 1 2 3 4 5)" + "(CONS 1 (FROB 2 3 4 5))" + "(FROB 2 3 4 5)") + ("(FROB 2 3 4 5)" + "(CONS 2 (FROB 3 4 5))" + "(FROB 3 4 5)") + ("(FROB 3 4 5)" + "(CONS 3 (FROB 4 5))" + "(FROB 4 5)") + ("(FROB 4 5)" + "(CONS 4 (FROB 5))" + "(FROB 5)") + ("(FROB 5)" + "(CONS 5 (FROB))" + "(FROB)") + ;; ("(FROB)" + ;; "NIL" + ;; nil) + ))) + (cl-loop for (original expansion subform) in expansions + do + (goto-char (point-min)) + (slime-macrostep-search original) + (macrostep-expand) + (slime-test-expect "Macroexpansion is correct" + expansion + (slime-sexp-at-point) + #'slime-test-macroexpansion=) + (when subform + (slime-macrostep-search subform) + (forward-char) + (slime-check "Head of macro form in expansion is fontified correctly" + (eq (get-char-property (point) 'font-lock-face) + 'macrostep-macro-face))))))) + +(def-slime-test (slime-macrostep-handle-unreadable-objects) + (definitions buffer-text subform expansion) + "Check that macroexpansion succeeds in a context containing unreadable objects." + '(("(defmacro macrostep-dummy-5 (&rest args) + `(expansion of ,@args))" + "(progn + # + (macrostep-dummy-5 quux frob))" + "(macrostep-dummy-5 quux frob)" + "(EXPANSION OF QUUX FROB)")) + (slime-macrostep-eval-definitions definitions) + (slime-macrostep-with-text buffer-text + (slime-macrostep-search subform) + (macrostep-expand) + (slime-test-expect "Macroexpansion is correct" + expansion + (slime-sexp-at-point) + #'slime-test-macroexpansion=))) + +(provide 'slime-macrostep-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-mdot-fu-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-mdot-fu-tests.el new file mode 100644 index 0000000..cf27b29 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-mdot-fu-tests.el @@ -0,0 +1,43 @@ +(require 'slime-mdot-fu) +(require 'slime-tests) + +(def-slime-test find-local-definitions.1 + (buffer-sexpr definition target-regexp) + "Check that finding local definitions work." + '(((defun foo (x) + (let ((y (+ x 1))) + (- x y *HERE*))) + y + "(y (+ x 1))") + + ((defun bar (x) + (flet ((foo (z) (+ x z))) + (* x (foo *HERE*)))) + foo + "(foo (z) (+ x z))") + + ((defun quux (x) + (flet ((foo (z) (+ x z))) + (let ((foo (- 1 x))) + (+ x foo *HERE*)))) + foo + "(foo (- 1 x)") + + ((defun zurp (x) + (macrolet ((frob (x y) `(quux ,x ,y))) + (frob x *HERE*))) + frob + "(frob (x y)")) + (slime-check-top-level) + (with-temp-buffer + (let ((tmpbuf (current-buffer))) + (insert (prin1-to-string buffer-sexpr)) + (search-backward "*HERE*") + (slime-edit-local-definition (prin1-to-string definition)) + (slime-sync) + (slime-check "Check that we didnt leave the temp buffer." + (eq (current-buffer) tmpbuf)) + (slime-check "Check that we are at the local definition." + (looking-at (regexp-quote target-regexp)))))) + +(provide 'slime-mdot-fu-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-parse-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-parse-tests.el new file mode 100644 index 0000000..0b0ec7d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-parse-tests.el @@ -0,0 +1,63 @@ +(require 'slime-parse) +(require 'slime-tests) + +(defun slime-check-buffer-form (result-form) + (slime-test-expect + (format "Buffer form correct in `%s' (at %d)" (buffer-string) (point)) + result-form + (slime-parse-form-upto-point 10))) + +(def-slime-test form-up-to-point.1 + (buffer-sexpr result-form &optional skip-trailing-test-p) + "" + `(("(char= #\\(*HERE*" + ("char=" "#\\(" ,slime-cursor-marker)) + ("(char= #\\( *HERE*" + ("char=" "#\\(" "" ,slime-cursor-marker)) + ("(char= #\\) *HERE*" + ("char=" "#\\)" "" ,slime-cursor-marker)) + ("(char= #\\*HERE*" + ("char=" "#\\" ,slime-cursor-marker) t) + ("(defun*HERE*" + ("defun" ,slime-cursor-marker)) + ("(defun foo*HERE*" + ("defun" "foo" ,slime-cursor-marker)) + ("(defun foo (x y)*HERE*" + ("defun" "foo" + ("x" "y") ,slime-cursor-marker)) + ("(defun foo (x y*HERE*" + ("defun" "foo" + ("x" "y" ,slime-cursor-marker))) + ("(apply 'foo*HERE*" + ("apply" "'foo" ,slime-cursor-marker)) + ("(apply #'foo*HERE*" + ("apply" "#'foo" ,slime-cursor-marker)) + ("(declare ((vector bit *HERE*" + ("declare" (("vector" "bit" "" ,slime-cursor-marker)))) + ("(with-open-file (*HERE*" + ("with-open-file" ("" ,slime-cursor-marker))) + ("(((*HERE*" + ((("" ,slime-cursor-marker)))) + ("(defun #| foo #| *HERE*" + ("defun" "" ,slime-cursor-marker)) + ("(defun #-(and) (bar) f*HERE*" + ("defun" "f" ,slime-cursor-marker)) + ("(remove-if #'(lambda (x)*HERE*" + ("remove-if" ("lambda" ("x") ,slime-cursor-marker))) + ("`(remove-if ,(lambda (x)*HERE*" + ("remove-if" ("lambda" ("x") ,slime-cursor-marker))) + ("`(remove-if ,@(lambda (x)*HERE*" + ("remove-if" ("lambda" ("x") ,slime-cursor-marker)))) + (slime-check-top-level) + (with-temp-buffer + (lisp-mode) + (insert buffer-sexpr) + (search-backward "*HERE*") + (delete-region (match-beginning 0) (match-end 0)) + (slime-check-buffer-form result-form) + (unless skip-trailing-test-p + (insert ")") (backward-char) + (slime-check-buffer-form result-form)) + )) + +(provide 'slime-parse-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-presentations-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-presentations-tests.el new file mode 100644 index 0000000..fad8d99 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-presentations-tests.el @@ -0,0 +1,61 @@ +(require 'slime-presentations) +(require 'slime-tests) +(require 'slime-repl-tests "test/slime-repl-tests") + +(define-slime-ert-test pick-up-presentation-at-point () + "Ensure presentations are found consistently." + (cl-labels ((assert-it (point &optional negate) + (let ((result + (cl-first + (slime-presentation-around-or-before-point point)))) + (unless (if negate (not result) result) + (ert-fail + (format "Failed to pick up presentation at point %s" + point)))))) + (with-temp-buffer + (slime-insert-presentation "1234567890" `(:inspected-part 42)) + (insert " ") + (assert-it 1) + (assert-it 2) + (assert-it 3) + (assert-it 4) + (assert-it 5) + (assert-it 10) + (assert-it 11) + (assert-it 12 t)))) + +(def-slime-test (pretty-presentation-results (:fails-for "allegro")) + (input result-contents) + "Test some more simple situations dealing with print-width and stuff. + +Very much like `repl-test-2', but should be more stable when +presentations are enabled, except in allegro." + '(("\ +(with-standard-io-syntax + (write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75) + 0)" + "\ +SWANK> \ +(with-standard-io-syntax + (write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75) + 0) +{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) + (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)) +}0 +SWANK> *[]") + ;; Two times to test the effect of FRESH-LINE. + ("\ +(with-standard-io-syntax + (write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75) + 0)" + "SWANK> \ +(with-standard-io-syntax + (write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75) + 0) +{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) + (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)) +}0 +SWANK> *[]")) + (slime-test-repl-test input result-contents)) + +(provide 'slime-presentations-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-repl-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-repl-tests.el new file mode 100644 index 0000000..dde08ae --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/test/slime-repl-tests.el @@ -0,0 +1,343 @@ +(require 'slime-repl) +(require 'slime-tests) +(require 'cl-lib) + +(defmacro slime-repl-test-markers (expected-string-spec &rest marker-specs) + "For (MARKER SIG FORM) in MARKER-SPECS, produce suitable `should' assertions. +The assertions compare values in symbols `expected-MARKER' and +`observed-MARKER'. The former is obtained by searching EXPECTED-STRING-SPEC +for the string sig SIG, the latter by evaling FORM in the test buffer." + (declare (indent 1)) + (cl-loop + for (marker signature observer-form) in marker-specs + for expected-sym = (make-symbol (format "expected-%s" marker)) + for observed-sym = (make-symbol (format "observed-%s" marker)) + + collect `(,expected-sym + (progn (goto-char (point-min)) + (when (search-forward ,signature nil t) + (replace-match "") + (point-marker)))) + into expected-bindings + collect `(,observed-sym ,observer-form) + into observed-bindings + collect `(when (and ,observed-sym (not ,expected-sym)) + (ert-fail + (format "Didn't expect to observe %s, but did and its %s" + ',marker ,observed-sym))) + into assertions + collect `(when (and (not ,observed-sym) ,expected-sym) + (ert-fail + (format "Expected %s to be %s, bit didn't observe anything" + ',marker ,expected-sym))) + into assertions + collect `(when (and ,observed-sym ,expected-sym) + (should (= ,observed-sym ,expected-sym))) + into assertions + finally + (return + `(progn + (let (,@observed-bindings + (observed-string (buffer-substring-no-properties (point-min) + (point-max)))) + (with-current-buffer (get-buffer-create "*slime-repl test buffer*") + (erase-buffer) + (insert ,expected-string-spec) + (let (,@expected-bindings) + (should + (equal observed-string (buffer-string))) + ,@assertions))))))) + +(defun slime-check-buffer-contents (_msg expected-string-spec) + (slime-repl-test-markers expected-string-spec + (point "*" (point)) + (output-start "{" (next-single-property-change + (point-min) 'slime-repl-output)) + (output-end "}" (previous-single-property-change + (point-max) 'slime-repl-output)) + (input-start "[" slime-repl-input-start-mark) + (point-max "]" (point-max)) + (next-input-start "^" nil))) + +(def-slime-test package-updating + (package-name nicknames) + "Test if slime-lisp-package is updated." + '(("COMMON-LISP" ("CL")) + ("KEYWORD" ("" "KEYWORD" "||")) + ("COMMON-LISP-USER" ("CL-USER"))) + (with-current-buffer (slime-output-buffer) + (let ((p (slime-eval + `(swank-repl:listener-eval + ,(format + "(cl:setq cl:*print-case* :upcase) + (cl:setq cl:*package* (cl:find-package %S)) + (cl:package-name cl:*package*)" package-name)) + (slime-lisp-package)))) + (slime-check ("slime-lisp-package is %S." package-name) + (equal (slime-lisp-package) package-name)) + (slime-check ("slime-lisp-package-prompt-string is in %S." nicknames) + (member (slime-lisp-package-prompt-string) nicknames))))) + +(defmacro with-canonicalized-slime-repl-buffer (&rest body) + "Evaluate BODY within a fresh REPL buffer. The REPL prompt is +canonicalized to \"SWANK\"---we do actually switch to that +package, though." + (declare (debug (&rest form)) (indent 0)) + `(let ((%old-prompt% (slime-lisp-package-prompt-string))) + (unwind-protect + (progn (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK")) + (kill-buffer (slime-output-buffer)) + (with-current-buffer (slime-output-buffer) + ,@body)) + (setf (slime-lisp-package-prompt-string) %old-prompt%)))) + +(def-slime-test repl-test + (input result-contents) + "Test simple commands in the minibuffer." + '(("(+ 1 2)" "SWANK> (+ 1 2) +3 +SWANK> *[]") + ("(princ 10)" "SWANK> (princ 10) +{10 +}10 +SWANK> *[]") + ("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20) +{1020 +}20 +SWANK> *[]") + ("(dotimes (i 10 77) (princ i) (terpri))" + "SWANK> (dotimes (i 10 77) (princ i) (terpri)) +{0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +}77 +SWANK> *[]") + ("(abort)" "SWANK> (abort) +; Evaluation aborted on NIL. +SWANK> *[]") + ("(progn (princ 10) (force-output) (abort))" + "SWANK> (progn (princ 10) (force-output) (abort)) +{10}; Evaluation aborted on NIL. +SWANK> *[]") + ("(progn (princ 10) (abort))" + ;; output can be flushed after aborting + "SWANK> (progn (princ 10) (abort)) +{10}; Evaluation aborted on NIL. +SWANK> *[]") + ("(if (fresh-line) 1 0)" + "SWANK> (if (fresh-line) 1 0) +{ +}1 +SWANK> *[]") + ("(values 1 2 3)" "SWANK> (values 1 2 3) +1 +2 +3 +SWANK> *[]")) + (with-canonicalized-slime-repl-buffer + (insert input) + (slime-check-buffer-contents "Buffer contains input" + (concat "SWANK> [" input "*]")) + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-check-buffer-contents "Buffer contains result" result-contents))) + +(def-slime-test repl-test-2 + (input result-contents) + "Test some more simple situations dealing with print-width and stuff" + '(("(with-standard-io-syntax + (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)" + "SWANK> (with-standard-io-syntax + (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0) +{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) + (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)) +}0 +SWANK> *[]") + ;; Two times to test the effect of FRESH-LINE. + ("(with-standard-io-syntax + (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)" + "SWANK> (with-standard-io-syntax + (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0) +{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) + (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)) +}0 +SWANK> *[]")) + (slime-skip-test "Repl test is unstable without the slime-presentations contrib.") + (slime-test-repl-test input result-contents)) + +(def-slime-test repl-return + (before after result-contents) + "Test if slime-repl-return sends the correct protion to Lisp even +if point is not at the end of the line." + '(("(+ 1 2)" "" "SWANK> (+ 1 2) +3 +SWANK> ") +("(+ 1 " "2)" "SWANK> (+ 1 2) +3 +SWANK> ") + +("(+ 1\n" "2)" "SWANK> (+ 1 +2) +3 +SWANK> ")) + (with-canonicalized-slime-repl-buffer + (insert before) + (save-excursion (insert after)) + (slime-test-expect "Buffer contains input" + (concat "SWANK> " before after) + (buffer-string)) + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) + +(def-slime-test repl-read + (prompt input result-contents) + "Test simple commands in the minibuffer." + '(("(read-line)" "foo" "SWANK> (values (read-line)) +foo +\"foo\" +SWANK> ") + ("(read-char)" "1" "SWANK> (values (read-char)) +1 +#\\1 +SWANK> ") + ("(read)" "(+ 2 3 +4)" "SWANK> (values (read)) +\(+ 2 3 +4) +\(+ 2 3 4) +SWANK> ")) + (with-canonicalized-slime-repl-buffer + (insert (format "(values %s)" prompt)) + (call-interactively 'slime-repl-return) + (slime-wait-condition "reading" #'slime-reading-p 5) + (insert input) + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) + +(def-slime-test repl-read-lines + (command inputs final-contents) + "Test reading multiple lines from the repl." + '(("(list (read-line) (read-line) (read-line))" + ("a" "b" "c") + "SWANK> (list (read-line) (read-line) (read-line)) +a +b +c +\(\"a\" \"b\" \"c\") +SWANK> ")) + (with-canonicalized-slime-repl-buffer + (insert command) + (call-interactively 'slime-repl-return) + (dolist (input inputs) + (slime-wait-condition "reading" #'slime-reading-p 5) + (insert input) + (call-interactively 'slime-repl-return)) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + final-contents + (buffer-string) + #'equal))) + +(def-slime-test repl-type-ahead + (command input final-contents) + "Ensure that user input is preserved correctly. +In particular, input inserted while waiting for a result." + '(("(sleep 0.1)" "foo*" "SWANK> (sleep 0.1) +NIL +SWANK> [foo*]") + ("(sleep 0.1)" "*foo" "SWANK> (sleep 0.1) +NIL +SWANK> [*foo]") + ("(progn (sleep 0.1) (abort))" "*foo" "SWANK> (progn (sleep 0.1) (abort)) +; Evaluation aborted on NIL. +SWANK> [*foo]")) + (with-canonicalized-slime-repl-buffer + (insert command) + (call-interactively 'slime-repl-return) + (save-excursion (insert (cl-delete ?* input))) + (forward-char (cl-position ?* input)) + (slime-sync-to-top-level 5) + (slime-check-buffer-contents "Buffer contains result" final-contents))) + + +(def-slime-test interrupt-in-blocking-read + () + "Let's see what happens if we interrupt a blocking read operation." + '(()) + (slime-skip-test "TODO: skip for now, but analyse this failure!") + (slime-check-top-level) + (with-canonicalized-slime-repl-buffer + (insert "(read-char)") + (call-interactively 'slime-repl-return) + (slime-wait-condition "reading" #'slime-reading-p 5) + (slime-interrupt) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window + (sldb-get-default-buffer)))) + 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "reading" #'slime-reading-p 5) + (with-current-buffer (slime-output-buffer) + (insert "X") + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + "SWANK> (read-char) +X +#\\X +SWANK> " (buffer-string))))) + +(def-slime-test move-around-and-be-nasty + () + "Test moving around in repl, and watching attempts to destroy prompt fail" + '(()) + (slime-skip-test "TODO: Test causes instability for other tests.") + (slime-check-top-level) + (with-canonicalized-slime-repl-buffer + (let ((start (point))) + (insert "foo") + (beginning-of-line) + (should (equal (buffer-substring-no-properties + (point-min) + (point-max)) "SWANK> foo")) + (should (equal (point) start)) + (unwind-protect + (progn + (let ((inhibit-field-text-motion t)) + (goto-char (line-beginning-position))) + (should-error (delete-char 1))) + (goto-char (line-end-position)))))) + +(def-slime-test mixed-output-and-results + (prompt eval-input result-contents) + "Test that output goes to the correct places." + '(("(princ 123)" (cl:loop repeat 2 do (cl:princ 456)) "SWANK> (princ 123) +123 +123 +456456 +SWANK> ")) + (with-canonicalized-slime-repl-buffer + (insert prompt) + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-eval eval-input) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) + +(provide 'slime-repl-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/.cvsignore b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/.cvsignore new file mode 100644 index 0000000..83078f7 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/.cvsignore @@ -0,0 +1,21 @@ +contributors.texi +slime.aux +slime.cp +slime.dvi +slime.fn +slime.fns +slime.info +slime.ky +slime.kys +slime.log +slime.pdf +slime.pg +slime.ps +slime.tmp +slime.toc +slime.tp +slime.vr +slime.vrs +slime.html +html +html.tgz diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/Makefile b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/Makefile new file mode 100644 index 0000000..242a70b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/Makefile @@ -0,0 +1,116 @@ +# This file has been placed in the public domain. +# +# Where to put the info file(s). NB: the GNU Coding Standards (GCS) +# and the Filesystem Hierarchy Standard (FHS) differ on where info +# files belong. The GCS says /usr/local/info; the FHS says +# /usr/local/share/info. Many distros obey the FHS, but people who +# installed their emacs from source probably have a GCS-ish file +# hierarchy. +infodir=/usr/local/info + +# What command to use to install info file(s) +INSTALL_CMD=install -m 644 + +# Info files generated here. +infofiles=slime.info + +TEXI = slime.texi contributors.texi + +help: + @echo -e "\ +Most important targets:\n\ +all generate info, pdf, and html documents\n\ +slime.info generate the slime.info file\n\ +slime.html generate a single html file\n\ +html/index.html generate on html file per node in html/ directory\n\ +html.tgz create a tarball of all html files\n\ +clean remove generated files" + +all: slime.info slime.pdf html/index.html + +slime.dvi: $(TEXI) + texi2dvi slime.texi + +slime.ps: slime.dvi + dvips -o $@ $< + +slime.info: $(TEXI) + makeinfo $< + +slime.html: $(TEXI) + texi2html --css-include=slime.css $< + +html/index.html: $(TEXI) + makeinfo -o html --css-include=slime.css --html $< + +html.tgz: html/index.html + tar -czf $@ html + +DOCDIR=/project/slime/public_html/doc +# invoke this like: make CLUSER=heller publish +publish: slime.pdf html.tgz + scp slime.pdf html.tgz $(CLUSER)@common-lisp.net:$(DOCDIR) + ssh $(CLUSER)@common-lisp.net "cd $(DOCDIR); tar -zxf html.tgz" + +slime.pdf: $(TEXI) + texi2pdf $< + +slime-refcard.pdf: slime-refcard.tex + texi2pdf $< + +install: install-info + +uninstall: uninstall-info + +# Create contributors.texi, a texinfo table listing all known +# contributors of code. +# +# The gist of this horror show is that the contributor list is piped +# into texinfo-tabulate.awk with one name per line, sorted +# by number of contributions. +LAST_CHANGELOG_COMMIT=ab6d1bd5c9d3c5b4a6299b8c864ce4acfd25cbcc +contributors.texi: ../slime.el Makefile texinfo-tabulate.awk + git show $(LAST_CHANGELOG_COMMIT):ChangeLog \ + $(LAST_CHANGELOG_COMMIT):contrib/ChangeLog | \ + sed -ne '/^[0-9]/{s/^[^ ]* *//; s/ *<.*//; p;}' | \ + (cat; git log $(LAST_CHANGELOG_COMMIT).. --format='%aN') | \ + sort | \ + uniq -c | \ + LC_ALL=C sort -nr | \ + sed -e 's/^[^A-Z]*//; /^$$/d' | \ + LC_ALL=C awk -f texinfo-tabulate.awk \ + > $@ + +#.INTERMEDIATE: contributors.texi + +# Debian's install-info wants a --section argument. +install-info: section=$(shell grep INFO-DIR-SECTION $(infofiles) | sed 's/INFO-DIR-SECTION //') +install-info: slime.info + mkdir -p $(infodir) + $(INSTALL_CMD) $(infofiles) $(infodir)/$(infofiles) + @if (install-info --version && \ + install-info --version 2>&1 | sed 1q | grep -i -v debian) >/dev/null 2>&1; then \ + echo "install-info --info-dir=$(infodir) $(infodir)/$(infofiles)";\ + install-info --info-dir="$(infodir)" "$(infodir)/$(infofiles)" || :;\ + else \ + echo "install-info --infodir=$(infodir) --section $(section) $(section) $(infodir)/$(infofiles)" && \ + install-info --infodir="$(infodir)" --section $(section) ${section} "$(infodir)/$(infofiles)" || :; fi + +uninstall-info: + @if (install-info --version && \ + install-info --version 2>&1 | sed 1q | grep -i -v debian) >/dev/null 2>&1; then \ + echo "install-info --info-dir=$(infodir) --remove $(infodir)/$(infofiles)";\ + install-info --info-dir="$(infodir)" --remove "$(infodir)/$(infofiles)" || :;\ + else \ + echo "install-info --infodir=$(infodir) --remove $(infodir)/$(infofiles)";\ + install-info --infodir="$(infodir)" --remove "$(infodir)/$(infofiles)" || :; fi + rm -f $(infodir)/$(infofiles) + +clean: + rm -f contributors.texi + rm -f slime.aux slime.cp slime.cps slime.fn slime.fns slime.ky + rm -f slime.kys slime.log slime.pg slime.tmp slime.toc slime.tp + rm -f slime.vr slime.vrs + rm -f slime.info slime.pdf slime.dvi slime.ps slime.html + rm -f slime-refcard.pdf slime-refcard.log slime-refcard.aux + rm -rf html html.tgz diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/contributors.texi b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/contributors.texi new file mode 100644 index 0000000..13d7504 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/contributors.texi @@ -0,0 +1,67 @@ +@multitable @columnfractions 0.333333 0.333333 0.333333 + +@item Helmut Eller @tab Tobias C. Rittweiler @tab Stas Boukarev +@item Luke Gorrie @tab Matthias Koeppe @tab Luís Oliveira +@item Nikodemus Siivola @tab Marco Baringer @tab João Távora +@item Alan Ruttenberg @tab Henry Harrington @tab Mark Evenson +@item Christophe Rhodes @tab Edi Weitz @tab Martin Simmons +@item Juho Snellman @tab Attila Lendvai @tab Peter Seibel +@item Geo Carncross @tab Douglas Crosher @tab Daniel Kochmanski +@item Gábor Melis @tab Daniel Barlow @tab Wolfgang Jenkner +@item Stelian Ionescu @tab Michael Weber @tab Didier Verna +@item Lawrence Mitchell @tab Anton Kovalenko @tab Terje Norderhaug +@item Jan Moringen @tab Brian Downing @tab Bill Clementson +@item Andras Simon @tab Adlai Chandrasekhar @tab Zach Beane +@item Ivan Shvedunov @tab Francois-Rene Rideau @tab Espen Wiborg +@item António Menezes Leitão @tab Utz-Uwe Haus @tab Thomas Schilling +@item Thomas F. Burdick @tab Takehiko Abe @tab Sébastien Villemot +@item Richard M Kreuter @tab Raymond Toy @tab Matthew Danish +@item Mark Harig @tab James Bielman @tab Harald Hanche-Olsen +@item Ariel Badichi @tab Andreas Fuchs @tab Willem Broekema +@item Taylor R. Campbell @tab Phil Hargett @tab Paulo Madeira +@item Lars Magne Ingebrigtsen @tab John Paul Wallington @tab Joerg Hoehle +@item David Reitter @tab Bryan O'Connor @tab Alexander Artemenko +@item Alan Shutko @tab Ursa americanus kermodei @tab Travis Cross +@item Tobias Rittweiler @tab Tiago Maduro-Dias @tab Stefan Kamphausen +@item Sean O'Rourke @tab Robert Lehr @tab Robert E. Brown +@item Philipp Marek @tab Peter S. Housel @tab Nathan Trapuzzano +@item Nathan Bird @tab Luís Borges de Oliveira @tab Jouni K Seppanen +@item Jon Oddie @tab Ivan Toshkov @tab Ian Eslick +@item Geoff Wozniak @tab Gary King @tab Fice T +@item Eric Blood @tab Eduardo Muñoz @tab Douglas Katzman +@item Christophe Junke @tab Christian Schafmeister @tab Christian Lynbech +@item Chris Capel @tab Charles Zhang @tab Bjørn Nordbø +@item Bart Botta @tab Anton Vodonosov @tab Alexey Dejneka +@item Alan Caulkins @tab Yu-Chiang Hsu @tab Yaroslav Kavenchuk +@item YOKOTA Yuki @tab Wolfgang Mederle @tab Wojciech Kaczmarek +@item William Bland @tab Vitaly Mayatskikh @tab Tomas Zellerin +@item Tom Pierce @tab Tim Daly Jr. @tab Syohei YOSHIDA +@item Sven Van Caekenberghe @tab Svein Ove Aas @tab Steve Smith +@item StanisBaw Halik @tab Sergey Kostyaev @tab Samuel Freilich +@item Russell McManus @tab Russ Tyndall @tab Rui Patrocínio +@item Robert P. Goldman @tab Robert Macomber @tab Robert Brown +@item Reini Urban @tab R. Matthew Emerson @tab Peter Feigl +@item Peter @tab Pawel Ostrowski @tab Paul Donnelly +@item Paul Collins @tab Olof-Joachim Frahm @tab Neil Van Dyke +@item NIIMI Satoshi @tab Mészáros Levente @tab Mikel Bancroft +@item MichaÅ‚ Herda @tab Michael White @tab Matthew Kennedy +@item Matthew D. Swank @tab Matt Pillsbury @tab Masayuki Onjo +@item Mark Wooding @tab Mark Karpov @tab Mark H. David +@item Marco Monteiro @tab Lynn Quam @tab Levente Mészáros +@item Leo Liu @tab Lasse Rasinen @tab Knut Olav Bøhmer +@item Kai Kaminski @tab Julian Stecklina @tab Juergen Gmeiner +@item Jon Allen Boone @tab John Stracke @tab John Smith +@item Johan BockgÃ¥rd @tab Joe Robertson @tab Jim Newton +@item Javier Olaechea @tab Jan Rychter @tab James McIlree +@item Jack Pugmire @tab Ivan Sokolov @tab Ivan Boldyrev +@item Ignas Mikalajunas @tab Hannu Koivisto @tab Graham Dobbins +@item Gerd Flaig @tab Gail Zacharias @tab Frederic Brunel +@item Eric Timmons @tab Dustin Long @tab Dmitry Igrishin +@item Deokhwan Kim @tab Denis Budyak @tab Daniel Koning +@item Daniel KochmaÅ„ski @tab Dan Weinreb @tab Dan Pierson +@item Cyrus Harmon @tab Chris Schafmeister @tab Cecil Westerhof +@item Brian Mastenbrook @tab Brandon Bergren @tab Bozhidar Batsov +@item Bob Halley @tab Barry Fishman @tab B.Scott Michel +@item Angelo Rossi @tab Andrew Myers @tab Aleksandar Bakic +@item Alain Picard @tab Adam Bozanich +@end multitable diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-refcard.pdf b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-refcard.pdf new file mode 100644 index 0000000..66e4184 Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-refcard.pdf differ diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-refcard.tex b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-refcard.tex new file mode 100644 index 0000000..0a5bf18 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-refcard.tex @@ -0,0 +1,123 @@ +\documentclass[a4paper,10pt]{article} + +\usepackage{textcomp} +\usepackage{fullpage} +\pagestyle{empty} + + +\newcommand{\group}[1]{\bigskip\par\noindent\textbf{\large#1}\medskip} +\newcommand{\subgroup}[1]{\medskip\par\noindent\textbf{#1}\smallskip} +\newcommand{\key}[2]{\par\noindent\textbf{#1}\hfill{#2}} +\newcommand{\meta}[1]{\textlangle{#1}\textrangle} + +\begin{document} + +\twocolumn[\LARGE\centering{SLIME Quick Reference Card}\vskip1cm] + +\group{Getting help in Emacs} + +\key{C-h \meta{key}}{describe function bound to \meta{key}} +\key{C-h b}{list the current key-bindings for the focus buffer} +\key{C-h m}{describe mode} +\key{C-h l}{shows the keys you have pressed} +\key{\meta{key} l}{what starts with \meta{key}} + +\group{Programming} + +\subgroup{Completion} + +\key{M-tab, C-c C-i, C-M-i}{complete symbol} +\key{C-c C-s}{complete form} +\key{C-c M-i}{fuzzy complete symbol} + +\subgroup{Closure} + +\key{C-c C-q}{close parens at point} +\key{C-]}{close all sexp} + +\subgroup{Indentation} + +\key{C-c M-q}{reindent defun} +\key{C-M-q}{indent sexp} + +\subgroup{Documentation} + +\key{spc}{insert a space, display argument list} +\key{C-c C-d d}{describe symbol} +\key{C-c C-f}{describe function} +\key{C-c C-d a}{apropos search for regexp} +\key{C-c C-d z}{apropos with internal symbols} +\key{C-c C-d p}{apropos in package} +\key{C-c C-d h}{hyperspec lookup} +\key{C-c C-d ~}{format character hyperspec lookup} + + +\subgroup{Cross reference} + +\key{C-c C-w c}{show function callers} +\key{C-c C-w r}{show references to global variable} +\key{C-c C-w b}{show bindings of a global variable} +\key{C-c C-w s}{show assignments to a global variable} +\key{C-c C-w m}{show expansions of a macro} +\key{C-c \textless}{list callers of a function} +\key{C-c \textgreater}{list callees of a function} + +\subgroup{Finding definitions} + +\key{M-.}{edit definition} +\key{M-, or M-*}{pop definition stack} +\key{C-x 4 .}{edit definition in other window} +\key{C-x 5 .}{edit definition in other frame} + +\newpage + +\subgroup{Macro expansion commands} + +\key{C-c C-m or C-c RET}{macroexpand-1} +\key{C-c M-m}{macroexpand-all} +\key{C-c C-t}{toggle tracing of the function at point} + +\subgroup{Disassembly} + +\key{C-c M-d}{disassemble function definition} + +\group{Compilation} + +\key{C-c C-c}{compile defun} +\key{C-c C-y}{call defun} +\key{C-c C-k}{compile and load file} +\key{C-c M-k}{compile file} +\key{C-c C-l}{load file} +\key{C-c C-z}{switch to output buffer} +\key{M-n}{next note} +\key{M-p}{previous note} +\key{C-c M-c}{remove notes} + +\group{Evaluation} + +\key{C-M-x}{eval defun} +\key{C-x C-e}{eval last expression} +\key{C-c C-p}{eval \& pretty print last expression} +\key{C-c C-r}{eval region} +\key{C-x M-e}{eval last expression, display output} +\key{C-c :}{interactive eval} +\key{C-c E}{edit value} +\key{C-c C-u}{undefine function} + +\group{Abort/Recovery} + +\key{C-c C-b}{interrupt (send SIGINT)} +\key{C-c \~}{sync the current package and working directory} +\key{C-c M-p}{set package in REPL} + +\group{Inspector} + +\key{C-c I}{inspect (from minibuffer)} +\key{ret}{operate on point} +\key{d}{describe} +\key{l}{pop} +\key{n}{next} +\key{q}{quit} +\key{M-ret}{copy down} + +\end{document} diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-small.eps b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-small.eps new file mode 100644 index 0000000..03814c9 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-small.eps @@ -0,0 +1,995 @@ +%!PS-Adobe-3.0 EPSF-3.0 +%%Creator: GIMP PostScript file plugin V 1.17 by Peter Kirchgessner +%%Title: slime-small.eps +%%CreationDate: Tue Nov 14 18:44:25 2006 +%%DocumentData: Clean7Bit +%%LanguageLevel: 2 +%%Pages: 1 +%%BoundingBox: 0 0 252 104 +%%EndComments +%%BeginProlog +% Use own dictionary to avoid conflicts +10 dict begin +%%EndProlog +%%Page: 1 1 +% Translate for offset +0 0 translate +% Translate to begin of first scanline +0 103.29540259080517 translate +251.14960629921259 -103.29540259080517 scale +% Image geometry +248 102 8 +% Transformation matrix +[ 248 0 0 102 0 0 ] +% Strings to hold RGB-samples per scanline +/rstr 248 string def +/gstr 248 string def +/bstr 248 string def +{currentfile /ASCII85Decode filter /RunLengthDecode filter rstr readstring pop} +{currentfile /ASCII85Decode filter /RunLengthDecode filter gstr readstring pop} +{currentfile /ASCII85Decode filter /RunLengthDecode filter bstr readstring pop} +true 3 +%%BeginData: 57552 ASCII Bytes +colorimage +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcDnQp&=1TJ,~> +JcDnQp&=1TJ,~> +JcDnQp&=1TJ,~> +JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~> +JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~> +JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~> +^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~> +^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~> +^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~> +_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=RRajSr)m.C/Qo)F4~> +_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=RRajSr)m.C/Qo)F4~> +_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=RRajSr)m.C/Qo)F4~> +_>al?q!dM,hr['q!?_R[B6U<\@8]>TW+a/a2[rL%+WD>YGn1p]$&prp\j^`J,~> +_>al?q!dM,hr['q!?_R[B6U<\@8]>SYMdk^:j@0%*ZE"VkT`^]$&prp\j^`J,~> +_>al?q!dM,hr['q!?_R[B6U<\@8]>V6mGObffhD%+WSI]!S?7]$&prp\j^`J,~> +h>[WWrVZQgrV-NkqY^ +h>[WWrVZQgrV-NkqY^ +h>[WWrVZQgrV-NkqY^ +i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>Us'pZTo*]]&><]WTQDp\jIY$N0Yek2"S6bK.`Erl4rX +&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFYYH=n8d,t$!pAYX%qXE=XWP-?nW4LRHq>U0h%/ohS +[aX +i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>Us'pZTo'Ze=ZtZ`DC8p\jIY$N0Yek2"S6bK.`Erl4rX +&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFYWMcZ'd,t$!pAYX%qXE=XVR4(PUUo%Cq>U0h%/ohS +[`n%#kND*rlfmd!#jCO?bH'(YqYp0fJ,~> +i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>UWspZTo0_>_X^_6_GNp\jIY$N0Yek2"S6bK.`Erl4rX +&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFY\[SrTd,t$!pAYX%qXE=XXhr)uZ+ANQq>U0h%/ohS +[`cFp[C*Zc_S#6C#e.Ieb-TO`qYp0fJ,~> +ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=YujOr):jPR)inGDVQ#lOAYeA&,YUT+6j +rMKRl&ZM@nU8Fur\%T]%dFmOFo_SR^rt#,*mFJYMn*93*d]1LSp\jjd&,YqR];b5Zi8F"CZIeRB +rqZR'qsDY1lH-<4XLlTm]<(D##dM"dh:&pnpAO[aJ,~> +ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=SolKIEplJ&AinGDVQ#lOAYeA&,YT;)+R +&tu(iSt`*_Z+%Eab0eo%lh(&Qq#:m(qX)k@WpB$ +ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=kd^ULV[^W +jSp5!r:odDfu^e(TW#$4`5KX*VPBrn_U.-&nbE%]rr3Q/q<,T+jM8%%Z,#G4_<:Xnn,E[lpZKc$ +a7&Kap$)PFrpLj&hlI!DZ]?TEJ +]]&S_qYq$(q<,Q6i4G)-M3+3lOR.f0N0'^WmB"n/r:U)?~> +jSoYfr:odDfu^e(SYE!prk&ZETV&$d_U.-&nbE%]rr3Q/q<,T#lJgaZi8X%._<:Xnn,E[lpZKc" +^?b+Po^)SC%GA>*Yb%S[Vmjk,nG<.[rt#%ugU4c]kN(^cl.W)cn,)n[&H2=`_5$AZio/kXlE\(] +pAOjf%K?1d^qT'lg=Os1gtUQLf*L$_h<"%&f(&\2s*t~> +jSoYfr:odDfu^e(V6RMKrko5ZYH4P+_U.-&nbE%]rr3Q/q<,T1^SmiuTr>`A_<:Xnn,E[lpZKc* +`luZIou$jQrQG\e`4`=ZUo1]FhsgLAq>V!'o%URl_R6MJYe%o[eF3;0rt,/&jMA1@ZDaXtYeRud +iV*6Hrso&(kJ5*MVO*gCQ^ +jo5bfq=3Rs^o=!Gi9omnrSSgZlL"&YYFr&9f&uZ$rr<#tp><.DeZ=^dN2tLtZ/>9Sn,E[jn'nDq +i76B&ouR3]rm_J2i8E\]lL+,hXhEQ]r;-F*rqPZpWTqU,S"$+djLMq`p\t!g&GtqFVs_s0PE:m' +dI*aUmeck\%0$%_\AdC +jo5bfq=3Rs^o<.@kMOqDf\blXZ/>9Sn,E[jn'n>j +l0%6kp#H,8roXCIl07L4liue!VnLpWr;-F*rqPZpU?psugt^`FlE\(_p\t!g#5dlKeD0-OVpY#3p&BO~> +jo5bfq=3Rs^o=9Obf[l@rOa8f`5g*>\>6:Ff&uZ$rr<#tp><.![@`qYS"@%3Z/>9Sn,E[jn'nV` +]X>/OorS5"rj<3E]Y)"t`6-^V@GAp\t!g&GtqFXNIi=QC!r. +ZH9&lmeck\%0$%_\AZ%WQ`IKoUS[sjs.fUb!1WhPrgj(a$EL>7UR/+$\'a^Cp&BO~> +kPl%kr:]F/_5=EomGQ[Fai+.i+Mc+De_oWYdBTXhhspRBs8DWFVsi0;M04ZUeaKEjp&4C[$3'b_ +^rPBFXK8,gRfK>bX:DMI]>2P1dFI(<^;T1/rql^-r:8L?i7YAoK7f#]eaK +kPl%kr:]F/_5=0amHNisjQ$3t+QDJDkNV=!af25XhspRBs8DWFVsEO'f?`(+kNf&#p&4C[$3'b_ +^q]-mhr!8_g]641h[\T'iSrqZk3)!q[`%>'rql^-r:8L?g$%AHeC<+-kNeqonbi7`')q^i^p<7b +g=+Kug>_D&]]Akequ7B0pYrWol/C@Eb0%rPeCWF0gu%#IqVhG2s4dt8g"4j2jQrnrnbi([J,~> +kPl%kr:]F/_5=`da1SmeXfMDt+K2EH[CjB!agn@hhspRBs8DWFVp)Q@S@"iY[EPQ'p&4C[$3'b_ +^rO*bT:_SFQN3QTT+7QlVPpW!ZF.9^_o1^4rql^-r:8L?bdX:8USFBO[EPGsnbi7`')q^i^qd^` +QDgj_QDhR4]]Akequ7B0pYrX!]V_$raiV93URdd=Q_'eBqPO7`s-F([R@Tn8Xi.d"nbi([J,~> +kl21mqXW[jYG^=Ag!..6VONkLO74rsA]! +iNr"'XGMdfon*7"reV,DOH>ZqS#39qeaKToo_n^f'E7jn`i87FRtGWtJssdGVoS*!rql^.rUo!M +dG;6kH>.S]Z.\'7g%51>rtPJ-j0lna]9%DS>]54_X1HBne^`@Li;V:,a9oMeX/ii!jIG&urUp2@~> +kl21mqXW[jYFsS7kiLd]hV?l`g)o,+hr3VXl0I$"^Ynb^s8DTCU[.+#f?`(+kNenro_n:Z$3'\X +Zg6f3f@SRGe,\)!f)XJ&gAfq6hV[;Tl`Ak5rVZ[/rqbp"U?psreBH.dguRgqa6NO#qu7<-p"cgo +l/C=Cb0\f!kh2rgoDSRd'`Rmf[_1k`g="-?bgbG*iT0(_kNMd,roa=Bs5F"8#3"t'QJM33p&BO~> +kl21mqXW[jYHcQQVT\R\-IXZF[os[D1Ylr;Z`ffqZd!T:E9ZT!ce;g%>74rsA]! +iNpb9T:DFFoqMMYrgXIfQ^=#)Q^j\C[EP`,o_n^f'E7jn`j3ObQ_V:/UR/+$YfH&*rql^.rUo!M +ah"78Y0!rrtPJ-j0ln=VO+@*`4r(6Su/Wl[C*L?]`,>=XU:r#St;h"fsBN,rUp2@~> +l2M=oqXE=XUVuHN`3H"tN/*%9rHo`:K8#/DQ);".g$5``lh^VZo[oo,eZ=UMM6#1qU=f,:nG`am +pY`=FeZ=W(K)0BuF*2bUG^OmfK7er9R`Octe+*A6rtGA)i3^G\]9%DSBRGoQi5E+ap\t'i')_:K +TC:=3M03 +l2M=oqXE=XTtKaUj5AbIf[eR$rR)h;eCE1)gYUoLkj57klh^VZo[oo(kMOn;fAGcWU=f,:nG`am +pY`=BkMOnfeG@B%cHjndd*g@keC<($guRh$e+*A6rtGA)i3^/]iS)`&ajSo%l+FLbp\t'i')_:K +TBk[tf?_"Pe_T?ST?Zg$qu7W7puJuul/C@Eb08AjjQGdom-Euj]!f)[]=,0Ili6;Yl0. +l2M=oqXE=XWPl`aX.buKS"?COrMq'>US43EQ(4VM\&>c!lh^VZo[on^[@`trSY!75U=f,:nG`am +pY`=#[@`ucU\_\;\$W<=Z)aq(USFENQ`\3:e+*A6rtGA)i3^G8VO+@*b,^o,]Yh5KTpi4+XNg21qu79-puK!(]V_$rahOU;XgPg[`;[sb_8jX6_T0^rbl>Tg]XkMY]Z7S& +lM:GPs*t~> +lMhLrq^+GGDrH$k-tNg6m"n%.TTrr)KAU@6X6M04ZUeaK6bo_n:Z +#QFM[][>QDT_b)XJoCQl!b$#!r/(B(#,]f9YL;q7?rtG7p +aJ\=FRtGWaCk.ehkH;Ybq>U +lMhLrq5n-eBIif!jg,#r7Cns#2\M/WRC;6r;RH.n^X?!kMOn;\\?GCi98jmg%>7?rtG7p +aJ%t]gsjQFbL>5+l__M^q>UZt61LRbiolg)'+ +DS#K +lMhLrqW[@`tra2kNTTsr7Eg%>7?rtG7p +aK`[cQ_V:6_PWU!_RIAFq>U +li.XtqecA:l@c2,KfRt>Q`91rN.JsuVRB+iSf03H[9p[_/X@p +DfU)Zc27M4s*t~> +li.Xtq_:p\t-`fV7]phq-3+hrj="f_#.2 +rs&>ec?\g@jne$EgsjQEBP=6deD0uZrS.V6k3SPhoDSUe'Dh%9U?psreBFepcIUk7m$uGkr;?R/ +rqPQcYNk-$e'"0$db<[E]X?bnrqudGrqblrOmM/aeC<:7m!_j6@:Wt`G2I%MiSeNdBkV*h_-^HL +?!q8ia8>l.s*t~> +li.XtqZ$jQ'\$?SfjJgQC4;9USF9T][XCLp\t-`fV6TtT:E9ZT!ce:f_#.2 +rs&>ecF_-+YkkI.Q_V:5]tMA!UR1nMrKd_YZH9E)oDSUe'Dh%9Z,Ec2UV=^e\=]:saeR5Or;?R/ +rqPQc]t^M3W5ZZsX-fcs_mSLurqudGrqblr[)B)5USF0X`3cMF\@]Gh_r&;IiShVh^q[Rp_7$_Q +[(!`gjSSrKs*t~> +m/Ie!qXE4IViB2rJdMm:snWnd:Gqu7Q1lG]=Zad[p7R`OcVDUX#aJV&sWK7ipmKDpH1JUls4 +I,97"J<87ZoDa=~> +m/Ie!qXE4ITBt[rg=4Kndam%,hrEe[roYEcjPo.UhV?oBiU".jk5##To[oo(kMOn;fAGcWU=f,: +n,EUjp#9GgmJ+DfC7$EH1aIEH,r:Df4cS +C>N]ADLg"2oDa=~> +m/Ie!qXE4IYJdZ8Q_Uh#W1TWNSu]!!rjfXQ`\3:ZdZe1`lH?uaN4,MaN2EB`l7/Y +_;<#G`Qd]IoDa=~> +m/IdtoA@0XlH,`THuEqGM5I?$e`Z5crpLuslK$dOdE'DRea@b2med"^o[oo,eZ=UMM6#1qU=f,: +n,F7(qso,XGH%U-Pbt7>Q)D`nK5Y[[R`NR_rU9^M"n&Y&\FBCnrtYM*hQG8^[Z5ZH +m/IdtoA@0Qm,[!Rd`fq]fA>EIkNhL$rp(]om- +m/IdtoA@0a`3#K"X1l?USXc:W[DKl(rlcM*`4rmkZE:75[E5l)med"^o[on^[@`trSY!75U=f,: +n,F7(qsqV9['?sN]W\HKT!b\eUV=LfXQ`\3<\E(]Pai`!0b0'__rQ>/^ +#l;W`p;k=sd-^E(J,~> +mJf3GpufYlmEM>YF(oQ8M6#%Sma%ntS"+2]Kp9'nn*]K+mGF7PjS&QPrUea:n("LrFc!0Ln"SJ, +rU0\3rqh:sLXXIiFiM79Q&Y(NRtH<]aQe[mBPM7MQBd`$HZRi\q>U +mJe4+pufYhmH*0ScH=AWfAG`Rm)YrVR@I?IG(m-?li-5fmFmD,jS&QPrUea:lf[0Wce%(;l_<&( +rU0\3rqgYOGLOcGA&c>kQ%//]gsjj/jQq=l<`iImLkgbBC15c3q>UllF"bZhrF8u:; +Es)G`F8l/[!JAbis*t~> +mJf3GpufYta0;#+\&lClSY!-paiCa#Tq&9S\@]DsbfRfAa3)0.jS&QPrUea:bdF(5[%3erbbEb^ +rU0\3rqjaS`7)rA]#MRoQ*nQ4Q_U=BXi.TFXfnps^:h4p\%()Kq>UO_9&jJ +UUnOLhY-sIrtP=qa0ERbQ_V:6]u@UWR]si4cL:Z-rt"tl`jWgfQ_U=BXi.l`lH0%J"jm:lb5_M= +aoh[db5VC_!RU6)s*t~> +mJf3DnC=Jqfs-K\AT)sQX4?XAG&4^3cI7'eG'(<5CNukFWNp\qoDARfrUea:n("LrFc!0Ln"SJ, +rU'V0re,obna:pXlK*8mYiNT`IY+$0lB,q,H$Rh^G'8(UIdkeaqu7E.m`hKnc(Ti2?VO@+Fc!0L +n"\M+rVlg3rqGKa\E(GhIVW(Z>]54_aQfYBlh^MY&,PV3Sa+=dK7]Q5lBHGWK`6Z/PQ->js8VtM +"94(/s8I]QPLf=)J,~> +mJf3DnC=Jjkht+?^Wb-Xhrj@&AQlWScI6FSAR`5U=_FOdV6XWIoDARfrUea:lf[0Wce%(;l_<&( +rU'V0rc<(0na::4lK)Z\V<['oe(!16m"8PRB4oY(A7T7bD",[Iqu7E.m`h?jjk\J3XDiQsce%(; +l_E)'rVlg3rqGKaYNk-$e'".kV9IHEjQrPZlh^MY&,PV3PO.AceC<:7m"T$9ErL+`KE$"6s8Vt; +"93F`s8I'?K@'2hJ,~> +mJf3DnC=J]\"T:raM4dHT!c\TZ*LpOcI9MU]XbV[YdCdOZ*M!YoDARfrUea:bdF(5[%3erbbEb^ +rU'V0rlW=,na=B8lK,a^`4r7:W2#]]`4<4d^:r%.]=Y_j_slphqu7E.m`hfQYaV8s`P0+-[%3er +bbNe]rVlg3rqGKa]t^M3W5ZZe`4r(6Xi.E_lh^MY&,PV3[`#;7USF0X`4W\Iao9Edd/V82s8Vu= +"96Nds8L.Ad-^E(J,~> +mf,?IpZ9/nkJWX9D/Xf`X4=@sDfpBeJ+)r[nUQ,NI!U%_GLYK!K)>QIs8DTBU@6X6M04ZUeaK6b +o_n.Vs+M8Pr;2/#q=B!@_;MqeI"e6iB2qN,Ck.ehkH)G]q>Ujs8VtM +"94(/s8I]QPLf=)J,~> +mf,?IpZ9/glf6aKbfnMhhrgeI?"@X0D=@%7nSW4*C1q5)A^oRRE;TY7s8DTBU?h""f?`(+kNekp +o_n.Vs)T97r;1MTq=A@.\*;l*dad18m=o(cDf>/aDJjB3EVn)ZrtbV1l,0+ZjP88/VJ(+WcIUk7 +m$c8hr;Q^3rUegDam%d;dD_&OT$,U;j6NPVkP>,Trt"tl`focMgsjj/jQqV2lZ2uG"bZhrF8u:; +Es)G`F8u5\!JAbis*t~> +mf,?IpZ90"_Q/ru_S<.=T!c;<[(F*6`:*9;n\rH._8!\/][YfVa8>l9s8DTBUfs`P'"*\=]:s +aeI,Mr;Q^3rUegDah"78Y0"Mm_nr:9X2;9ZkP>,Trt"tl`jWgfQ_U=BXi.l`lcK.K"jm:lb5_M= +aoh[db5_I`!RU6)s*t~> +mf+X3o%0etfs-K\Dg[YXeW=TiH[gYBK`(e%r.KauJqARBJFW;bK`:uN&H27RU@6X6M04ZUeaK6b +o_n.Vs+M8Qs8Re,rqCiK_;MqeI"e6s+Q1,s8.KP +s+Q1,re1B:f(/ik~> +mf+X3o%0emkht+?bgP5(kCZrJBl.haEr>lWr,QiQEH#jbDt3L?F8l1=&H27RU?h""f?`(+kNekp +o_n.Vs)T!/s8R.]rqC39\*;l*dad18m<<,ZEcV*VErU1]s3UZC(B4*i\\.1cg="-,;J)cLeD0-O +T>p3nrr3c2n'@Njk2+\7ZZf6.ajSo%l+FLcq#:3k&,PS1PO.AceC<:7m"T$9ErL+`KE$"6s8Vt; +"93F`s8I'?K@'2hJ,~> +mf+X3o%0e`\"T:r^T3a![C* +mf+U0lc?'jad[p$I#tqtNbs#iJqSgVL&_1,s+Q1,KnP-WK`(h'L&M#_rUea:n("LrFc!0Ln"SJ, +rTsRaKbosQs+Q1+pO'9_i4G(uM6#1qBR#)]L&_%(!WUaJs"OHGhQOiT]9%DS=%5\^C4;>\jLDnc +q>UEnq<,SskJWX9D-KS# +mf+U0lc>gejP88/db<[EJQl`&E,p%!F8u8]s)W8]F)uC"Er>oXF8c+MrUea:lf[0Wce%(;l_<&( +rTsRaEu0K/s)W8\pM7(Cl/C@EfAGcWkF8u,Y!WUODs"OHGhQONTiS)`&P#>DLbL5,(lEIta +q>UEnq<,Sllf6aKbb& +F*%B\Ergp?o)F4~> +mf+U0lc?BMXd>fsX-fcsZa.9^a2uL'b5_Las2rLab0%j(ao).\b5M>OrUea:bdF(5[%3erbbEb^ +rTsRaaqrG)s2rL`pVO5W]V_$rSY!75Y.hotb5_@]!WVQas"OHGhQOf/VO+@*_Rd@s`i,3%^V.>C +q>UEnq<,T'_Q/ru_Sj*u_TJpHVS'aKhtI'Jrt,2+l,0pIXd>fXQ`\3=]'IK;ap$/lb0'baqoT$@ +b0'b`aoTlVo)F4~> +n,FF-puK!)i4G(uI#tqtcXh3IJqSf2s+ULQL&Zj\s8I]Us+ULQKn]L*&H27RU$pO5M04ZUeaK6b +o_n.Vs+M8Qs8Re,rq:`C^u2hdI#4oSmqI'!KSBI'K`V5)qu8AKo@Tl-eZ=UM@o5Z`re6()rV_EL +K*_7)KDU=UKp1*Ys*t~> +n,FF-puJuul/C@Edb<[E`Dg;_E,p#@s)\5?F8p<&s8I'Cs)\5?F*%<[&H27RU$Ln!f?`(+kNekp +o_n.Vs)T!/s8R.]rq:*1[cuc)db!C>lW@e=F*%BYErl +n,FF-puK!(]V_$rX-fcsbH&1ka2uKHs2tBAb5]W,s8L.Es2tBAb0'\_&H27RU!0p:S@"iY[EPAt +o_n.Vs2l/)s8U6arq=13aLnC:X.>iibceb$b0'b]aoVP0qu8AKo@Tk_[@`tra1o*p_TJpHVS'dP +i:m6NrUo'Q_n;k5X3&5i]"c:mSY!75VqUeArVmH.q<,N!`3#B$UR/+$]XmFNrlPDkrlWC^rVak< +a924YaSYtZ!RU6)s*t~> +n,FF-p>2t1fs-K\I#tqt^1MM:JqJ`0qh4nGK`6[Zs8I]Us+ULQKn]L*&H24OTC:=3M04ZUeaK9d +o_n.Vs+M8Qs8Re,rq1Wo)F4~> +n,FF-p>2t*kht+?db<[EZrCOOE,fo=qf;W5F8g6%s8I'Cs)\5?F*%<[&H24OTBk[tf?`(+kNenr +o_n.Vs)T!/s8R.]rq1!*f]_8Gd+@1F*%BYErl,^bi98jm +g@Y@Dr:/7.lf[0WcaeL::jfe!fAGcWT%*?/rVn;FpuT-$l/C@EeD0-OL19=cEH6&MpMk0Eo5AMa +D/=%KCM`BWEH?cZo)F4~> +n,FF-p>2sr\"T:rX-fcs`N6Yga2lBEqoSd7b5TQ+s8L.Es2tBAb0'\_&H24OT?O^8S@"iY[EPE! +o_n.Vs2l/)s8U6arq4(,bdX:8Z(7Jobcee%b0'b]aoVP0qu8AJn'@cOZCIMq`kJmm^rWdMTsr7E +g@Y@Dr:/7.bdF(5[)]qo]"c:mSY!75T%*?/rVn;FpuT-,]V_$rUR/+$]Xd4HaN;NKpW1DIo>\bg +`5BLQ_Sbc]aNDlso)F4~> +n,FF,p"QG6eZ=UMF,-X?h/I4SH[^Hom""TrK(X_Jq>Q$Nre:CPKn]L*&H)(IS+"n/M04`]g$klm +p&47Ws+M8Qs8Re,rUkK6n("LrFc!0LmqR0#KSBI'K`V5)qu8AHlc,jfad[p$>Y@sb:h"R(X4?[/ +ddd87qWc%tlH,NJDd5q3787*.KqQ]XU!<$&rVn;FpuAj%i4G(uJssdGPB#B,It)p(iSJq6eTc7[ +FE2B2EHB?NItIULo)F4~> +n,Fa5p"QG2kMOn;cIUk7fO.rqBl%X'lu)=`E:n3jq/ULsrcA,>F*%<[&H)(IS*T7pf?`+-kj,," +p&47Ws)T!/s8R.]rUjm%lf[0Wce%(;lW@h>F*%BYErlYe_T?SS^$U"rVmE-puAirl/C@EeD0-OKj`^8D&$l4iSJ;$eRi?% +@UWWR?X_/mD/oL#o)F4~> +n,Fa5p"QFh[@`tr\=]:s`iQMZ^r++/m)AJba7[Npq8pb$rlY9@b0'\_&H)(IS'8:4S@"cZ\'Lr* +p&47Ws2l/)s8U6arUmt'bdF(5[%3erbcnk&b0'b]aoVP0qu8AHlc-0IXd>fs`P&[k^W3^PT!ce4 +ddd87qWc&(`3#B$^;[e#]"Q(pTpi4+Wm0u/rVmE-puAj%]V_$rUR/+$]=6Sp`"g20iSMB&e\/T+ +\[])X[^aPs`5qlDo)F4~> +n,Fa5p"QG6eZ=UMA93O'dG9@fDK9iAaEGnYHJ*XmjaVi5q1S_HKn]L*&H)"BU[?="Km\uni8L]k +p&=:W(kn1Rs+Q1*oQm;$eZ=UMM6#1qC3kJbL&_%(!WUaKs"XNJk.J4b^ls4_=[u+a93cCeR`Ocm +amAm&p>NEti4G(uBiePK<_H\9JssdGUr;QprVn;FpYrU!i4G(uJssdGOD;JJFE;K4Z`\,>Sp-Kc +Pc_pC_T/`rGCK;:o)F4~> +n,Fa5p"QG2kMOn;^[V#NaCNWGB\@*7j_\pTq/ZH6F*%<[&H)"BTC(are^E11l.N)l +p&=:W(it?0s)W8[oOt#ckMOn;fAGcW=D2YpF8u,Y!WUOEs"XNJk.Iq`inDl)R9F2aAu3`$guRgr +amAm&p>NEll/C@Eb*&U2O_1H6eD0-OT#BpjrVn;FpYrTml/C@EeD0-OJQTV)@prcTZ`[K,SnEk6 +L8DPq\%\_FASq1fo)F4~> +n,Fa5p"QFh[@`traL@e3ZH';S[(!TWaLfdI^Y-E=ji#0Zq8rU8b0'\_&H)"BX2hH5TrXQX][3\6 +p&=:W(s:5*s2rL_oY70F[@`trSY!75YeS6$b5_@]!WVQbs"XNJk.JCBW0XC$_n3Rh]YqR[Q`\33 +amAm&p>NEt]V_$rahl!:_S!h%UR/+$Y/KW%rVn;FpYrTu]V_$rUR/+$\$3Qb]"#5ZZ`^U/T!Z5F +]X>\rai:`q]YsR2o)F4~> +n,Fa6p>2t@eZ=UM@pjA5VU=eg_3:+KVj4$IC8Gcc]6/@Fk(*1&Kn]L*&Gtk;WTqTpK7&cli5)VS +pAXCX(kn1Rs+Q1*oQm8#eZ=UMM6#1qC3kJbL&_%(!WUaKs"aTIi3L8Y]9%DS=%c@_8Qoq\Q,Mje +^ZYCho%'Vpfs-K\AR&nkBNA5MIZhJ,\%Lhtrr2p5rqGBY`8J7hI"Ig.lAAo;Vj*CN`5KOlmf;eT +l2^#Gi!/K*H[+r+rq$/?~> +n,Fa6p>2t +n,Fa6p>2sr[@`tra2YT\S?g2ZaLf*uZ+d9/YGJP3]=P\kk/R,lb0'\_&Gtk;Zc&u4UT9cZ]Z%)3 +pAXCX(s:5*s2rL_oY7-E[@`trSY!75YeS6$b5_@]!WVQbs"aTIi3L85VO+@*_S!Xr]YhU`Q)hd0 +^ZYCho%'V[\"T:raMc6.b/2'9W0XBs]tEJ%rr2p5rqGBY_n;k5X.u#``3Q/5Z+[ch`5BIkbQ,fb +_uR[Q]EZ=!\@q:orq$/?~> +n,F"!puK'(i4G(uBjP1gLSi>Li;Dj?mJZJ]_8V[aD81>TmXp2lrr3Q+m)Z*iad[p1OLjAdZJbKV +lMhZas8Re,rUbE1n("LrFc!0LmqR0#KSBI'K`V5)r;SPNo@Tqufs-K\AQW2H>YA+2I#tqt_mA:p +q!6%omEM>YEF3C,M0ru;BRGoQi5;n[p\t0l&,u=]ZGYV4OF1tuS&ssamJcANjSn*:eH""raT09X +]*?C5d;e*jrU^&>~> +n,F"!puK&rl/C@Eb,_hnf&#NPl29lJmJZ>Y[_7E.>ean1mW!:Hrr3Q+m)YjdjP885g>V;+ZJbKV +lMhZQs8R.]rUactlf[0Wce%(;lW@h>F*%BYErl~> +n,F"!puK'/]V_$rai29/T:E-p]_o\Ja8O3iaMkj"ZbO35m`f`R&7O8ZJbKV +lMh[Is8U6arUdk!bdF(5[%3erbcnk&b0'b]aoVP0r;SPNo@Tq`\"T:raMYs:`4Wt0X-fcs_R&1o +q!6&#a0;#+]#DgmSZBoMb,^o,]Y_#6p\t0l&,u=]ZGX>PQ`IiqQ`\3Ma8X!W^](nF[/dN3XT5F# +V?X06bdQHlrU^&>~> +mf*jpm*(7Pc(Ti:EGB$*LS:ubr5er`rRLr+*U<(NY'IS+IY.Irs8Vr]`i&+DRtH*M]&:E3iV3?6 +rtC+bo[oo,eZ=UMM6#1qC3kJbL&_()s8N)Mr;SPLn'@TndAD\?@9dDeDd61NGDi`Zi25/to]!Ek +jM6t.CN"T^X,q^BA9Ws:g#/jap&4mi&,u:[YJ];1OF1b\Jt'm4c2Pfb_#CtFX8o-sRfJ`PO9VB& +m>BH;r:Br=~> +mf*jpm*'_Ajk\J7c-*iHf%o9Cr8[k>rTF4Fs6L]XVJ3ThCiK:Ns8Vr]`h;\Zgsjd+iT[kZiV3?6 +rtBJPo[oo(kMOn;fAGcW=D2YpF8u/Zs8N)Gr;SPLn'@Kik2+\7Z_bUdbb]s+d+I:?fr!Emo]!Eb +lJgOHbKSDghqHN$^ +mf*jpm**&]YaV8g]>hq$Ssl@Mr2ft'rO)[<*Q6+E[^EZo_oMZRs8Vr]`j!C`Q_UUKVS'pUiV3?6 +rtEQRo[on^[@`trSY!75YeS6$b5_C^s8N)dr;SPLn'@cOZCIMq`l-!+^Vmq/Z(%GrbGNq_o]!Ep +^SmHs`P8I@SsZS$aK_5.\'1i+p&4mi&,u:[YJRrLQ`J6BUR/*jYl:a)W;`[nT)bD\QN3 +mf*jso\XW*i4kqFKmn5cF+oR7r0m\[rN-%2*Qc^^kO,mVFFV)rqYfrV[VW.VU=h'cg:)O +VVp.4N-K8gOLhF&OF1bbM6#1qT@EH0rr3N.p"ZS*fs-K\AR'/*S#i=_RfJZOOT((:L]2o+JGsp$ +JssdGQdEnQoDa=~> +mf*jso\X#cl/LOPe^DghcILS$r7h;.rSRY6*TZAHlg1mP@qtN0rr2c[`h;\Zgsjd+iT[kZiV3?6 +rtKPQo[oo(kMOn;fAGcW=D2YpF8u:=F8u7?d/Eu#rqYfrT'YOneBFf.dFZmlV6S=shWF0ocg:)O +VV11kf[.jjg>T*kg="-ifAGcWT@EH0rr3N.p"ZS#kht+?^ST0(gu$reh#5t+f)XD$e,[tsdKe:W +jQq`M`;K6,J,~> +mf*gro\[+"]Vq9eTr>6.\"T;gQN3KQTDtc/Xg5FQb.ja`_=7=#rqbs#Yf*Z1UT9cZ]Z.>;p\s=T +'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drVn\Qq<>f"`3#B$^;\3sSYNp;`jhY2ZH8iem-`K& +bdX:8Z+m?,VQH__X3.f?T!ce7eFNP:rt#,%goAT-Tpr=.`4i"5T:5bG!1*VNrgWt[rhBIiri6:! +Q`\3@d,Foos*t~> +mf*aqqX/WG_W8tMTTY4eK)U/qK)gW(M>rYXS#3I/dH'5?Eng'ZrVGj"Vs;BnK7&cli5)eZp\s=T +'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVn\Qp>NEti4G(uC2\BXUmcmR>]54_aQfSYEIhXGM(0;-\$lM1tq]!.Oops)n +mf*aqqX/!#\*E)6h:gN3eGdnoe,\%tfDjPFgtpuLk3CWD@,(/HrVGj"T^:apeC*(0l+"+Zp\s=T +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVn\Qp>NEll/C@EbKSAebhU^lV9IHEjQrJTjQ=OQ +mH*0Sc-k>)l$'>ig="6rh<"$pbjPB-rt#)$g8=3!hq-2bI\k9 +mf*aqqX2)'ahP'TR[0G:U].=lUB%"dSGnipS>!!h^Wa6tg[G";qWl/*`3#B$X-fcs`jF_!roX4p +b5LtbUO`4i":U&LeeW;`jt[/R*+VZ*@iSHbFb +`4sd\r:Br=~> +mJd^qpj[O*\aA4t^TjH#OH>CuM#`>1K)U-iS:Q2[6OWs60& +oPWI0rU^&>~> +mJd^qphaVJZ0gc:io&YJg=k3Wf)XD$eGdl:eCN:,hW!bdLUu=4qYBHsT^:apeC*(0l+"+[p\s=T +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVo=bo%0_kkht+?bgG,&R&f#lbfS;eiT\"^g"Np= +lJgOHdb<[El9quCiS)`0guRgm_Wgprs8W&ifq[lrhq-2bI\k97dJhSne,\%ufDaJ(g]$"-hZi', +lWi5drU^&>~> +mJd^qpr'kP^;mghW1fZHR$aB@SH,;]U].;7URms?S>`p;]t3%jqYBHsYJdQ0UT9cZ]Z.>s8W&?s8N)drVo=bo%0_]\"T:r^TO!"V5]fV^<3LDVS'gRg"NpK +^SmHsX-fcse=4FiVO+?YQ`\3._Wgprs8W&ifqZd!T:E:/^VmmoY5YL$UB%"eSc4uVQ2[-LSd)(4 +gp>etrU^&>~> +m/IRoK7A0UL=#>Kg!.UL]!;16!2faa+HVV=HujO_LQf!flD_V\p%[glVWu9mK7&cli5)e[p\s=T +'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVo=`mE;6kc(Ti2H&f>hKr2t]Jo>jkZ.\'2bfcd> +fs-K\JssdG_-N&cad[p1OLjAg\E!A`s8W&ifV7ibXGM(0>]54NNrG.>RK0#[X8][1`;[jWeHXt! +QZ_N>rq$/?~> +m/IRoEG]?tGK9+9kiLmaiSaXk!8d_1+PPN"da$4gf%T'Dm%_DXp%[glT^:apeC*(0l+"+[p\s=T +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVo=`mE;'fjk\J3dFmLBHCj3QeBH:li98jibfcd7 +kht+?eD0-O\4hD=jP885g>V;/\E!A`s8W&ifV7]phq-2bV9IH@g&B_)g]610hu;R7j8S-=k6C2< +M.>bmrq$/?~> +m/IRoaMbg%\]`%.\$3!3VP3pZ!1a%T+IJRhX1,@1SsH(S`3R5?p%[glYJdQ0UT9cZ]Z.>s8W&?s8N)drVo=`mE;NMYaV8sY*l&rV6m@kUV="&Tsr7Abfcd* +\"T:rUR/+$_kXWXXd>f`R&7O6\E!A`s8W&ifV6TtT:E:/`4r( +li.EIK7Mg$DMG[ZmHWWfg&0A#dJh30]!eJtHt[AE%jhRtGd;VU=h"]==F! +c(Ti2JssdGS7RiJad[p.NjdcjXPNRJs8W&ifV.caXGM(0Dh=FY[f3l;a8jKaec+J,kPjcGmfg[e +F+!T/o)F4~> +li.E8EGjWC>^*F*mHj*%kksTDk5OHAi?$k0d`TeZe(EO>g8!$]p$'Gfm,ZsOdb<[E\@(>jroX4p +F8ba`U?h""f?`(+kNc5`E-$+#s8@$=rrCFFs$cq^jh7MVj4i&1g#;/[97H6ggsjX#hWF0k]==6q +jk\J3eD0-OQ;`J'jP884g#;/:XPNRJs8W&ifV.Wohq-2bbgbG*rSdb:!9O4CrojFKrp9XM"hf1j +C@faAs*t~> +li.F:aMm#I[(3loa2GX'\,fcRA7@7XPNRJs8W&ifV-NsT:E:/^S@-eU]..iXT5U)[Jmf=_Z%LQbQYtt +\\[n'o)F4~> +li7!=$\\/%HZm!"Um/^2i;E$Dmf)Joi8)elOF1bNCOVG]jLD\VnE7]clH,NJI#tqt_RAM"roX4p +L&LYrU@6X6M04ZUeaI7!JqSjXs8@ZOrrCXLs$ltZgo\u[[Z5ZaQ,Mk5ARFoVXGM(OR`OceV4b6W +^ls4rP/$)KPAFh!eZ=UMM6#1qT[iW2s8W&heXl6[XGM(Z@3l2^5Nmgm:N_4m0YQCDZ, +]Q\dTqpk9;J,~> +li7!+$ZblVBk=lTT8'h`g&117llbQVk2G%Bb-T:>g>_D%\)6]<_k-5Ugsjd+iT[k\j7rW9rtKPQ +o[oo(kMOn;fAGcW=D2YpF8u:=F8u7?d/O&7rUemIb3@m +li7"-$H_qY^q@7XXh;`qqof&^rkoql]!A3#X3/H$W0XBs]slngkJOI@Xd>f`R&7O9[c@/^k5Q.< +rUea:bdF(5[%3erbcnk&b0'barQ>0?!:Bdc7fDu7Xi\/LRBEEPX2<2WV9H?>S@#&XXi.38TY%t; +QDgaJW5$rJZ)Z$UT:E9ZT!ce8eaiYT$4U7S@$&+Q`[[,rk/6K!6>)_&&H?.^q7:oS$963 +]Y_\cmIL:-~> +li6s<2#W&YJE5FsFE)5@ChmdZBqD8fTu#(Ci4G(uBjc";VU=h+cfjE(U?]jiK7K6*kJXplq#9FU +'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)Mrr6C(n'RfrdAD\?KqQ]XTl+Jgh6r>iI#tqt_23g5 +eZ=UMKqQ]X\#XO`i7YAoG_Mg8m@_Yiqu?]on^ +li6s*2#VE5DWKN]@UNJQ>$4t$=.>q=S%$E(l/C@Eb-B7ChWF0tcfjE(SF#=leC314laaReq#9FU +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)Grr6C(n'R]mk2+\7e_T?SP[7>0l/C=Cdb<[E\VYt) +kMOn;e_T?SYH)&5g$%AHd+-t6m@2;dqu?]on^ +li6t,2#YM9`T5ar\[SrOZ*:I+Y+i57WlW?)]V_$rai:i_S?g88cfjE(X2M-,USas8W&?s8N)drr6C(n'RuSZCIMqTpi4+^oONY\tb[rX-fcs^km]f +[@`trTpi4+^8n`HbI=17Z([Vja/I2Kqu?]on^ +li6s<2#i8_K_Y2kIsud#H[:"iH-j`V^2IeN^Yl_cHtd>EP/$(g^YmtZ`Se@iI"Ig.lD;5Xq>TOV +'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8QW\s8W)ol,0@_ad[p&KqQ]XKQ_1:jM6t.GDi`ZheJ;= +ad[p&KqQ]XT"oMd_r/.gI"7L#kH2M^q>UEkm`hftad[p7R`OcP@;2l`EH?5FcZsikhL'a#It3(> +JqEcNKSBHWo)F4~> +li6s*2#hW_D'^YmtZ^$4M0da[(5m$YTNq>TOV +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8QWVs8W)ol,0+ZjP880e_T?SFCn^QlJgOHd+I:?fP6?2 +jP880e_T?SR_WK>]BS;.daQt2l_VAZq>UEkm`hQojP887guRgM:fsl,?t!PUcY$qGhJ6nCD/O:^ +E,kYnF*%B.o)F4~> +li6t,+TKU,anYMj`5BI1^q[Y9^TOV +'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8QWss8W)ol,0^CXd>fpTpi4+[^36X^SmHsZ(%Grb%dEa +Xd>fpTpi4+VnfsO_n;k5X/;/__R@5Bq>UEkm`i,WXd>fXQ`\34Vm!82\%'#]cb@0KhSR.I`5Tad +a2n%tb0'bOo)F4~> +li6s +li6s*!<<%>#6+SXEcH)Lrbs4VDt*13kA"YEV;]=)D_DNVU9'aYj16%e'ct/l+=7YpAP!fm)c!gjP887guRgR>@lQ)Ci+$,n8E:=pAT(2EWc5\ +F8l/[!WUO;s*t~> +li6t,!<<&@#6+SkaiMQJrl6AX`piE7kJ=mIY/e2PQ`J62RA7@8YLhI8`4Vt6X.u#``4s8W&?s8Q*ds8W)li3U>6VO+?aR&7OGY.D'T`3#B$]:k[ta*G"q +R\@fXQ`\39ZFnr/_o0L4nA`NApAW/4aTMI` +b5VC_!WVQXs*t~> +li6s,dBKS9@(qh51QKn]P\ +rr2uLo)F4~> +li6s*!<<%>s8N)Wrc8'lrc9CaF8YoUq/L?3@T;"Di7QE&fAGcWU!D2o]BS;.da[(5m#&dIqW7_k +F8ba`U?h""f?`(+kNc5`E-$+#s8@$=s&IGGs8;H=U[.+#f?_q#j6O-YEb&8;kMOn;c.1Y3RH<8T +c-Fnsk3T+ZhJ6Snm,ZsOce%(;l_E&%r;QQYa.Ve[gsjj/jQqS/C[uK?q>,.0F*%?[qf;o?F*%A& +rr2uFo)F4~> +li6t,!<<&@s8N)jrlP5frlQPcb5D.Yq8gS7\Z/52b0'__qoT'Ab0'b, +rr2uco)F4~> +n,ELhr;-6gKE2#NL&_/QjSji5PQ$7^s+ULQL&Zj[nTo&VjM6t.EJ:(1mA%_LYf,J3OF2YKaQf/4 +lh]`C'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Or;T@cm)ksfc(Ti2KqQ]XUN2*7D9q%HNd>>XKqZbb +KlLLALSiJeHctZ'GFn6MVMB5HTZuktbjG<,qWl/!lH,NJJssdGPf8.JL&V)UL&Zj\s8VtM!rmt. +r;QcJo)F4~> +n,EXlr;-50Ec_6ZF8u7?i;RctKDop +n,EXlr;-62aiaV^b5_JAoDZl4d/M06s2tBAb5]W+n\;BI^SmHs]:k[ta/m>/Yf",NQ`HmJXi.fj +lh]`C'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?r;T@cm)l9IYaV8sTpi4+_RIFsZHKhSRBFZDTpi3S +Tt87RT:E4/Z-2CM]VEWTS=[3`R]si3bjG<,qWl/*`3#B$UR/+$]Z%hbb5VDEb5]W,s8Vu=!rpEc +r;Qcao)F4~> +nc'.!r:faIk^J&6q1OHUs8V0ZK`I>9KdHbQs8RfQKn]8LEKTP.RtGX2R`Ocm_U#F'i4G(uJssdG +R)nXjjo6$KrUea:n("LrFc!0LmqR0#KSBI+rIt4M9)eVI]Xd+=PC@M*TZukXG)CZeZK/fbIVW80 +KqX3??Yk7X`95Tkg@9`?VXN':M04?6`948;kP>)Qlc,jfad[p7R`OcY`ddi=rr3.Us+Q1,s8.KO +s+Q1)rrCX@s*t~> +nc&ppr:faIk\Y3Vq>PI8rrD!VEr^jlF!^j-s8R0?F*%(k?\Ie,gsjQtguRgr_U#Etl/C@EeD0-O +Mob8]jo6$9rUea:lf[0Wce%(;lW@h>F*%B]rH%r;9)eVI]Wg\\g=+)Qlc,UajP887guRgV`bkQnrr3.Cs)W8]s8-j= +s)W8ZrrCF:s*t~> +nc&ppr:faIketH\q>SP:rrDZiaoKffasI)1s8U7Ab0'Iq[^sDZQ_V9iQ`\32_U#F']V_$rUR/+$ +]#a77jo6%;rUea:bdF(5[%3erbcnk&b0'barQ>*=9)eVI]Y;.ZQDhEhR]siB]>qdt`kSI)Qlc-0IXd>fXQ`\3=`l._rrr3/Es2rLas80q? +s2rL^rrDHWs*t~> +nc'-soB+WF^iO[Fl@O\Cs8V0ZK`I>9KdHbQs8RfQKnT/JE09G-RtGX2R`Ock^s/sui4G(uKqQ]X +R*+gnjSonlo[oo,eZ=UMM6#1qU=b'NL&_2OL&M$DrUo!KdG;6kH@1gci:1T.N.5u(mEM>YEF3$l +KlLI-F,-X?m]V!!p@Wg>`8J7hI!h$ei5;eUp&+[P`hr%CRtH<]aQf#0J,4lurrn,VKn]R,qh5+O +Kn]I)!7p`@J,~> +nc'-soB+WF^gUbfl>^ics8V$VEr^jlF!^j-s8R0?F*%%j?\@_+gsjQtguRgp^s/sll/C@Ee_T?S +N6:PbjSonlo[oo(kMOn;fAGcWU=aF+F8u:=F8c,2rUo!Kb3@mJ>QrrmKDF*%B]qf;i= +F*%9Z!7:<:J,~> +nc'-soB+WF^pq"llH%)is8V]iaoKffasI)1s8U7Ab0'Fp[^j>YQ_V9iQ`\31^s/st]V_$rTpi4+ +]ZTX=jSonlo[on^[@`trSY!75U=dN/b5_M?b5M?4rUo!Kah"78Y,dqe][X1"b/Cp%a0;#+]#DY" +Tt84_\=]:sagnqCp@Z8._n;k5X/hVb]Y^o0p&+[P`im=_Q_U=BXi.ll`;7XUrrpRFb0'baqoT!? +b0'Y^!:B@WJ,~> +nc'-kiPqq)a2=clc$k7ts8V0ZK`I>9KdHbQs8RfQL&18gCp +nc'-kiPqjt^:9S9c"q??s8V$VEr^jlF!^j-s8R0?F8G@U>,:HCg=+9qguRgq^rr^gl/C@Ee_T?S +IEq!WR6>s%<4Ze"5mghq-3'gZ.V.?#"k-B3FQ`hq-2b +I]UeqFg96ChWF0pEUN\uCquq6j4i&/fAGcWT[`N/qWl.om,ZsOeD0-OL;n*,F8l1CF8p<&s8Vt; +!rm=_r;QcDo)F4~> +nc'-kiPr.7`lc6+c,7TEs8V]iaoKffasI)1s8U7Ab51SWZ,=>TQDhQnQ`\31^rr^o]V_$rTpi4+ +\'FI?jSoeio[on^[@`trSY!75U=dNbrr<#@!WU=@s%<4Ze"4dkT:E9cQ)hdF[)'u+^9GhhT:E:/ +^W!e'^;d[TS?g83^@(jm_n`auX-KNgSY!75T[`N/qWl/*`3#B$UR/+$]Z.ndb5VDEb5]W,s8Vu= +!rpEcr;Qcao)F4~> +nc'-^a04poi8EeVW-3ZCrVtsXK`I>9KdHbQs8RfNKC@U-F5>6@LN@BcR`Oco`65"GeZ=UMM6#1q +DU\.Rp&>V90o[oo,eZ=UMM6#1qU"4elrVc_LL&Qf)s%<.Ra/A4ERtGX5TZul! +F+3lVHuHjZ]9%DS=&!$r>&8_S`95UOL@kE@JBOYRc(Ti2JssdGW6"<#q +nc'-^a/J@jl07NeV.FL`rVtgTEr^jlF!^j-s8R0V90o[oo(kMOn;fAGcWU"4/ZrVc_:F8g7Zs%<.Ra._k\gsjQuh<"$i +@;P]2C0e=5iS)`&P&IF@T$,U;j6OjiG4b_0DTeR;jk\J3eD0-OU<)Zrq +nc'-^a10:/]Y),+XLuKmrVuKgaoKffasI)1s8U7>aR@orYfV90o[on^[@`trSY!75U"76\rVc` +nc'9SXPhXI]=Z#7iGIaturhU/3UF(T]X[b^G5bKQ^LeZ=UMM6#1q +E7a^[q>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X9#eZ=UMM6#1qS'QTTo^qg.K(aiorVlfkjh&%` +^ls4eKqQ]XKm&"Cq0mFMlH,NJDd5q0:1/-uVU=h8^P_gcr.3Fnn("LrFafLgjL;_]p\F-qVs;Bn +K7]Q5lBK; +nc'9SWnHRqiSih\fii$+qYoDoF8pmlF!^j-rqpd,Ct6(]g#h/BcG\,`iTTQ_bKQ^HkMOn;fAGcW +@+Y#Kq>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X8tkMOn;fAGcWS'PsBo^qfqE;";KrVlfkjh%_] +inDl+e_T?SG%>Leq/'Sqm,ZsObbf&mFg96ChWF1&^O#\Sr,:/\lf[0WcdLP,lE@e[p\F-qT^:ap +eC<:7m"WMsqK)Z9"`s]bF8u:;EruA_F8Z% +nc'9SZH9MTVP^E'bd+t%qYp*/b5]ifasI)1rqsk._pu;gaKh>-\&ke@UUnmMbKQ^)[@`trSY!75 +Xk31Cq>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X8U[@`trSY!75S'T%Do^qgsa7dUOrVlfkjh&4@ +W0XBoTpi4+\@]`Vq8BhV`3#B$^;[e"^;d[TS?g8I^W6-Kr5R<^bdF(5[&B:h^V%/=p\F-qZ,Ec2 +USF0X`4X+.qTAg;"j6kfb5_M=ao_Ucb5D8>mIL:-~> +nc*OK[-uPGOH>aGkFupAn+bmrL&R9iKnT>Up@*O`FJtS`dAD\?@;LIZ`95R;eBafVeZ=UMM6#1q +ES:!_s8W)trVZNep@@V6hpffb^;J=Un+chXq=jUUo^V+fQg`J+M04ZUeaJ@(GLtL"fm7s@hL4ea +qu$0FYL217Nd?)7]&<*nH%GnjJ9ZA-dAD\?@8BKj?uq+#dI*XPNVi_RK&3]Ii4G(uH&f>hd&Ypm +q!?,$lH,NJJssdGPf/(JL&V)UL&Zj\s8VtM!rmt.r;QcJo)F4~> +nc'9DXR#',g=k +nc'9D^Wa*WQ^[p@,uP\Yu4BZCIMq`knUVYab5VDEb5]W,s8Vu=!rpEcr;Qcao)F4~> +nc'9;b4!l]M0t)UdGB"cfBCk=p@j[JJoL1-hpQSFL!f;8VMB5$?uLXcaQfS"h9hk`eZ=UMOLjB? +F4p-[qYBp[oC)#,hUTfaYbA&-`lG$ifB`%tki(=Mf[S$HJa_-jM04ZUeaI.-BVD/pUMFYIER*V8 +q"!(5n("LrFaT:^i4s2VK)PX-JpVC^h6r>iB2q?'Ck.ehkL-KfO8]+XKB9bOjM6t.F,-X?m\%qq +p[6;,lH,NJJssdGP.uJ@K`:rSL&Qd[rr)_I"T*k*rVlfr!7p`@J,~> +nc*F?_!C1@f@&7,k1O9PfBC_'p@j)WE,b8_hpPr4Fis+6hU]uYZ-:_QjQr5-h9hk\kMOn;g>V;] +A(gGKqYBp[oC)#,hUTfaYb@es]t^>SfB`%tki(=Mf[S$HJa;LVf?`(+kNcc;5+lc?3`J,TEHETOj1lJgOHcIUk7m%)Ml +p[6;%m,ZsOeD0-OKthI!F8l.BF8g6%rr)e:s)J8>EcV-Xrr2uFo)F4~> +nc*F?cciegSZABQZH'5YfBDDaVS'sU^rQEPa2#%)\tb[rahbO*_PWU!_U,F?bl.S@aQ:(S^SmHs\=]:sae[;P +p[6;5`3#B$UR/+$]>)8Yb5VADb5TQ+rr)f +nc*47am[c\M03lpVU=7AX2DYthr*F?He$BWZ(@3,mG6$aLN?m+F+Tk%lJl]gjO'LdeZ=UTOLjAd +Ems7=lK@0_f?_FIY+_Mj_scmOi8F"D[FF'`_m?>F,-X?m\IV[OT,:[K^6^ElH,NJDh=G!lD2;\p@-Ohn("Lr +IZhJ,YdAcGK(o!4K(X_Io^r*6$A!`qJ:[ChrVliJo)F4~> +nc*47_!C1@f?_anhWEL#X2DM_hr*F-C":JEZ(?]lmHN`hf$:UhcICY1m+PXHjO'L`kMOn>g>V;, +@ajQ-lK@0_f?_FIY+_>^]BehKl07TM[FF'`_m?>EKJc>]LEpLf%m,ZsObgbG/m%2)Xp@-Oblf[0W +db<^GV6jt*E;0)"E:n0ho^r*$s)/22DK#4DrVliDo)F4~> +nc*47cciegS[>kuS?g5>X2E2thr*G/^t$]GZ(AVMa1ALFT!u_W\>,Cm`7D3;jO'LA[@`tiR&7O3 +YLD_%lK@0_f?_FIY+_f&_p$'6]Y);*[FF'`_m?>fsUR/+$Xhs;qnC+,U[@`tf +QDhR:[(u.Np\+=$ouG,Fo_li1`X)"O`qB0+rr;BVs*t~> +nc)Y-^$jLPM039KLSiJe[@<=qYHkHOCnR8m`:*!Ic*j=$F(&HcF+Tk%lBlY.kg#aedAD\HOLjAb +CqIj4`P/a]U7J-idI6Jci75rb]=Z>NZ*V*B]]&eWs69m3RtGWa@WdO/pXLeMmB4Okk/aLdad[p$ +JssdGPB25+rr7Y%GB`K&VMB5$:LJ7!VU=gVcgHtqs!`WjdV81#XGM(IOLjAf[,CTIfTP^RXGM=d +]&:>mFOtothVTGi%`Xqu51;s*t~> +nc)Y-[-Qo4f?^qOf&#QUXI"rNYHkH=>+h:S]BehJjl,%HcEjdccICY1m#,>akg#[ak2+\;g>V;* +>eA/$`P/a]U77dYb3SH\l0%-eiSinaWjB@;[+YBCs6L$PgsjQF\BidapZF'kmAS+ek/a:`jP88/ +eD0-OKjnn=rr7"VAS1;khU]uYGHoHEhWF0;cgHDas!`!XdT>bthq-3&g>V;.[,CTIfSo.Zhq-<1 +iT[b>@b5APhV;huBP?&Nrb)[PAnB.sBAVqGqu4t5s*t~> +nc)V,`lti^S[?GHT:E40\tl%*YHkI?ZCmnn_p$'1YbRYY\&QG.\>,Cm`4NS3kg#pFZCIMeR&7O2 +WOpDIV`!EK3UV=^f[%3f_[4Ai/\&dXmaK`[cQ_V9i +Q`\3<\\uSgs2i6mZc]SDT!u_R`jhY2ZH9H!ma(n4.EV)-Y0=;GS@#>aVS'gRi:QTmWQ_cBS?&$S +]Z-GOf>6A$gq_UX^Y%3<^C.ch]Z[t%hWjb1rpB:VJ,~> +nc'0HRIA\,M0398F,-X?jR)E^rkh(MNmZ&Ep=<,[AWaQh5lh=Qm0s!`WngMGg$Z&EpMM6#1qUt5&,hO2^G[Z5Zl +Z.\#UAuBONY,Q33CMTZ=rb;gTBU>]aLpG1^o)&FWs*t~> +nc)8.O6budf?^q3cIUk7lL!oX]">S_f^%njl0%-dh:^?(^<=gJf%8gB]k;&rlH>shjP885g>V;& +:Q(I3T;B3Blg4!'l0%0giSWGig'?U#acM\=lKJ0/s5XI@eBFe;MR_!apYRL[kh32lh7oNIjP88/ +eD0-OLLb:Cs8R.ZBj03Ri7QDkMTjT*jQsunh=Q@!s!`$]gKN:oi7QE&fAGcWUt5&,hNQ%FiRuW2 +i98d6<2X!*Y,PR!=]qJnrE'D-LnfcOZHD.squ60dJ,~> +nc)Y9[*5qLS[?GW\"B1r^W4R@_Sa:4bfn5J]X=l:R[KkYaMt`sT:MR]^pLo8lH?NPXd>f`R&7O. +S;WWfs +UR/+$]t;8*s8U6^^p;1nTpr=._7ub3Xi/Yoh=T(ns#A0ngTo&4Tpr +nc'0VN6pChNd>MP?uq+#^s1EcrSSpRe^;LNXIG6(H?!kGIYWcWX4>"cJq))3aJeCGRtGX,OLsHM +n,MYikMY1HdE024XJ(o@M1^8)MlYCsFL1&DZ2C^'RfS.[raGtABP;P_M(>%9lEJOb\AdC +nc'-UK#m38g!S!WZHh%XioTA$kp,ETk2bLYgtC6*c-4M^f%8d9kI7I4D92%aU?psreBH@piT^@- +s6LTgl07BnjPo.Uh:pZ8eC2juhrj +nc'0VZcp"URBFEJ`j_P0W3E\@rOaAa[Bcp3T9kt>Y.DBTW1TWNT!cJ9^r5@#aK`[cQ_V9qR&7Oq +bl>Tu_S!IfZE:(#T:2%3S>3$`S"@%3FLf/bU&:P_QN[E#qWQ`I`lR]si4bO"i\\B2C\Q`IB\ +Tsr7iaN268p!!ER#04rt_rC@fo)F4~> +nc'0cRtpCUVMftKDeO3IPG,(drOX;ZXJVJKM1^+oFaSdtP,>;-e\H%JMh9@BaJeCGRtGWmI#tu> +ec3`.`4NIZVONd0M1pJ-Fa&4bMne?DB^aKQN;SP4K)foiFT?^[Hn9lHdI+0[e?m0P]9%DfOLjB? +CjL\ds8RfLJ9?_9c(Ti2A:Tr`kMg9&nbeUMruZskl#`9Wad[p$J +nc'-bOa-9ThUp<(bfS/]g>1Zai?R:W%o +s5Y$WiSi\NgtLH5e^Msmd*gFrip,fBlf[0Xr7Ctu!6tJg!7CJf/C`P=m&8(V[(PY^g="F'iT]W2 +BlJ.ns)\$SA:3e+h:9cae(`pKfii%Yr.G"K*cq2B@Z'O5gsjQsgZ.Us^ut@SV2"?tgsjQpf\krU +rTX"1kmJ?DRJ,~> +nc'0c_RddlS=?C\^WO$WQC=G@rMCg5T:D77S>36u[&]smQCOPP[D]AsaN3T2aK`[cQ_V:;X-]^_ +[K!?GX/;YaSfsVNn4![_V(ul,(-PXd>fsZ(%Gp +[CZ@MosOe$#-bSWZ-Mb5o)F4~> +nc'0mWH+9hdBSspJp_c`IYEW=rK&7_M2-_2FaSXiM3+1,^X:TgUi1MBOG)'LbGsjLRtGW]Bmc$A +XT+b,Q&q#_LP(&%Fa8@dLP_+]X2!`#EpqP[M>_f(J:`B,rJ:N7oT1T#dI*ONf!WHS]9%DhP/$(r +Dg[1ks8RfNJU2A*eZ=UMFb#q%lD8QNp\pBUruZslmWXTVc(Ti2I#tqt_m\Rsn$RH/dAD\?A9a'7 +XLA,?orS.^#GJT^e%=]9rq$/?~> +nc'0mT4!H@k2>"HeC)^he(*('rRrLKf@JI"cdL7kf@o$;io]FXT3Z'nJ9&m$bG=LcgsjQ8b0o#C +huDIKgY1?4f$r0rcdC1jf%8X2hr_D0 +?>FP%s8R0 +nc'0mcaUU+ZD!PQUT:Z/W1f`LrKeauS=ZLV[&^.#SX>b8W3WhNX0fS)c,o5;bHo-hQ_V:4b,^m. +TDt5pQ'[o/Sti6e['$I)T:M@9SuBEEEm1q`SGfJjVPBo[rLEqVoU%/!ZH9;rf!WH/VO+?^QDhR: +[DL#-s8U7>`kS_$[@`tr[&01l`4rh"p\rP=ru]D\m_$$LYaV8sX-fcs_m\Rsn'&2^ZCIMqaK_5, +T;2C_oq25M#F_F!b.Ha0rq$/?~> +nc'*rZ?pShmb,O`RZNG_Jq3]F,(P8sLP_+UR]F$@e`?/&Uq_5+pQC6[nC"9&c(Ti0C1q:.re^Z- +(k@![H$k-oLP_%QR\m-saOTA/FcG>4Z','I"-o=DT`(nk[e.-]aOSk7gYKK]i4G(uI\tN\]5rFR +L&_1,re#WFZK/fbM2@86lJlo1Jc#J2rr4'orUY>Wi7YAoG_1dQeaKa"o^on;_Vi%fIWojXM2@8l +OS+J0K*R76eaKa"pAX[`J,~> +nc'*rW+fV4m-*KfgtLE3eC49B,1G&kf%8X0gu%)OkN_E1U;(AZpOdP4nC"*!jk\J2bK7lSrn%2" +(Xpg[dF-Lnf%8U/gtprIjQGg]A<#:+i;D:2gYCT?rSR5*/*,m +nc'*rftb&#ag\=EQ^F87USdmg,,V-1T:M@8Q_((V[D0huWP?3epX%(KnC"P]YaV9#`lcH)rga"` +(o=:9Y,eFpT:MC;Q^jYEXgPpcZ&Qu:TpGYE"-o4>Rf/fXU\(E6XgQ]ggYKK\]V_$rW1:08`4 +nc'*u\:Aq>T&AebaL\XRR[*`2+-i:`VQ7;CaOT56hQihocf9S/rKDrco\?(sfs-KfIf+R4J:`B, +M2@7SQ("SN[^sQ-e_o`LZZC,kVru=>rON*LaN2X)eH"Fti%+*MXL%-P`i\FBQ&q*)dI*cSmt?Dp +s+UK+J:`(7dC-*V[`Ia4I=?hJs-*H^+GKgiIXAK`^lsA%TXs(OZJbHOaEMptdAE(bLOsu&I!>7+ +!."Qk#_8APh=.W*pAX[`J,~> +nc'*uY&A$fS([,kjPf%RgtV\Z*o#K*hV[;OjQGdofqt?Jcf8q`rI]1;o\>qhkht+CqpHG4eC<%# +f@em4gtprIiT0.al0R*$@pcL1lfI.)i/*tuiXm"ldU[-spg=kEGm%J%[Ec_9\ +F8p8uEbXn&iSWPOjQrUXCiTISKDtljF8krNCT?[Zg=4X.iT]X5i:cr_ASLMnhV-W5eGdkrd.P]b +dJhQ"e(ipGlEB+=rq$/?~> +nc'*uho]#2Vgs3UcF+Nj]Y_mm\#W0X3RR\maIZJbHOhn6A>ZCI5MT;/?cX0M?) +!3Z=%#cpAX[`J,~> +nG`s0KRr(&CnoqRi7ZN!`;7%e`5p$Ie_oNRn&(E2ER0%"p4S/"PD.Q^kH_PW^oNoer/_k_R[TnM +X1#UXaO/Poi9Kaf`2@ZsK6u$j_sQO`hui0-lL"Q=!7:PW0Z1`C`58R!cc#GDeW'"E`4EP$e]#+I +p4S/"s+UK+Jr+Q8mG6=Ch +nG`s&Ec9mW>*dk.l0.9jj8.^Uj5f:`kNV9ulb&!^@*`TTp2Y6SK6,B6kH:lNinrPgg)Jf%gtglF +iSihXk3(smm-NEPaL8PS[kPG'\%K5IB@"<`n(!$Vk2YFZjQF7g +C\Dgjs8R0?F)cJ7M!aEhkNM9I[WZS0s8R`Lru1cQF)p!si8!,DiU".jk4nkrCLN%ck2P=Uh#?"- +f_*hrg&B\2gYCcSah$R.rq$/?~> +nG`sVai<8[ZGFc']XP2KX88\8X0&M0[Cj8mbeq,t\'MnXp;tJWd)tbNkJ>0QW1K?Ar0SFgQ^=/4 +Sti0`Xg5@G]Yqq6`3HPV^qeC+b/_9q]E?$h`5hi#!m&F&qoCJ.aN28S!1EhR#aLaO`7) +nG`s0KnT*^H#n&*_;ObHkPF*YkN_@#n%cGuC:&,:II;^`rIot*PD0&7n\fXgjOM>dr44>qaN2WV +e_T0HlL+,e_53cF\As8ONIgDKEJV6G_84'kPc0=NC29cLDYe9*[;^)AF0C>achd@tO-f:ti8EnI +Y18(!Kn]R,L&Zj[NdPo(dI6POQFPP*K8'@*PPkG%rI]rTRd/SIaN`Q/HID9ZrmQFFEL#tQg!RmU +]"50>WrTU-\d-0pe`rLFm/$;QJ,~> +nG`s&F)pp:B45;E\(L'6lh]iGli-5ilaF$Q=L;R[C[Q0[@550XY4nI:9*ulcK"sk(JTXlfm[# +afa04qK$`Xs)\3]Edhb3Gf]4:aG@@XI;s?.s+C7L*rU))D2moGjQ,FdltXu;qu4iYBjZ\_lKIBk +io/kSp##`,#NOn.m"rsQqXXZ:~> +nG`sWb/s;>^::DQaNVcE_YUne_SjC7bf@E1YdD!X_X>J@rQ<:_d)uCdn^Fke^U:2Br2(sEXf\h8 +[CX#f`6$6HaKD;B\AuJ(b/Wba\%BGoaN2<-]2ss*t~> +nGa!1Kn]L#JUW9nEGTluXi^IV+/5QrTVZS?Fa;npNe@4^s8Re,s-*K_rqY&rDmSotjS[pakN_@" +n*eT=U6Kk;DK3VAL#_KZK9Co_NI5ug]5V`#^N@SAG^=\jh>)FPidH6JI`RTGec,I;SooCU`knis +e*;SaKn]R,L&Zj\Ob%q)EGi"#G2;SJKSBI+PPbA#qi6GYXPrI0mEp6&k4eiSeV&L#F*Y(Lmcrlk +i7[eR!8[Y4#NtC@V/kMdrUTu=~> +nGa!'F*%7+s8R.]s+C@OrqXo^?)[)UlMTlqlg4!* +lg)U#Q%ipS>[PFrG2qn;EIr6+I;3B3]3epV^LG;rB4tu5h.le%0]Hk`P\e3dq9T';o9*TuR(g). +?IS1ZrH!&[s)\3]F+J7FARJcI?Y&!\JTGo4s+C4K*W(;0CSoeOm-Vl.AENXbs3G_(Bjk_Rg$J(j +l07F)k5a`Fkm-P@l^2,=o_n@\J,~> +nGa!Xb0'\X`l#[7[^*9F[_DX[+2G%mV5:Q4]>!4AbK0S's8U6as3UfGrqYTi[)U>.^\k_n_SjC5 +bfn8O^qI(YZaRg!_rL(+aNr!'b/(d/]=,/Z^U_J!^;%G;h8/s)0]KsdcGSSaq<\+Xo?=eT_o9a+ +[F=E^rQ<:_s2tAab0J#D]XP8P[_(A`cH=<0s3UZC*W+$u\@0W"`5g*1]B8kds6[qJ^pphlbfRf< +]Y(`H[/df;]Ec +nGa!1Kn]R+KS, +nGa$(F*%B\EcHQoCM@D&_5:T=?N4@H@Dud*fkTYeDt\4'F8p=]s)W8]KDtm.rRuX4@Afp!\%KA_ +]Tn2+GFhuC?=@>UBPM>Jmsk*.JocQcrdf$,l/c\rjl^LJDf9T6p%J3$/GO4)SoN#-rm:]Eqj_J8 +A&2X"C$kY9s)W8]s)\3]F+\LPDJX(FCMre@K6.%l!/(1K*WCV=GK=BRM5O]lD"RZ*s3Ph-Deirn +AS?gq\%:5blO1bA\%S)`X(,o6qYp'cJ,~> +nGa$Yb0'b`aiMZk_SEk,_7@#R[K!ZL\Ac).ftlgi`qIO#b5]Was2rLad/O&&rU%_A\>Q[PaMYp: +`5'!u\Xp(4[CEf]^VRePn'(P&ccXVWrm&R(l/fe!jlaSL`l?'>p%J4&/GR<-fZ<@)rpBabqpr[! +]"tr&_!Um=s2rLas2tAab0\8N`P]OL_Su0Dd)u@f!7:WC*<+7,`5o:#^U1G^_t~> +nGa!1Kn]R,KnY]dK7\[@kg'*Ss*bXHJFW8`q1OG#Kp.5jL&_1,L&[A8s"<;nJUZ7pF)eXrE4U+4 +Fa)>]I!pHoJV&K+qYZNUs-&/#L&[?iK_kIrKD>7qqu26ML&V)IKc'iDKs$-\PQ056s8K*PJUcm5 +mXk<6L&Zl+rt'naKnY_EKS4u1pOe.trf`'8rrA8ZruI;cO6MFEGh%1lK)GWJs42mXKS+f(L3Ri] +E3X7rrbE.@C20K +nGa!'F*%B]F)us0EH#j_kfWg=s(iA6DXm@=q/UQUF+\Q6F8u8]F8pmks"E8\Df"(L@:-IN?b0ZT +A7a8(C27X'DfB]9qYZ!Fs+>BFF8pl6Er,QNEVT?Mqf;[Ws8Mh8)#nYuU3"\6s3UfGrh+7LD&9IkmF+\OTEcH*nEH;$WK6.%l!/(.J*J8oml$$cPeS8uAr;Q`rcuX8KEGoZ:An,7V +Z!1E2=V@H2=JDQn=^#$8?FjUifkbX(rpg#=~> +nGa!Xb0'bab0&',aN)s3Sp8b5]i2ankeRaS>SQqoSi[s8Mi:)#qb$grf$2s6]jdrn>H5`9>/- +a85bWs2t?@&Bb$qb0\;RaiMQtaN=D[d)u@f!7:TB*RN*Ul,: +nGa!1Kn]R,KnY`jKnP-Vq=so@(ANN7qLneFL&_1,s+QYjs+ULQKn]PjrVmSmPD"S[m='KDidKp; +It3+@JqAW-re1<*s8N^qs8S::PD0%#Kn]R,Kn]R,L&_+*s8VnK#lfU4Y(bGjs472L%'G;;K_^;u +K`;"*s+UIP"GQl0Kp2Fg#6'=1s8S::rr2t^qZ$SZ#a5"EJV!BDKS9=(!7q+&$&!qlJUi2ti8&bZ +HN2V.HJ$nsH@(!dIH>tHo7M_qnGe"~> +nGa!'F*%B]F*!!6F)uC!q=so.(AMlhqJuN4F8u8]s)Wg6s)\5?F*%A6rVmJfK5tu'm;6Y!ibRXl +D/O:_E;jkWErL.[rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%RU2t?qq/Z@R +rr7'>F8l1BF8p<&KD]cprcClrr@]Js8R]WK)'q8Dt7mgF8c+=d/A"lEcHVJDJX+Hh.ck% +s4@Eef\'s;BaAHhj_aGWEH;'Js*t~> +nGa!Xb0'bab0&*2b0%j'q=sp0(APtlqT8[6b5_Las2r^2s2tBAb0'b2rVmK$d)jB#mDQm%ikjfp +`5Taea8X0[ao9H_rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ogrda\q8rNV +rr:.@b5VDDb5]W,d/;#jrlWC`s3SpfrrCFBs8UFOchYi*`q%3mb5M>?mJY06aiM`H`P]RNh8'$) +s4@Fgf\+%=^^.cnji$TYaN=GNs*t~> +nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]%-3V+L&Ln$KD>4opk/R! +!<)\Hs8N^qs8S::PD0%#Kn]R,Kn]R,L&_+*s8VnK#lfU4Y(bGjs472L!3Z +nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M%,cbZF8buUEVT +"EXTaF+aC3"oiXbs8R`Mrr@]Js8IWRre#63rVgm:rrCFCEs@8;EcH*npAJt1oE'")p&8q0E +nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E%.higb5M4YaS>POprNHV +!<)]8s8N_Ys8UHgd)uC8b0'bab0'bab5_F_s8Vo;#li&igrf$2s6]gc!8RRr#li'Ib5_Las2t?@ +"Npbeb0^(/"ol`fs8UIErrCFBs8L@Jrm8d/rVjt +nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO +s7h +nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!= +s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%FUAf3>s)\3]s8R0?F8l1B +F8p<&s86pAs)W8]s+C:M!/(.Jrdt@RK6),6rcA& +nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(? +s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ch#>G%s2tAas8U7Ab5VDD +b5]W,s8:"Cs2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:\es8Mu>s8<#Arr2f;"olaFs2rLQ +s*t~> +nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO +s7hL&_.+rVllKqh5$6rIt:OrIt:O!ep[Sqh54RL&_1,L%#%l~> +nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!= +s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%FUAf3 +nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(? +s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ch#>G#s2tAas8U7>rrgLE +b0'b^ap%gfb5_LgrVllEqZ$QA"TQikb5_I`rVllbqoSocrQ>0?rQ>0?!m:QCqoT*Bb5_Lab4#@\~> +nG`O$L&V,PK`RD;re:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO +s7h +nG`NoF8l4>ErgpnrcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!= +s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^?s)W7UF3oR;rrAemEsDYcs)\5?F8Z%@F8p<& +s86pAs)W8]s+C:M!/(.Jrdt@RK6),6rcA&#leses)\5?F*$gM +J,~> +nG`OKb5VG@aoTlhrlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(? +s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seAs2rL>b3dRRrrCjRap.mgs2tBAb5D8Bb5]W, +s8:"Cs2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q +J,~> +nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPtLhjHG:Os8Re,s8RfQrIk7O +pkAbJ&sN@qPD,3Ss-&.js8Re,s8RfQrIt:Oq1T%QKnZ[`es$%3!3Z +nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5@KDkfXi.H)ls8R.]s8R0?rGqu= +piHK8&qg5aK6)Zds+>B6s8R.]s8R0?rH&#=q/Zc?F*"'sd"D8r!2BI6#6/cEF8u8]r;QqAs)W8] +s8@!Bs)W8]s+C:M!/(.Jrdt@RK6),6rcA&#leses)\5?F*$gM +J,~> +nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/EtPo?bY&s8U6as8U7ArQ5-? +pr`X:'%$[Yd)s_Xs3Sp2s8U6as8U7ArQ>0?q8rpAb0&M^mEke2!8RRr#62jGb5_Lar;QrCs2rLa +s8C(Ds2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q +J,~> +nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPkFfPD+_js+Q1,s+ULOK`M/J +L&_/cPQ1ZHKp.5js+Q1,s+Q1,s+ULOL&_2KKa.R2Ks$-\PPkF\Y5X+Zs+UK,s8RfNrrn,VKn]R, +rIkFTKn]R,PPtL]PPY:aPQ-jHPD+_jre:=N!7q%$!0dD9rr;qNs8N.Ss8W(P#lfU4s+ULQKn]!q +J,~> +nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5@KDb`VK6),6s)W8]s)\5=Erc78 +F8u7QKE(t(F+\Q6s)W8]s)W8]s)\5=F8u:9EsDYcF/!a&KDb`LUAf3#leses)\5?F*$gM +J,~> +nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/G#s2tAas8U7>rrpRFb0'ba +rQ5!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q +J,~> +nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPkFfPD+_js+Q1,s+ULOK`M/J +L&_/QPQ(R`Kp.5irs4>Ys+Q1,s+ULOL&V,KKa.R2Ks(I,PPkF\Y5X+Zs+UK,s8RfNrrn,VKn]R, +rIkFTKn]R,PPtL]PPY:cPQ-jHPD+_jKn]I)!7q%$!0dD9rr;qNs8N.Ss8W(P#QKL3s+ULQL$ntk~> +nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5@KDb`VK6),6s)W8]s)\5=Erc78 +F8u7?KDtlPF+\Q5rs3]Gs)W8]s)\5=F8l49EsDYcF/&]]KDb`LUAf3#QJjds)\5?F70'Y~> +nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/G#s2tAas8U7>rrpRFb0'ba +rQ5s8N/Cs8W)@#QMrhs2tBAb3o:[~> +nG`O$L&V,PK`RD;re:@OrIkLVKn]P\s8RfOrrRn +nG`NoF8l4>ErgpnrcA)=rGr5DF*%A&s8R0=rrR7oF8c.=Erl;nr;R+Vs)\5?F*%B]F8u2[!<;h8 +qu6_=K6-qis)\5?!-A/>s)\2>rGr,AF*%A&rr3#GKDb`QUAo:Us)\/=!-A)<%s.blF8u8]s)W8] +F*%B]KDkfMKDPTSKE$T(K6),6F*%9Z!7:Ua!/(8lrr;q#QJjds)\5?F70'Y~> +nG`OKb5VG@aoTlhrlY6?rQ5BFb0'b,s8U7?rrU?ib5MA?aoVOhr;R,Ns2tBAb0'bab5_F_!<;i: +qu6`?d)u7cs2tBA!6Y<@s2t?@rQ59Cb0'b,rr3#dd/s2t&'Fppb5_Las2rLa +b0'bad/EtEd/*bKd/VJmd)sN2b0'Y^!:B[+!7:_frr;r>s8N/Cs8W)@#QMrhs2tBAb3o:[~> +nG`O$L&V,PK`RD;re:@Os+LUUL&Zj\rVlkOrVlqQPD/u8s+LLRPPkFfPQ-@:s+Q1,s+ULOK`h@/ +s+UFOs+U@M!elhlqu?\Ms8N(Qrr<"Prr;qN"TO10s+UIP!S3J4rr]G(Kn]F(!/:@N%u(%;L&_1, +s+Q1,Kn]R,PPtL]PPY:bPQ-jHPD+_jL&:lMf)::(s+Q[9L&V,NL&_/SL&_2PKa7X3L&Zl,s+Tn@ +J,~> +nG`NoF8l4>ErgpnrcA)=s)S>CF8p<&rVlk=rVlq?K6."ks)S5@KDb`VKE$#ms)W8]s)\5=Es)G` +s)\/=s)\);!cs!8qu?\;s8N(?rr<">rr;q<"TNOas)\2>!RQJsrr]"qF*%6Y!-A)<%s.blF8u8] +s)W8]F*%B]KDkfMKDPTRKE$T(K6),6F8Pt;d/A"es)WhlF8l4EsM_dF8p=]s)[W. +J,~> +nG`OKb5VG@aoTlhrlY6?s2kKEb5]W,rVll?rVlrAd)u=es2kBBd/"TQWes2t?@!U\83rr_'Vb0'V]!6Y6>&'Fppb5_La +s2rLab0'bad/EtEd/*bJd/VJmd)sN2b5;2=mJY0/s2r^fb5VG>b5_JCb5_M@ap7shb5]Was2sd0 +J,~> +nG`O$L&V,PK`mV>L&Zl+s8RcUs+UK,L&M#OL&M#QKp.5hs8RcRs-*B\!gEY +nG`NoF8l4>Es.-qF8p=\s8R-Cs)\3]F8c+=F8c+?F+\Q4s8R-@s+C7L!e^Morr3CJs8R0?s)\3] +s)\3]rVun=qu6_=K6-qis)\5?!-A/>s)\2>rGr,AF*%A&rr3#GKDb`OUAo:Uqu6Y;r;R:Ks)W8] +s)\3]F8p<&s8R`Mrr@]Jrs48WKE$RFF8p=YrrCFEEruA_KDorks8@$=rrR9As8I'Es)W8]F8u8] +mf.e~> +nG`OKb5VG@aop)kb5]W`s8U4Es2tAab5M>?b5M>Ab0\<0s8U4Bs3U]D!mptirr3DLs8U7As2tAa +s2tAarVuo?qu6`?d)u7cs2tBA!6Y<@s2t?@rQ59Cb0'b,rr3#dd/qu6Z=r;R;Ms2rLa +s2tAab5]W,s8UIErrCFBrs7!Od/VJ8b5]W]rrDHbao_Ucd/M2es8C+?rrU@Cs8L.Gs2rLab5_La +mf.e~> +nG`O$L&V,PK`[J +nG`NoF8l4>Erq!oF8Z(%!2IKF8u8]s)\3] +s)\/=s)\);!cs!8qu?\;s8N(?rr<">rr;q<"TNOas)\2>!RQJsrr]"qF*%$S%s.blF8u8]s)W8] +F*%B]KDkfMKDPTRKE$T(K6),6F8Pt;d/A"es)WhlF8l4>EsDYcs8R0?s8I'Es)W8]F8u8]mf.e~> +nG`OKb5VG@ao]rib5D;>aoqaes2rL_rrC4?rrU?ib5MA?aoVOhr;QiFs2t?@%*JVMb5_Las2tAa +s2t"TQWes2t?@!U\83rr_'Vb0'DW&'Fppb5_Las2rLa +b0'bad/EtEd/*bJd/VJmd)sN2b5;2=mJY0/s2r^fb5VG@ap.mgs8U7As8L.Gs2rLab5_Lamf.e~> +nG`O$L&V,PK`[J +nG`NoF8l4>Erq!oF8Pt@F8p=]F*%<[!-A,=!cs!8rVun=!WRfMrrRiQF8l1JF8u8]s8R0?F8p=] +F8c.=F8Pt=F+\Q2s8R0?rr@->s8R0>s8@!As)W8]F8l1?d"D8r"/>g:F7oPDF8p<&s8R0?F*%A& +F8u8mrVlkMqYphRs+C?(F*%A&qu6ZCrGr&?F+aI5rr<">#6/cEs)\5?rcA,>"`s]bs8R0.s*t~> +nG`OKb5VG@ao]rib5;2Bb5]Wab0'\_!6Y9?!m8m4rVuo?!WUOErrURIb5VDLb5_Las8U7Ab5]Wa +b5MA?b5;2?b0\<.s8U7ArrC4@s8U7@s8C(Cs2rLab5VDAmEke2"5Nq!b4YcFb5]W,s8U7Ab0'b, +b5_LgrVllEqYpiJs3Uemb0'b,qu6Z`rQ53Ab0^.1rr<#@#62jGs2tBArlY9@"j6kfs8U70s*t~> +p]#dES,i?aJ,~> +p]#dES,i?aJ,~> +p]#dES,i?aJ,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4 +o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4 +o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4 +pAY0R +pAY0R +pAY0R +pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[ +n,EEg!8%7$~> +pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[ +n,EEg!8%7$~> +pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[ +n,EEg!8%7$~> +pAY-nEr>qDEo[2[ElS0?WrN+! +*KF."q>WDSWrN+ZElV1?j&I*?j)R-[j8]."!36%u%rt[Ms8V+Zrr3MLs2S,[a8b1? +pAY-nEr>qDEo[2[ElS0?WrN+! +*KF."q>WDSWrN+ZElV1?j&I*?j)R-[j8]."!36%u%rt[Ms8V+Zrr3MLs2S,[a8b1? +pAY-nEr>qDEo[2[ElS0?WrN+! +*KF."q>WDSWrN+ZElV1?j&I*?j)R-[j8]."!36%u%rt[Ms8V+Zrr3MLs2S,[a8b1? +pAY+mrW";dWrE(!s/H(!!!$">ErT,[EiK*>3<6)Ws8Q*ts8Q(,s)K,[ +3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[ +<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%; +!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~> +pAY+mrW";dWrE(!s/H(!!!$">ErT,[EiK*>3<6)Ws8Q*ts8Q(,s)K,[ +3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[ +<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%; +!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~> +pAY+mrW";dWrE(!s/H(!!!$">ErT,[EiK*>3<6)Ws8Q*ts8Q(,s)K,[ +3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[ +<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%; +!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~> +p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[ErV."WW9(!*QS*Xs&K$ts&BI,EZL2? +s/H(Zs&E(qruqHCs8T)!+" +a8\/"EZP2[N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u +<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~> +p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[ErV."WW9(!*QS*Xs&K$ts&BI,EZL2? +s/H(Zs&E(qruqHCs8T)!+" +a8\/"EZP2[N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u +<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~> +p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[ErV."WW9(!*QS*Xs&K$ts&BI,EZL2? +s/H(Zs&E(qruqHCs8T)!+" +a8\/"EZP2[N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u +<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~> +nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTosts8Q(%WW3$!a8,`C!36)!UJq!;uls<=]$/WrE'>rrB)! +WW<&!Wr;r"j)P-"p&BO~> +nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTosts8Q(%WW3$!a8,`C!36)!UJq!;uls<=]$/WrE'>rrB)! +WW<&!Wr;r"j)P-"p&BO~> +nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTosts8Q(%WW3$!a8,`C!36)!UJq!;uls<=]$/WrE'>rrB)! +WW<&!Wr;r"j)P-"p&BO~> +p\u.P3<8([WrK(!rrB)!WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+>!<<'!WrH(!s8R*[j8Y." +iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t +s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~> +p\u.P3<8([WrK(!rrB)!WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+>!<<'!WrH(!s8R*[j8Y." +iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t +s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~> +p\u.P3<8([WrK(!rrB)!WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+>!<<'!WrH(!s8R*[j8Y." +iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t +s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~> +p\t5nr;Zp?WrI,WW<)! +!35tss&BR/WW;)Z!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[ +WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~> +p\t5nr;Zp?WrI,WW<)! +!35tss&BR/WW;)Z!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[ +WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~> +p\t5nr;Zp?WrI,WW<)! +!35tss&BR/WW;)Z!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[ +WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~> +pAY6TWiF,s8V->s8T+!j8Z+Z +WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z +#fluFWiH+!a/]+s2V/"a8c2" +WlP/>j/T-Os*t~> +pAY6TWiF,s8V->s8T+!j8Z+Z +WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z +#fluFWiH+!a/]+s2V/"a8c2" +WlP/>j/T-Os*t~> +pAY6TWiF,s8V->s8T+!j8Z+Z +WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z +#fluFWiH+!a/]+s2V/"a8c2" +WlP/>j/T-Os*t~> +l2LbaWmUhIWW7VMec1.~> +l2LbaWmUhIWW7VMec1.~> +l2LbaWmUhIWW7VMec1.~> +l2Lc)a3jnf`uTa2ec1.~> +l2Lc)a3jnf`uTa2ec1.~> +l2Lc)a3jnf`uTa2ec1.~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +%%EndData +showpage +%%Trailer +end +%%EOF diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-small.pdf b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-small.pdf new file mode 100644 index 0000000..4fd6557 Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime-small.pdf differ diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime.css b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime.css new file mode 100644 index 0000000..bd333d9 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime.css @@ -0,0 +1,22 @@ +body { font-family: Georgia, serif; + line-height: 1.3; + padding-left: 5em; padding-right: 1em; + padding-bottom: 1em; max-width: 60em; } +table { border-collapse: collapse } +span.roman { font-family: century schoolbook, serif; font-weight: normal; } +h1, h2, h3, h4, h5, h6 { font-family: Helvetica, sans-serif } +h4 { margin-top: 2.5em; } +dfn { font-family: inherit; font-variant: italic; font-weight: bolder } +var { font-variant: slanted; } +td { padding-right: 1em; padding-left: 1em } +sub { font-size: smaller } +.node { padding: 0; margin: 0 } +dd { padding-top: 1em; padding-bottom: 2em } +pre.example { + font-family: monospace; + background-color: #E9FFE9; border: 1px solid #9D9; + padding-top: 0.5em; padding-bottom: 0.5em; } +a:link { color: #383; text-decoration: none; padding: 1px 2px 1px 2px; } +a:visited { color: #161; text-decoration: none; padding: 1px 2px 1px 2px; } +a:hover { color: #161; text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #666; } +a:focus { color: #161; text-decoration: none; padding: 1px 2px 1px 2px; border: none; } diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime.texi b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime.texi new file mode 100644 index 0000000..1c3156b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/slime.texi @@ -0,0 +1,3544 @@ +\input texinfo +@c %**start of header +@setfilename slime.info + +@documentencoding UTF-8 +@codequoteundirected on +@codequotebacktick on + +@dircategory Emacs +@direntry +* SLIME: (slime). Superior Lisp Interaction Mode for Emacs. +@end direntry +@c %**end of header + +@set EDITION 2.24 +@set UPDATED @today{} +@set TITLE SLIME User Manual +@settitle @value{TITLE}, version @value{EDITION} + +@copying +Written by Luke Gorrie and others. + +This file has been placed in the public domain. +@end copying + +@titlepage +@title @value{TITLE} +@titlefont{version @value{EDITION}} +@sp 2 +@center @image{slime-small} +@sp 4 +@subtitle Compiled: @value{UPDATED} + +@page +@insertcopying + +@end titlepage + +@c Macros + +@macro SLIME +@acronym{SLIME} +@end macro + +@macro SLDB +@acronym{SLDB} +@end macro + +@macro REPL +@acronym{REPL} +@end macro + +@macro Git +@acronym{Git} +@end macro + +@macro kbditem{key, command} +@item \key\ +@itemx M-x \command\ +@kindex \key\ +@findex \command\ +@c +@end macro + +@macro kbditempair{key1, key2, command1, command2} +@item \key1\, M-x \command1\ +@itemx \key2\, M-x \command2\ +@kindex \key1\ +@kindex \key2\ +@findex \command1\ +@findex \command2\ +@c +@end macro + +@macro cmditem{command} +@item M-x \command\ +@findex \command\ +@c +@end macro + +@macro kbdanchorc{key, command, comment} +@anchor{\command\} +@item \key\ +@code{\command\} +@i{\comment\}@* +@end macro + +@macro fcnindex{name} +@item \name\ +@xref{\name\}. +@end macro + +@c Merge the variable and concept indices because both are rather short +@synindex cp vr + + +@c @setchapternewpage off +@c @shortcontents +@contents + +@ifnottex +@node Top +@top SLIME + +@SLIME{} is the ``Superior Lisp Interaction Mode for Emacs''. This is +the manual for version @value{EDITION}. (Last updated @value{UPDATED}) + +@insertcopying +@end ifnottex + +@menu +* Introduction:: +* Getting started:: +* SLIME mode:: +* Debugger:: +* Misc:: +* Customization:: +* Tips and Tricks:: +* Contributed Packages:: +* Credits:: +* Key Index:: +* Command Index:: +* Variable Index:: + +@detailmenu + --- The Detailed Node Listing --- + +Getting started + +* Platforms:: +* Downloading:: +* Installation:: +* Running:: +* Setup Tuning:: + +Downloading @SLIME{} + +* Git:: +* Git Incantations:: + +Setup Tuning + +* Basic customization:: +* Multiple Lisps:: +* Loading Swank faster:: + +Using @SLIME{} mode + +* User-interface conventions:: +* Evaluation:: +* Compilation:: +* Completion:: +* Finding definitions:: +* Documentation:: +* Cross-reference:: +* Macro-expansion:: +* Disassembly:: +* Recovery:: +* Inspector:: +* Profiling:: +* Other:: +* Semantic indentation:: +* Reader conditionals:: + +User-interface conventions + +* Temporary buffers:: +* Inferior-lisp:: +* Multithreading:: +* Key bindings:: + +SLDB: the @SLIME{} debugger + +* Examining frames:: +* Restarts:: +* Frame Navigation:: +* Stepping:: +* Miscellaneous:: + +Misc + +* slime-selector:: +* slime-macroexpansion-minor-mode:: +* Multiple connections:: + +Customization + +* Emacs-side customization:: +* Lisp-side:: + +Emacs-side + +* Hooks:: + +Lisp-side (Swank) + +* Communication style:: +* Other configurables:: + +Tips and Tricks + +* Connecting to a remote lisp:: +* Global IO Redirection:: +* Auto-SLIME:: + +Connecting to a remote lisp + +* Setting up the lisp image:: +* Setting up Emacs:: +* Setting up pathname translations:: + +Contributed Packages + +* Loading Contribs:: +* REPL:: +* slime-mrepl:: +* inferior-slime-mode:: +* Compound Completion:: +* Fuzzy Completion:: +* slime-autodoc-mode:: +* ASDF:: +* Banner:: +* Editing Commands:: +* Fancy Inspector:: +* Presentations:: +* Typeout frames:: +* TRAMP:: +* Documentation Links:: +* Xref and Class Browser:: +* Highlight Edits:: +* Scratch Buffer:: +* SLIME Trace Dialog:: +* slime-sprof:: +* slime-fancy:: +* Quicklisp:: + +REPL: the ``top level'' + +* REPL commands:: +* Input Navigation:: +* Shortcuts:: + +@end detailmenu +@end menu + +@c ----------------------- +@node Introduction +@chapter Introduction + +@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 @code{slime-mode}, an +Emacs minor-mode that complements the standard @code{lisp-mode}. While +@code{lisp-mode} supports editing Lisp source files, @code{slime-mode} +adds support for interacting with a running Common Lisp process for +compilation, debugging, documentation lookup, and so on. + +The @code{slime-mode} programming environment follows the example of +Emacs's native Emacs Lisp environment. We have also included good +ideas from similar systems (such as @acronym{ILISP}) and some new +ideas of our own. + +@SLIME{} is constructed from two parts: a user-interface written in +Emacs Lisp, and a supporting server program written in Common +Lisp. The two sides are connected together with a socket and +communicate using an @acronym{RPC}-like protocol. + +The Lisp server is primarily written in portable Common Lisp. The +required implementation-specific functionality is specified by a +well-defined interface and implemented separately for each Lisp +implementation. This makes @SLIME{} readily portable. + +@c ----------------------- +@node Getting started +@chapter Getting started + +This chapter tells you how to get @SLIME{} up and running. + +@menu +* Platforms:: +* Downloading:: +* Installation:: +* Running:: +* Setup Tuning:: +@end menu + +@c ----------------------- +@node Platforms +@section Supported Platforms + +@SLIME{} supports a wide range of operating systems and Lisp +implementations. @SLIME{} runs on Unix systems, Mac OSX, and Microsoft +Windows. GNU Emacs versions 24 and 23.4 are supported. @emph{XEmacs is +not supported anymore}. + +The supported Lisp implementations, roughly ordered from the +best-supported, are: + +@itemize @bullet +@item +CMU Common Lisp (@acronym{CMUCL}), 19d or newer +@item +Steel Bank Common Lisp (@acronym{SBCL}), 1.0 or newer +@item +Clozure Common Lisp (@acronym{CCL}), version 1.3 or newer +@item +LispWorks, version 4.3 or newer +@item +Allegro Common Lisp (@acronym{ACL}), version 6 or newer +@item +@acronym{CLISP}, version 2.35 or newer +@item +Armed Bear Common Lisp (@acronym{ABCL}) +@item +Corman Common Lisp, version 2.51 or newer with the +patches from @url{http://www.grumblesmurf.org/lisp/corman-patches}) +@item +Scieneer Common Lisp (@acronym{SCL}), version 1.2.7 or newer +@item +Embedded Common Lisp (@acronym{ECL}) +@end itemize + +Most features work uniformly across implementations, but some are +prone to variation. These include the precision of placing +compiler-note annotations, @acronym{XREF} support, and fancy debugger +commands (like ``restart frame''). + +@c ----------------------- +@node Downloading +@section Downloading SLIME + +You can choose between using a released version of @SLIME{} or +accessing our @Git{} repository directly. You can download the latest +released version from our website: + +@url{http://github.com/slime/slime/} + +We recommend that users who participate in the @code{slime-devel} +mailing list use the @Git{} version of the code. + +@menu +* Git:: +* Git Incantations:: +@end menu + +@c ----------------------- +@node Git +@subsection Downloading from Git + +@SLIME{} is available from the @Git{} repository on +@file{github.com}. You have the option to use either the very latest +code or the tagged @code{FAIRLY-STABLE} snapshot. + +The latest version tends to have more features and fewer bugs than the +@code{FAIRLY-STABLE} version, but it can be unstable during times of +major surgery. As a rule-of-thumb recommendation we suggest that if +you follow the @code{slime-devel} mailing list then you're better off +with the latest version (we'll send a note when it's undergoing major +hacking). If you don't follow the mailing list you won't know the +status of the latest code, so tracking @code{FAIRLY-STABLE} or using a +released version is the safe option. + +If you download from @Git{} then remember to @code{git pull} +occasionally. Improvements are continually being committed, and the +@code{FAIRLY-STABLE} tag is moved forward from time to time. + +@c ----------------------- +@node Git Incantations +@subsection Git incantations + +To download the very latest @SLIME{} you first configure +your @code{GitROOT} and login to the repository. + +@example +git clone https://github.com/slime/slime.git +@end example + +You might substitute @code{https} for @code{http} if you're having +problems with that protocol. + +If you want to hack on @SLIME{}, use Github's @emph{fork} functionality +and submit a @emph{pull request}. Be sure to first read the +@uref{https://github.com/slime/slime/blob/master/CONTRIBUTING.md,,CONTRIBUTING.md} file first. + + +@c ----------------------- +@node Installation +@section Installation + +The easiest way to install and keep @SLIME{} up-to-date is using +Emacs's built-in package manager. @SLIME{} is available from the +@uref{http://melpa.org,,MELPA} repository. After +@uref{http://melpa.org/#/getting-started,,setting up the MELPA repository}, +@SLIME{} can be installed via @kbd{M-x package-install RET slime RET}. +You should then define your default Lisp in your @file{.emacs} as follows: + +@example +(setq inferior-lisp-program "/opt/sbcl/bin/sbcl") +@end example + +At this point, you should be ready to start @ref{Running,,running SLIME}. + +This is the minimal configuration with the fewest frills. If the +basic setup is working, you can try additional modules (@ref{Loading +Contribs}). + +@subsection Installing from Git + +If you'd rather install @SLIME{} directly from its +@uref{https://github.com/slime/slime,,git repository}, you will need +to add a few extra lines in your @file{.emacs}: + +@vindex inferior-lisp-program +@vindex load-path +@example +;; @emph{Setup load-path, autoloads and your lisp system} +;; @emph{Not needed if you install SLIME via MELPA} +(add-to-list 'load-path "~/dir/to/cloned/slime") +(require 'slime-autoloads) +(setq inferior-lisp-program "/opt/sbcl/bin/sbcl") +@end example + +You may optionally byte-compile @SLIME{} using @code{make compile +contrib-compile}. + + +@c ----------------------- +@node Running +@section Running SLIME + +@SLIME{} is started with the Emacs command @kbd{M-x slime}. This uses +the @code{inferior-lisp} package to start a Lisp process, loads and +starts the Lisp-side server (known as ``Swank''), and establishes a +socket connection between Emacs and Lisp. Finally a @REPL{} buffer is +created where you can enter Lisp expressions for evaluation. + +At this point @SLIME{} is up and running and you can start exploring. + +@node Setup Tuning +@section Setup Tuning + +This section explains ways to perform basic extensions to @SLIME{}, and +how to configure @SLIME{} for multiple Lisp systems and how to reduce +@SLIME{}'s startup time. + +Please proceed with this section only if your basic setup works. If +you are happy with the basic setup, skip this section. + +For contrib modules @pxref{Loading Contribs}. + +@menu +* Basic customization:: +* Multiple Lisps:: +* Loading Swank faster:: +@end menu + +@node Basic customization +@subsection Basic customization + +Once you have the basic no-frills setup working, you can enhance your +@SLIME{} installation with bundled extensions: + +@example +;; @emph{Setup load-path, autoloads and your lisp system} +(add-to-list 'load-path "~/dir/to/cloned/slime") +(require 'slime-autoloads) +;; @emph{Also setup the slime-fancy contrib} +(add-to-list 'slime-contribs 'slime-fancy) +@end example + +See @pxref{Loading Contribs} for more information on @SLIME{}'s +contrib system. + +To customize a particular binding in one of @SLIME{}'s keymaps, you +can add one of the following to your init file: + +@example +(add-hook 'slime-load-hook + (lambda () + (define-key slime-prefix-map (kbd "M-h") 'slime-documentation-lookup))) +@end example + +The former technique works only for @SLIME{}'s core keymaps, not it's +contribs'. For those you can use the latter form which works for any +Emacs library. See also @pxref{Customization} for more advanced +configuration options. + +@node Multiple Lisps +@subsection Multiple Lisps + +By default, the command @kbd{M-x slime} starts the program specified +with @code{inferior-lisp-program}. If you invoke @kbd{M-x slime} with +a prefix argument, Emacs prompts for the program which should be +started instead. If you need that frequently or if the command +involves long filenames it's more convenient to set the +@code{slime-lisp-implementations} variable in your @file{.emacs}. For +example here we define two programs: + +@vindex slime-lisp-implementations +@lisp +(setq slime-lisp-implementations + '((cmucl ("cmucl" "-quiet")) + (sbcl ("/opt/sbcl/bin/sbcl") :coding-system utf-8-unix))) +@end lisp + +@vindex slime-default-lisp +This variable holds a list of programs and if you invoke @SLIME{} with +a negative prefix argument, @kbd{M-- M-x slime}, you can select a +program from that list. When called without a prefix, either the name +specified in @code{slime-default-lisp}, or the first item of the list will be used. +The elements of the list should look like + +@lisp +(NAME (PROGRAM PROGRAM-ARGS...) &key CODING-SYSTEM INIT INIT-FUNCTION ENV) +@end lisp + +@table @code +@item NAME +is a symbol and is used to identify the program. +@item PROGRAM +is the filename of the program. Note that the filename can contain +spaces. +@item PROGRAM-ARGS +is a list of command line arguments. +@item CODING-SYSTEM +the coding system for the connection. (@pxref{slime-net-coding-system})x +@item INIT +should be a function which takes two arguments: a filename and a +character encoding. The function should return a Lisp expression as a +string which instructs Lisp to start the Swank server and to write the +port number to the file. At startup, @SLIME{} starts the Lisp process +and sends the result of this function to Lisp's standard input. As +default, @code{slime-init-command} is used. An example is shown in +@ref{init-example,,Loading Swank faster}. +@item INIT-FUNCTION +should be a function which takes no arguments. It is called after +the connection is established. (See also @ref{slime-connected-hook}.) +@item ENV +specifies a list of environment variables for the subprocess. E.g. +@lisp +(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/")) +@end lisp +initializes @code{SBCL_HOME} in the subprocess. +@end table + +@node Loading Swank faster +@subsection Loading Swank faster + +For SBCL, we recommend that you create a custom core file with socket +support and @acronym{POSIX} bindings included because those modules +take the most time to load. To create such a core, execute the +following steps: + +@example +shell$ sbcl +* (mapc 'require '(sb-bsd-sockets sb-posix sb-introspect sb-cltl2 asdf)) +* (save-lisp-and-die "sbcl.core-for-slime") +@end example + +After that, add something like this to your @file{.emacs}: + +@lisp +(setq slime-lisp-implementations + '((sbcl ("sbcl" "--core" "sbcl.core-for-slime")))) +@end lisp + +For maximum startup speed you can include the Swank server directly in +a core file. The disadvantage of this approach is that the setup is a +bit more involved and that you need to create a new core file when you +want to update @SLIME{} or @acronym{SBCL}. The steps to execute are: + +@example +shell$ sbcl +* (load ".../slime/swank-loader.lisp") +* (swank-loader:dump-image "sbcl.core-with-swank") +@end example + +@noindent +Then add this to your @file{.emacs}: + +@anchor{init-example} +@lisp +(setq slime-lisp-implementations + '((sbcl ("sbcl" "--core" "sbcl.core-with-swank") + :init (lambda (port-file _) + (format "(swank:start-server %S)\n" port-file))))) +@end lisp + +@noindent +Similar setups should also work for other Lisp implementations. + +@node SLIME mode +@chapter Using Slime mode + +@SLIME{}'s commands are provided via @code{slime-mode}, a minor-mode +used in conjunction with Emacs's @code{lisp-mode}. This chapter +describes the @code{slime-mode} and its relatives. + +@menu +* User-interface conventions:: +* Evaluation:: +* Compilation:: +* Completion:: +* Finding definitions:: +* Documentation:: +* Cross-reference:: +* Macro-expansion:: +* Disassembly:: +* Recovery:: +* Inspector:: +* Profiling:: +* Other:: +* Semantic indentation:: +* Reader conditionals:: +@end menu + +@c ----------------------- +@node User-interface conventions +@section User-interface conventions + +To use @SLIME{} comfortably it is important to understand a few +``global'' user-interface characteristics. The most important +principles are described in this section. + +@menu +* Temporary buffers:: +* Inferior-lisp:: +* Multithreading:: +* Key bindings:: +@end menu + +@c ----------------------- +@node Temporary buffers +@subsection Temporary buffers + +Some @SLIME{} commands create temporary buffers to display their +results. Although these buffers usually have their own special-purpose +major-modes, certain conventions are observed throughout. + +Temporary buffers can be dismissed by pressing @kbd{q}. This kills the +buffer and restores the window configuration as it was before the +buffer was displayed. Temporary buffers can also be killed with the +usual commands like @code{kill-buffer}, in which case the previous +window configuration won't be restored. + +Pressing @kbd{RET} is supposed to ``do the most obvious useful +thing.'' For instance, in an apropos buffer this prints a full +description of the symbol at point, and in an @acronym{XREF} buffer it +displays the source code for the reference at point. This convention +is inherited from Emacs's own buffers for apropos listings, +compilation results, etc. + +Temporary buffers containing Lisp symbols use @code{slime-mode} in +addition to any special mode of their own. This makes the usual +@SLIME{} commands available for describing symbols, looking up +function definitions, and so on. + +@vindex slime-description-autofocus +Initial focus of those ``description'' buffers depends on the variable +@code{slime-description-autofocus}. If @code{nil} (the default), +description buffers do not receive focus automatically, and vice +versa. + +@c ----------------------- +@node Inferior-lisp +@subsection @code{*inferior-lisp*} buffer + +@SLIME{} internally uses the @code{comint} package to start Lisp +processes. This has a few user-visible consequences, some good and +some not-so-terribly. To avoid confusion it is useful to understand +the interactions. + +The buffer @code{*inferior-lisp*} contains the Lisp process's own +top-level. This direct access to Lisp is useful for troubleshooting, +and some degree of @SLIME{} integration is available using the +inferior-slime-mode. Many people load the better integrated @SLIME{} +@REPL{} contrib module (@pxref{REPL}) and ignore +the @code{*inferior-lisp*} buffer. (@pxref{Loading Contribs} for +information on how to enable the REPL.) + +@c ----------------------- +@node Multithreading +@subsection Multithreading + +If the Lisp system supports multithreading, SLIME spawns a new thread +for each request, e.g., @kbd{C-x C-e} creates a new thread to evaluate +the expression. An exception to this rule are requests from the +@REPL{}: all commands entered in the @REPL{} buffer are evaluated in a +dedicated @REPL{} thread. + +Some complications arise with multithreading and special variables. +Non-global special bindings are thread-local, e.g., changing the value +of a let bound special variable in one thread has no effect on the +binding of the variables with the same name in other threads. This +makes it sometimes difficult to change the printer or reader behaviour +for new threads. The variable +@code{swank:*default-worker-thread-bindings*} was introduced for such +situations: instead of modifying the global value of a variable, add a +binding the @code{swank:*default-worker-thread-bindings*}. E.g., with +the following code, new threads will read floating point values as +doubles by default: + +@example +(push '(*read-default-float-format* . double-float) + swank:*default-worker-thread-bindings*). +@end example + + +@node Key bindings +@subsection Key bindings + +In general we try to make our key bindings fit with the overall Emacs +style. We also have the following somewhat unusual convention of our +own: when entering a three-key sequence, the final key can be pressed +either with control or unmodified. For example, the +@code{slime-describe-symbol} command is bound to @kbd{C-c C-d d}, but +it also works to type @kbd{C-c C-d C-d}. We're simply binding both key +sequences because some people like to hold control for all three keys +and others don't, and with the two-key prefix we're not afraid of +running out of keys. + +There is one exception to this rule, just to trip you up. We never +bind @kbd{C-h} anywhere in a key sequence, so @kbd{C-c C-d C-h} +doesn't do the same thing as @kbd{C-c C-d h}. This is because Emacs +has a built-in default so that typing a prefix followed by @kbd{C-h} +will display all bindings starting with that prefix, so @kbd{C-c C-d +C-h} will actually list the bindings for all documentation commands. +This feature is just a bit too useful to clobber! + +@quotation +@i{``Are you deliberately spiting Emacs's brilliant online help facilities? The gods will be angry!''} +@end quotation + +@noindent This is a brilliant piece of advice. The Emacs online help facilities +are your most immediate, up-to-date and complete resource for keybinding +information. They are your friends: + +@table @kbd +@kbdanchorc{C-h k , describe-key, ``What does this key do?''} +Describes current function bound to @kbd{} for focus buffer. + +@kbdanchorc{C-h b, describe-bindings, ``Exactly what bindings are available?''} +Lists the current key-bindings for the focus buffer. + +@kbdanchorc{C-h m, describe-mode, ``Tell me all about this mode''} +Shows all the available major mode keys, then the minor mode keys, for +the modes of the focus buffer. + +@kbdanchorc{C-h l, view-lossage, ``Woah@comma{} what key chord did I just do?''} +Shows you the literal sequence of keys you've pressed in order. + +@c is breaks links PDF, despite that it's not l it's C-h +@c @kbdanchorc{ l, , ``What starts with?''} +@c Lists all keybindings that begin with @code{} for the focus buffer mode. + + +@end table + +@emph{Note:} In this documentation the designation @kbd{C-h} is a +@dfn{canonical key} which might actually mean Ctrl-h, or F1, or +whatever you have @code{help-command} bound to in your +@code{.emacs}. Here is a common situation: + +@example +(global-set-key [f1] 'help-command) +(global-set-key "\C-h" 'delete-backward-char) +@end example + +@noindent In this situation everywhere you see @kbd{C-h} in the +documentation you would substitute @kbd{F1}. + +You can assign or change default key bindings globally using the +@code{global-set-key} function in your @file{~/.emacs} file like this: +@example +(global-set-key "\C-c s" 'slime-selector) +@end example +@noindent +which binds @kbd{C-c s} to the function @code{slime-selector}. + +Alternatively, if you want to assign or change a key binding in just a +particular slime mode, you can use the @code{define-key} function +in your @file{~/.emacs} file like this: +@example +(define-key slime-repl-mode-map (kbd "C-c ;") + 'slime-insert-balanced-comments) +@end example +@noindent +which binds @kbd{C-c ;} to the function +@code{slime-insert-balanced-comments} in the REPL buffer. + +@c ----------------------- +@node Evaluation +@section Evaluation commands + +These commands each evaluate a Common Lisp expression in a different +way. Usually they mimic commands for evaluating Emacs Lisp code. By +default they show their results in the echo area, but a prefix +argument causes the results to be inserted in the current buffer. + +@table @kbd + +@kbditem{C-x C-e, slime-eval-last-expression} + +Evaluate the expression before point and show the result in the echo +area. + +@kbditem{C-M-x, slime-eval-defun} +Evaluate the current toplevel form and show the result in the echo +area. `C-M-x' treats `defvar' expressions specially. Normally, +evaluating a `defvar' expression does nothing if the variable it +defines already has a value. But `C-M-x' unconditionally resets the +variable to the initial value specified in the `defvar' expression. +This special feature is convenient for debugging Lisp programs. + +@end table + +If @kbd{C-M-x} or @kbd{C-x C-e} is given a numeric argument, it +inserts the value into the current buffer, rather than displaying it +in the echo area. + +@table @kbd +@kbditem{C-c :, slime-interactive-eval} +Evaluate an expression read from the minibuffer. + +@kbditem{C-c C-r, slime-eval-region} +Evaluate the region. + +@kbditem{C-c C-p, slime-pprint-eval-last-expression} +Evaluate the expression before point and pretty-print the result in a +fresh buffer. + +@kbditem{C-c E, slime-edit-value} +Edit the value of a setf-able form in a new buffer @file{*Edit
*}. +The value is inserted into a temporary buffer for editing and then set +in Lisp when committed with @kbd{C-c C-c}. + +@kbditem{C-c C-u, slime-undefine-function} +Undefine the function, with @code{fmakunbound}, for the symbol at +point. + +@end table + +@c ----------------------- +@node Compilation +@section Compilation commands + +@cindex Compilation + +@SLIME{} has fancy commands for compiling functions, files, and +packages. The fancy part is that notes and warnings offered by the +Lisp compiler are intercepted and annotated directly onto the +corresponding expressions in the Lisp source buffer. (Give it a try to +see what this means.) + +@table @kbd +@cindex Compiling Functions +@kbditem{C-c C-c, slime-compile-defun} +Compile the top-level form at point. The region blinks shortly to +give some feedback which part was chosen. + +With (positive) prefix argument the form is compiled with maximal +debug settings (@kbd{C-u C-c C-c}). With negative prefix argument it is compiled for +speed (@kbd{M-- C-c C-c}). If a numeric argument is passed set debug or speed settings +to it depending on its sign. + +The code for the region is executed after compilation. In principle, +the command writes the region to a file, compiles that file, and loads +the resulting code. + +@kbditem{C-c C-k, slime-compile-and-load-file} +Compile and load the current buffer's source file. If the compilation +step fails, the file is not loaded. It's not always easy to tell +whether the compilation failed: occasionally you may end up in the +debugger during the load step. + +With (positive) prefix argument the file is compiled with maximal +debug settings (@kbd{C-u C-c C-k}). With negative prefix argument it is compiled for +speed (@kbd{M-- C-c C-k}). If a numeric argument is passed set debug or speed settings +to it depending on its sign. + +@kbditem{C-c M-k, slime-compile-file} +Compile (but don't load) the current buffer's source file. + +@kbditem{C-c C-l, slime-load-file} +Load a Lisp file. This command uses the Common Lisp LOAD function. + +@cmditem{slime-compile-region} +Compile the selected region. + +@end table + +The annotations are indicated as underlining on source forms. The +compiler message associated with an annotation can be read either by +placing the mouse over the text or with the selection commands below. + +@table @kbd +@kbditem{M-n, slime-next-note} +Move the point to the next compiler note and displays the note. + +@kbditem{M-p, slime-previous-note} +Move the point to the previous compiler note and displays the note. + +@kbditem{C-c M-c, slime-remove-notes} +Remove all annotations from the buffer. + +@kbditem{C-x `, next-error} +Visit the next-error message. This is not actually a @SLIME{} command +but @SLIME{} creates a hidden buffer so that most of the Compilation +mode commands (@inforef{Compilation Mode,, emacs}) work similarly for +Lisp as for batch compilers. + +@end table + +@node Completion +@section Completion commands + +@cindex Completion +@cindex Symbol Completion + +Completion commands are used to complete a symbol or form based on +what is already present at point. Classical completion assumes an +exact prefix and gives choices only where branches may occur. Fuzzy +completion tries harder. + +@table @kbd +@kbditem{M-TAB,slime-complete-symbol} +@c @itemx ESC TAB +@c @itemx C-M-i +Complete the symbol at point. Note that three styles of completion are +available in @SLIME{}; the default is similar to normal Emacs +completion (@pxref{slime-completion-at-point-functions}). + +@end table + +@c ----------------------- +@node Finding definitions +@section Finding definitions (``Meta-Point'' commands). + +@cindex Meta-dot +@cindex TAGS + +The familiar @kbd{M-.} command is provided. For generic functions this +command finds all methods, and with some systems it does other fancy +things (like tracing structure accessors to their @code{DEFSTRUCT} +definition). + +@table @kbd + +@kbditem{M-., slime-edit-definition} +Go to the definition of the symbol at point. + +@item M-, +@itemx M-* +@itemx M-x slime-pop-find-definition-stack +@kindex M-, +@findex slime-pop-find-definition-stack +Go back to the point where @kbd{M-.} was invoked. This gives multi-level +backtracking when @kbd{M-.} has been used several times. + +@kbditem{C-x 4 ., slime-edit-definition-other-window} +Like @code{slime-edit-definition} but switches to the other window to +edit the definition in. + +@kbditem{C-x 5 ., slime-edit-definition-other-frame} +Like @code{slime-edit-definition} but opens another frame to edit the +definition in. + +@cmditem{slime-edit-definition-with-etags} +Use an ETAGS table to find definition at point. + +@end table + +@c ----------------------- +@node Documentation +@section Documentation commands + +@SLIME{}'s online documentation commands follow the example of Emacs +Lisp. The commands all share the common prefix @kbd{C-c C-d} and allow +the final key to be modified or unmodified (@pxref{Key bindings}.) + +@table @kbd + +@kbditem{SPC, slime-space} +The space key inserts a space, but also looks up and displays the +argument list for the function at point, if there is one. + +@kbditem{C-c C-d d, slime-describe-symbol} +Describe the symbol at point. + +@kbditem{C-c C-d f, slime-describe-function} +Describe the function at point. + +@kbditem{C-c C-d A, slime-apropos} +Perform an apropos search on Lisp symbol names for a regular expression +match and display their documentation strings. By default the external +symbols of all packages are searched. With a prefix argument you can choose a +specific package and whether to include unexported symbols. + +@kbditem{C-c C-d z, slime-apropos-all} +Like @code{slime-apropos} but also includes internal symbols by default. + +@kbditem{C-c C-d p, slime-apropos-package} +Show apropos results of all symbols in a package. This command is for +browsing a package at a high-level. With package-name completion it +also serves as a rudimentary Smalltalk-ish image-browser. + +@kbditem{C-c C-d h, slime-hyperspec-lookup} +Lookup the symbol at point in the @cite{Common Lisp Hyperspec}. This +uses the familiar @file{hyperspec.el} to show the appropriate section +in a web browser. The Hyperspec is found either on the Web or in +@code{common-lisp-hyperspec-root}, and the browser is selected by +@code{browse-url-browser-function}. + +Note: this is one case where @kbd{C-c C-d h} is @emph{not} the same as +@kbd{C-c C-d C-h}. + +@kbditem{C-c C-d ~, hyperspec-lookup-format} +Lookup a @emph{format character} in the @cite{Common Lisp Hyperspec}. + +@kbditem{C-c C-d #, hyperspec-lookup-reader-macro} +Lookup a @emph{reader macro} in the @cite{Common Lisp Hyperspec}. +@end table + +@c ----------------------- +@node Cross-reference +@section Cross-reference commands + +@cindex xref +@cindex Cross-referencing + +@SLIME{}'s cross-reference commands are based on the support provided +by the Lisp system, which varies widely between Lisps. For systems +with no built-in @acronym{XREF} support @SLIME{} queries a portable +@acronym{XREF} package, which is taken from the @cite{CMU AI +Repository} and bundled with @SLIME{}. + +Each command operates on the symbol at point, or prompts if there is +none. With a prefix argument they always prompt. You can either enter +the key bindings as shown here or with the control modified on the +last key, @xref{Key bindings}. + +@menu +* Xref buffer commands:: +@end menu + +@table @kbd +@kbditem{C-c C-w c, slime-who-calls} +Show function callers. + +@kbditem{C-c C-w w, slime-calls-who} +Show all known callees. + +@kbditem{C-c C-w r, slime-who-references} +Show references to global variable. + +@kbditem{C-c C-w b, slime-who-binds} +Show bindings of a global variable. + +@kbditem{C-c C-w s, slime-who-sets} +Show assignments to a global variable. + +@kbditem{C-c C-w m, slime-who-macroexpands} +Show expansions of a macro. + +@cmditem{slime-who-specializes} +Show all known methods specialized on a class. + +@end table + +There are also ``List callers/callees'' commands. These operate by +rummaging through function objects on the heap at a low-level to +discover the call graph. They are only available with some Lisp +systems, and are most useful as a fallback when precise @acronym{XREF} +information is unavailable. + +@table @kbd +@kbditem{C-c <, slime-list-callers} +List callers of a function. + +@kbditem{C-c >, slime-list-callees} +List callees of a function. + +@end table + +@node Xref buffer commands +@subsection Xref buffer commands +Commands available in Xref buffers +@table @kbd + +@kbditem{RET, slime-show-xref} +Show definition at point in the other window. Do not leave Xref buffer. + +@kbditem{Space, slime-goto-xref} +Show definition at point in the other window and close Xref buffer. + +@kbditem{C-c C-c, slime-recompile-xref} +Recompile definition at point. + +@kbditem{C-c C-k, slime-recompile-all-xrefs} +Recompile all definitions. + +@end table + +@c ----------------------- +@node Macro-expansion +@section Macro-expansion commands + +@cindex Macros + +@table @kbd +@kbditem{C-c C-m, slime-expand-1} +Macroexpand (or compiler-macroexpand) the expression starting at point +once. If invoked with a prefix argument use macroexpand instead or +macroexpand-1 (or compiler-macroexpand instead of +compiler-macroexpand-1). + +@cmditem{slime-macroexpand-1} +Macroexpand the expression starting at point once. If invoked with a +prefix argument, use macroexpand instead of macroexpand-1. + +@kbditem{C-c M-m, slime-macroexpand-all} +Fully macroexpand the expression starting at point. + +@cmditem{slime-compiler-macroexpand-1} +Display the compiler-macro expansion of sexp starting at point. + +@cmditem{slime-compiler-macroexpand} +Repeatedy expand compiler macros of sexp starting at point. + +@end table + +For additional minor-mode commands and discussion, +@pxref{slime-macroexpansion-minor-mode}. + + +@c ----------------------- +@node Disassembly +@section Disassembly commands + +@table @kbd + +@kbditem{C-c M-d, slime-disassemble-symbol} +Disassemble the function definition of the symbol at point. + +@kbditem{C-c C-t, slime-toggle-trace-fdefinition} +Toggle tracing of the function at point. If invoked with a prefix +argument, read additional information, like which particular method +should be traced. + +@cmditem{slime-untrace-all} +Untrace all functions. + +@end table + +@c ----------------------- +@node Recovery +@section Abort/Recovery commands + +@table @kbd +@kbditem{C-c C-b, slime-interrupt} +Interrupt Lisp (send @code{SIGINT}). + +@cmditem{slime-restart-inferior-lisp} +Restart the @code{inferior-lisp} process. + +@kbditem{C-c ~, slime-sync-package-and-default-directory} +Synchronize the current package and working directory from Emacs to +Lisp. + +@kbditem{C-c M-p, slime-repl-set-package} +Set the current package of the @acronym{REPL}. + +@cmditem{slime-cd} +Set the current directory of the Lisp process. This also +changes the current directory of the REPL buffer. + +@cmditem{slime-pwd} +Print the current directory of the Lisp process. + +@end table + +@c ----------------------- +@node Inspector +@section Inspector commands + +The @SLIME{} inspector is a Emacs-based alternative to the +standard @code{INSPECT} function. The inspector presents objects in +Emacs buffers using a combination of plain text, hyperlinks to related +objects. + +The inspector can easily be specialized for the objects in your own +programs. For details see the @code{inspect-for-emacs} generic +function in @file{swank/backend.lisp}. + +@table @kbd + +@kbditem{C-c I, slime-inspect} +Inspect the value of an expression entered in the minibuffer. + +@end table + +The standard commands available in the inspector are: + +@table @kbd + +@kbditem{RET, slime-inspector-operate-on-point} +If point is on a value then recursively call the inspector on that +value. If point is on an action then call that action. + +@kbditem{d, slime-inspector-describe} +Describe the slot at point. + +@kbditem{e, slime-inspector-eval} +Evaluate an expression in the context of the inspected object. The +variable @code{*} will be bound to the inspected object. + +@kbditem{v, slime-inspector-toggle-verbose} +Toggle between verbose and terse mode. Default is determined by +`swank:*inspector-verbose*'. + +@kbditem{l, slime-inspector-pop} +Go back to the previous object (return from @kbd{RET}). + +@kbditem{n, slime-inspector-next} +The inverse of @kbd{l}. Also bound to @kbd{SPC}. + +@kbditem{g, slime-inspector-reinspect} +Reinspect. + +@kbditem{q, slime-inspector-quit} +Dismiss the inspector buffer. + +@kbditem{p, slime-inspector-pprint} +Pretty print in another buffer object at point. + +@kbditem{., slime-inspector-show-source} +Find source of object at point. + +@kbditem{>, slime-inspector-fetch-all} +Fetch all inspector contents and go to the end. + +@kbditem{M-RET, slime-inspector-copy-down} +Store the value under point in the variable `*'. This can +then be used to access the object in the REPL. + +@kbditempair{TAB, S-TAB, slime-inspector-next-inspectable-object, slime-inspector-previous-inspectable-object} + +Jump to the next and previous inspectable object respectively. + +@end table + +@c ----------------------- +@node Profiling +@section Profiling commands + +The profiling commands are based on CMUCL's profiler. These are +simple wrappers around functions which usually print something to the +output buffer. + +@table @kbd +@cmditem{slime-toggle-profile-fdefinition} +Toggle profiling of a function. +@cmditem{slime-profile-package} +Profile all functions in a package. +@cmditem{slime-profile-by-substring} +Profile all functions which names contain a substring. +@cmditem{slime-unprofile-all} +Unprofile all functions. +@cmditem{slime-profile-report} +Report profiler data. +@cmditem{slime-profile-reset} +Reset profiler data. +@cmditem{slime-profiled-functions} +Show list of currently profiled functions. +@end table + +@c ----------------------- +@node Other +@section Shadowed Commands + +@table @kbd + +@kbditempair{C-c C-a, C-c C-v, slime-nop, slime-nop} +This key-binding is shadowed from inf-lisp. + +@end table + +@c ----------------------- +@node Semantic indentation +@section Semantic indentation + +@SLIME{} automatically discovers how to indent the macros in your Lisp +system. To do this the Lisp side scans all the macros in the system and +reports to Emacs all the ones with @code{&body} arguments. Emacs then +indents these specially, putting the first arguments four spaces in and +the ``body'' arguments just two spaces, as usual. + +This should ``just work.'' If you are a lucky sort of person you needn't +read the rest of this section. + +To simplify the implementation, @SLIME{} doesn't distinguish between +macros with the same symbol-name but different packages. This makes it +fit nicely with Emacs's indentation code. However, if you do have +several macros with the same symbol-name then they will all be indented +the same way, arbitrarily using the style from one of their +arglists. You can find out which symbols are involved in collisions +with: + +@example +(swank:print-indentation-lossage) +@end example + +If a collision causes you irritation, don't have a nervous breakdown, +just override the Elisp symbol's @code{common-lisp-indent-function} +property to your taste. @SLIME{} won't override your custom settings, it +just tries to give you good defaults. + +A more subtle issue is that imperfect caching is used for the sake of +performance. @footnote{@emph{Of course} we made sure it was actually too +slow before making the ugly optimization.} + +In an ideal world, Lisp would automatically scan every symbol for +indentation changes after each command from Emacs. However, this is too +expensive to do every time. Instead Lisp usually just scans the symbols +whose home package matches the one used by the Emacs buffer where the +request comes from. That is sufficient to pick up the indentation of +most interactively-defined macros. To catch the rest we make a full scan +of every symbol each time a new Lisp package is created between commands +-- that takes care of things like new systems being loaded. + +You can use @kbd{M-x slime-update-indentation} to force all symbols to +be scanned for indentation information. + +@c ----------------------- +@node Reader conditionals +@section Reader conditional fontification + +@SLIME{} automatically evaluates reader-conditional expressions, like +@code{#+linux}, in source buffers and ``grays out'' code that will be +skipped for the current Lisp connection. + +@c ----------------------- +@node Debugger +@chapter SLDB: the SLIME debugger + +@cindex Debugger + +@SLIME{} has a custom Emacs-based debugger called @SLDB{}. Conditions +signalled in the Lisp system invoke @SLDB{} in Emacs by way of the +Lisp @code{*DEBUGGER-HOOK*}. + +@SLDB{} pops up a buffer when a condition is signalled. The buffer +displays a description of the condition, a list of restarts, and a +backtrace. Commands are offered for invoking restarts, examining the +backtrace, and poking around in stack frames. + +@menu +* Examining frames:: +* Restarts:: +* Frame Navigation:: +* Stepping:: +* Miscellaneous:: +@end menu + +@c ----------------------- +@node Examining frames +@section Examining frames + +Commands for examining the stack frame at point. + +@table @kbd +@kbditem{t, sldb-toggle-details} +Toggle display of local variables and @code{CATCH} tags. + +@kbditem{v, sldb-show-source} +View the frame's current source expression. The expression is +presented in the Lisp source file's buffer. + +@kbditem{e, sldb-eval-in-frame} +Evaluate an expression in the frame. The expression can refer to the +available local variables in the frame. + +@kbditem{d, sldb-pprint-eval-in-frame} +Evaluate an expression in the frame and pretty-print the result in a +temporary buffer. + +@kbditem{D, sldb-disassemble} +Disassemble the frame's function. Includes information such as the +instruction pointer within the frame. + +@kbditem{i, sldb-inspect-in-frame} +Inspect the result of evaluating an expression in the frame. + +@kbditem{C-c C-c, sldb-recompile-frame-source} +Recompile frame. @kbd{C-u C-c C-c} for recompiling with maximum debug settings. + +@end table + +@c ----------------------- +@node Restarts +@section Invoking restarts + +@table @kbd +@kbditem{a, sldb-abort} +Invoke the @code{ABORT} restart. + +@anchor{sldb-quit} +@kbditem{q, sldb-quit} +``Quit'' -- For @SLIME{} evaluation requests, invoke a restart which +restores to a known program state. For errors in other threads, see +@ref{*SLDB-QUIT-RESTART*}. + +@kbditem{c, sldb-continue} +Invoke the @code{CONTINUE} restart. + +@item 0 ... 9 +Invoke a restart by number. +@end table + +Restarts can also be invoked by pressing @kbd{RET} or @kbd{Mouse-2} on +them in the buffer. + +@c ----------------------- +@node Frame Navigation +@section Navigating between frames + +@table @kbd +@kbditempair{n,p,sldb-down,sldb-up} +Move between frames. + +@kbditempair{M-n, M-p, sldb-details-down, sldb-details-up} +Move between frames ``with sugar'': hide the details of the original +frame and display the details and source code of the next. Sugared +motion makes you see the details and source code for the current frame +only. + +@kbditem{>, sldb-end-of-backtrace} +Fetch the entire backtrace and go to the last frame. + +@kbditem{<, sldb-beginning-of-backtrace} +Goto the first frame. + +@end table + +@node Stepping +@section Stepping + +@cindex Stepping + +Stepping is not available in all implementations and works very +differently in those in which it is available. + +@table @kbd +@kbditem{s, sldb-step} +Step to the next expression in the frame. For CMUCL that means, set a +breakpoint at all those code locations in the current code block which +are reachable from the current code location. + +@kbditem{x, sldb-next} +Step to the next form in the current function. + +@kbditem{o, sldb-out} +Stop single-stepping temporarily, but resume it once the current +function returns. + +@end table + +@node Miscellaneous +@section Miscellaneous Commands + +@table @kbd +@kbditem{r, sldb-restart-frame} +Restart execution of the frame with the same arguments it was +originally called with. (This command is not available in all +implementations.) + +@kbditem{R, sldb-return-from-frame} +Return from the frame with a value entered in the minibuffer. (This +command is not available in all implementations.) + + +@kbditem{B, sldb-break-with-default-debugger} +Exit @SLDB{} and debug the condition using the Lisp system's default +debugger. + +@kbditem{C, sldb-inspect-condition} +Inspect the condition currently being debugged. + +@kbditem{:, slime-interactive-eval} +Evaluate an expression entered in the minibuffer. +@kbditem{A, sldb-break-with-system-debugger} +Attach debugger (e.g. gdb) to the current lisp process. + +@end table + + +@c ----------------------- +@node Misc +@chapter Misc + +@menu +* slime-selector:: +* slime-macroexpansion-minor-mode:: +* Multiple connections:: +@end menu + +@c ----------------------- +@node slime-selector +@section @code{slime-selector} + +The @code{slime-selector} command is for quickly switching to +important buffers: the @REPL{}, @SLDB{}, the Lisp source you were just +hacking, etc. Once invoked the command prompts for a single letter to +specify which buffer it should display. Here are some of the options: + +@table @kbd +@item ? +A help buffer listing all @code{slime-selectors}'s available buffers. +@item r +The @REPL{} buffer for the current @SLIME{} connection. +@item d +The most recently activated @SLDB{} buffer for the current connection. +@item l +The most recently visited @code{lisp-mode} source buffer. +@item s +The @code{*slime-scratch*} buffer (@pxref{slime-scratch}). +@item c +SLIME connections buffer (@pxref{Multiple connections}). +@item n +Cycle to the next Lisp connection (@pxref{Multiple connections}). +@item t +SLIME threads buffer (@pxref{Multiple connections}). +@end table + +@code{slime-selector} doesn't have a key binding by default but we +suggest that you assign it a global one. You can bind it to @kbd{C-c s} +like this: + +@example +(global-set-key "\C-cs" 'slime-selector) +@end example + +@noindent +And then you can switch to the @REPL{} from anywhere with @kbd{C-c s +r}. + +The macro @code{def-slime-selector-method} can be used to define new +buffers for @code{slime-selector} to find. + +@c ----------------------- +@node slime-macroexpansion-minor-mode +@section slime-macroexpansion-minor-mode + +Within a slime macroexpansion buffer some extra commands are provided +(these commands are always available but are only bound to keys in a +macroexpansion buffer). + +@table @kbd +@kbditem{C-c C-m, slime-macroexpand-1-inplace} +Just like slime-macroexpand-1 but the original form is replaced with +the expansion. + +@c @anchor{slime-macroexpand-1-inplace} +@kbditem{g, slime-macroexpand-1-inplace} +The last macroexpansion is performed again, the current contents of +the macroexpansion buffer are replaced with the new expansion. + +@kbditem{q, slime-temp-buffer-quit} +Close the expansion buffer. + +@kbditem{C-_, slime-macroexpand-undo} +Undo last macroexpansion operation. + +@end table + +@c ----------------------- +@node Multiple connections +@section Multiple connections + +@SLIME{} is able to connect to multiple Lisp processes at the same +time. The @kbd{M-x slime} command, when invoked with a prefix +argument, will offer to create an additional Lisp process if one is +already running. This is often convenient, but it requires some +understanding to make sure that your @SLIME{} commands execute in the +Lisp that you expect them to. + +Some buffers are tied to specific Lisp processes. Each Lisp connection +has its own @acronym{REPL} buffer, and all expressions entered or +@SLIME{} commands invoked in that buffer are sent to the associated +connection. Other buffers created by @SLIME{} are similarly tied to +the connections they originate from, including @SLDB{} buffers, +apropos result listings, and so on. These buffers are the result of +some interaction with a Lisp process, so commands in them always go +back to that same process. + +Commands executed in other places, such as @code{slime-mode} source +buffers, always use the ``default'' connection. Usually this is the +most recently established connection, but this can be reassigned via +the ``connection list'' buffer: + +@table @kbd +@kbditem{C-c C-x c, slime-list-connections} +Pop up a buffer listing the established connections. It is also +available by the typing @kbd{c} from the @SLIME{} selector +(@ref{slime-selector}). + +@kbditem{C-c C-x n, slime-cycle-connections} +Change current Lisp connection by cycling through all connections. It +is also available by the typing @kbd{n} from the SLIME selector +(@ref{slime-selector}). + +@kbditem{C-c C-x t, slime-list-threads} +Pop up a buffer listing the current threads. It is also available by +the typing @kbd{t} from the @SLIME{} selector (@ref{slime-selector}). +@end table + +The buffer displayed by @code{slime-list-connections} gives a one-line +summary of each connection. The summary shows the connection's serial +number, the name of the Lisp implementation, and other details of the +Lisp process. The current ``default'' connection is indicated with an +asterisk. + +The commands available in the connection-list buffer are: + +@table @kbd +@kbditem{RET, slime-goto-connection} +Pop to the @acronym{REPL} buffer of the connection at point. + +@kbditem{d, slime-connection-list-make-default} +Make the connection at point the ``default'' connection. It will then +be used for commands in @code{slime-mode} source buffers. + +@kbditem{g, slime-update-connection-list} +Update the connection list in the buffer. + +@kbditem{q, slime-temp-buffer-quit} +Quit the connection list (kill buffer, restore window configuration). + +@kbditem{R, slime-restart-connection-at-point} +Restart the Lisp process for the connection at point. + +@cmditem{slime-connect} +Connect to a running Swank server. + +@cmditem{slime-disconnect} +Disconnect all connections. + +@cmditem{slime-abort-connection} +Abort the current attempt to connect. + +@end table + + +@c ----------------------- +@node Customization +@chapter Customization + +@menu +* Emacs-side customization:: +* Lisp-side:: +@end menu + +@c ----------------------- +@node Emacs-side customization +@section Emacs-side + +The Emacs part of @SLIME{} can be configured with the Emacs +@code{customize} system, just use @kbd{M-x customize-group slime +RET}. Because the customize system is self-describing, we only cover a +few important or obscure configuration options here in the manual. + +@table @code + +@item slime-truncate-lines +The value to use for @code{truncate-lines} in line-by-line summary +buffers popped up by @SLIME{}. This is @code{t} by default, which +ensures that lines do not wrap in backtraces, apropos listings, and so +on. It can however cause information to spill off the screen. + +@anchor{slime-completion-at-point-functions} +@vindex slime-completion-at-point-functions +@item slime-completion-at-point-functions +A list of functions used for completion of Lisp symbols. This works +as the standard +@code{completion-at-point-functions} +(@pxref{Completion in Buffers,,,elisp}). Three completion +styles are available: @code{slime-simple-completion-at-point}, +@code{slime-complete-symbol*} (@pxref{Compound Completion}), +and @code{slime-fuzzy-complete-symbol} (@pxref{Fuzzy Completion}). + +The default is @code{slime-simple-completion-at-point}, which +completes in the usual Emacs way. + +@vindex slime-filename-translations +@item slime-filename-translations +This variable controls filename translation between Emacs and the Lisp +system. It is useful if you run Emacs and Lisp on separate machines +which don't share a common file system or if they share the filesystem +but have different layouts, as is the case with @acronym{SMB}-based +file sharing. + +@anchor{slime-net-coding-system} +@vindex slime-net-coding-system +@cindex Unicode +@cindex UTF-8 +@cindex ASCII +@cindex LATIN-1 +@cindex Character Encoding +@item slime-net-coding-system +If you want to transmit Unicode characters between Emacs and the Lisp +system, you should customize this variable. E.g., if you use SBCL, you +can set: +@example +(setq slime-net-coding-system 'utf-8-unix) +@end example +To actually display Unicode characters you also need appropriate +fonts, otherwise the characters will be rendered as hollow boxes. If +you are using Allegro CL and GNU Emacs, you can also +use @code{emacs-mule-unix} as coding system. GNU Emacs has often +nicer fonts for the latter encoding. (Different encodings can be used +for different Lisps, see @ref{Multiple Lisps}.) + +@end table + +@menu +* Hooks:: +@end menu + +@c ----------------------- +@node Hooks +@subsection Hooks + +@table @code + +@vindex slime-mode-hook +@item slime-mode-hook +This hook is run each time a buffer enters @code{slime-mode}. It is +most useful for setting buffer-local configuration in your Lisp source +buffers. An example use is to enable @code{slime-autodoc-mode} +(@pxref{slime-autodoc-mode}). + +@anchor{slime-connected-hook} +@vindex slime-connected-hook +@item slime-connected-hook +This hook is run when @SLIME{} establishes a connection to a Lisp +server. An example use is to create a Typeout frame (@xref{Typeout frames}.) + +@vindex sldb-hook +@item sldb-hook +This hook is run after @SLDB{} is invoked. The hook functions are +called from the @SLDB{} buffer after it is initialized. An example use +is to add @code{sldb-print-condition} to this hook, which makes all +conditions debugged with @SLDB{} be recorded in the @REPL{} buffer. + +@end table + +@c ----------------------- +@node Lisp-side +@section Lisp-side (Swank) + +The Lisp server side of @SLIME{} (known as ``Swank'') offers several +variables to configure. The initialization file @file{~/.swank.lisp} +is automatically evaluated at startup and can be used to set these +variables. + +@menu +* Communication style:: +* Other configurables:: +@end menu + +@c ----------------------- +@node Communication style +@subsection Communication style +@vindex SWANK:*COMMUNICATION-STYLE* + +The most important configurable is @code{SWANK:*COMMUNICATION-STYLE*}, +which specifies the mechanism by which Lisp reads and processes +protocol messages from Emacs. The choice of communication style has a +global influence on @SLIME{}'s operation. + +The available communication styles are: + +@table @code +@item NIL +This style simply loops reading input from the communication socket +and serves @SLIME{} protocol events as they arise. The simplicity +means that the Lisp cannot do any other processing while under +@SLIME{}'s control. + +@item :FD-HANDLER +This style uses the classical Unix-style ``@code{select()}-loop.'' +Swank registers the communication socket with an event-dispatching +framework (such as @code{SERVE-EVENT} in @acronym{CMUCL} and +@acronym{SBCL}) and receives a callback when data is available. In +this style requests from Emacs are only detected and processed when +Lisp enters the event-loop. This style is simple and predictable. + +@item :SIGIO +This style uses @dfn{signal-driven I/O} with a @code{SIGIO} signal +handler. Lisp receives requests from Emacs along with a signal, +causing it to interrupt whatever it is doing to serve the +request. This style has the advantage of responsiveness, since Emacs +can perform operations in Lisp even while it is busy doing other +things. It also allows Emacs to issue requests concurrently, e.g. to +send one long-running request (like compilation) and then interrupt +that with several short requests before it completes. The +disadvantages are that it may conflict with other uses of @code{SIGIO} +by Lisp code, and it may cause untold havoc by interrupting Lisp at an +awkward moment. + +@item :SPAWN +This style uses multiprocessing support in the Lisp system to execute +each request in a separate thread. This style has similar properties +to @code{:SIGIO}, but it does not use signals and all requests issued +by Emacs can be executed in parallel. + +@end table + +The default request handling style is chosen according to the +capabilities of your Lisp system. The general order of preference is +@code{:SPAWN}, then @code{:SIGIO}, then @code{:FD-HANDLER}, with +@code{NIL} as a last resort. You can check the default style by +calling @code{SWANK-BACKEND::PREFERRED-COMMUNICATION-STYLE}. You can +also override the default by setting +@code{SWANK:*COMMUNICATION-STYLE*} in your Swank init file. + +@c ----------------------- +@node Other configurables +@subsection Other configurables + +These Lisp variables can be configured via your @file{~/.swank.lisp} +file: + +@table @code + +@vindex SWANK:*CONFIGURE-EMACS-INDENTATION* +@item SWANK:*CONFIGURE-EMACS-INDENTATION* +This variable controls whether indentation styles for +@code{&body}-arguments in macros are discovered and sent to Emacs. It +is enabled by default. + +@vindex SWANK:*GLOBALLY-REDIRECT-IO* +@item SWANK:*GLOBALLY-REDIRECT-IO* +When T this causes the standard streams (@code{*standard-output*}, +etc) to be globally redirected to the @REPL{} in Emacs. + +When @code{:STARTED-FROM-EMACS} (default) redirects the output when +the lisp is launched from emacs (i.e. @kbd{M-x slime}), but not +from @kbd{M-x slime-connect}. + +When @code{NIL} these streams are only temporarily redirected +to Emacs using dynamic bindings while handling requests. Note that +@code{*standard-input*} is currently never globally redirected into +Emacs, because it can interact badly with the Lisp's native @REPL{} by +having it try to read from the Emacs one. + +@vindex SWANK:*GLOBAL-DEBUGGER* +@item SWANK:*GLOBAL-DEBUGGER* +When true (the default) this causes @code{*DEBUGGER-HOOK*} to be +globally set to @code{SWANK:SWANK-DEBUGGER-HOOK} and thus for @SLIME{} +to handle all debugging in the Lisp image. This is for debugging +multithreaded and callback-driven applications. + +@anchor{*SLDB-QUIT-RESTART*} +@vindex SWANK:*SLDB-QUIT-RESTART* +@item SWANK:*SLDB-QUIT-RESTART* +This variable names the restart that is invoked when pressing @kbd{q} +(@pxref{sldb-quit}) in @SLDB{}. For @SLIME{} evaluation requests this +is @emph{unconditionally} bound to a restart that returns to a safe +point. This variable is supposed to customize what @kbd{q} does if an +application's thread lands into the debugger (see +@code{SWANK:*GLOBAL-DEBUGGER*}). +@example +(setf swank:*sldb-quit-restart* 'sb-thread:terminate-thread) +@end example + +@vindex SWANK:*BACKTRACE-PRINTER-BINDINGS* +@vindex SWANK:*MACROEXPAND-PRINTER-BINDINGS* +@vindex SWANK:*SLDB-PRINTER-BINDINGS* +@vindex SWANK:*SWANK-PPRINT-BINDINGS* +@item SWANK:*BACKTRACE-PRINTER-BINDINGS* +@itemx SWANK:*MACROEXPAND-PRINTER-BINDINGS* +@itemx SWANK:*SLDB-PRINTER-BINDINGS* +@itemx SWANK:*SWANK-PPRINT-BINDINGS* +These variables can be used to customize the printer in various +situations. The values of the variables are association lists of +printer variable names with the corresponding value. E.g., to enable +the pretty printer for formatting backtraces in @SLDB{}, you can use: +@example +(push '(*print-pretty* . t) swank:*sldb-printer-bindings*). +@end example + +@vindex SWANK:*USE-DEDICATED-OUTPUT-STREAM* +@item SWANK:*USE-DEDICATED-OUTPUT-STREAM* +This variable controls whether to use an unsafe efficiency hack for +sending printed output from Lisp to Emacs. The default is @code{nil}, +don't use it, and is strongly recommended to keep. + +When @code{t}, a separate socket is established solely for Lisp to send +printed output to Emacs through, which is faster than sending the output +in protocol-messages to Emacs. However, as nothing can be guaranteed +about the timing between the dedicated output stream and the stream of +protocol messages, the output of a Lisp command can arrive before or +after the corresponding REPL results. Thus output and REPL results can +end up in the wrong order, or even interleaved, in the REPL buffer. +Using a dedicated output stream also makes it more difficult to +communicate to a Lisp running on a remote host via SSH +(@pxref{Connecting to a remote lisp}). + +@vindex SWANK:*DEDICATED-OUTPUT-STREAM-PORT* +@item SWANK:*DEDICATED-OUTPUT-STREAM-PORT* +When @code{*USE-DEDICATED-OUTPUT-STREAM*} is @code{t} the stream will +be opened on this port. The default value, @code{0}, means that the +stream will be opened on some random port. + +@vindex SWANK:*LOG-EVENTS* +@item SWANK:*LOG-EVENTS* +Setting this variable to @code{t} causes all protocol messages +exchanged with Emacs to be printed to @code{*TERMINAL-IO*}. This is +useful for low-level debugging and for observing how @SLIME{} works +``on the wire.'' The output of @code{*TERMINAL-IO*} can be found in +your Lisp system's own listener, usually in the buffer +@code{*inferior-lisp*}. + +@end table + +@c ----------------------- +@node Tips and Tricks +@chapter Tips and Tricks + +@menu +* Connecting to a remote lisp:: +* Global IO Redirection:: +* Auto-SLIME:: +@end menu + +@c ----------------------- +@node Connecting to a remote lisp +@section Connecting to a remote lisp + +One of the advantages of the way @SLIME{} is implemented is that we can +easily run the Emacs side (slime.el) on one machine and the lisp backend +(swank) on another. The basic idea is to start up lisp on the remote +machine, load swank and wait for incoming @SLIME{} connections. On the +local machine we start up emacs and tell @SLIME{} to connect to the +remote machine. The details are a bit messier but the underlying idea is +that simple. + +@menu +* Setting up the lisp image:: +* Setting up Emacs:: +* Setting up pathname translations:: +@end menu + +@c ----------------------- +@node Setting up the lisp image +@subsection Setting up the lisp image + +When you want to load swank without going through the normal, Emacs +based, process just load the @file{swank-loader.lisp} file. Just +execute + +@example +(load "/path/to/swank-loader.lisp") +(swank-loader:init) +@end example + +inside a running lisp image@footnote{@SLIME{} also provides an +@acronym{ASDF} system definition which does the same thing}. Now all we +need to do is startup our swank server. The first example assumes we're +using the default settings. + +@example +(swank:create-server) +@end example + +Since we're going to be tunneling our connection via ssh@footnote{there +is a way to connect without an ssh tunnel, but it has the side-effect of +giving the entire world access to your lisp image, so we're not going to +talk about it} and we'll only have one port open we want to tell swank +to not use an extra connection for output (this is actually the default +in current @SLIME{}): + +@example +(setf swank:*use-dedicated-output-stream* nil) +@end example + +@c ----------------------- +If you need to do anything particular +(like be able to reconnect to swank after you're done), look into +@code{swank:create-server}'s other arguments. Some of these arguments +are +@table @code + +@item :PORT +Port number for the server to listen on (default: 4005). +@item :STYLE +See @xref{Communication style}. +@item :DONT-CLOSE +Boolean indicating if the server will continue to accept connections +after the first one (default: @code{NIL}). For ``long-running'' lisp processes +to which you want to be able to connect from time to time, +specify @code{:dont-close t} +@item :CODING-SYSTEM +String designating the encoding to be used to communicate between the +Emacs and Lisp. +@end table + +So the more complete example will be +@example +(swank:create-server :port 4005 :dont-close t :coding-system "utf-8-unix") +@end example +On the emacs side you will use something like +@example +(setq slime-net-coding-system 'utf-8-unix) +(slime-connect "localhost" 4005)) +@end example +to connect to this lisp image from the same machine. + + +@node Setting up Emacs +@subsection Setting up Emacs + +Now we need to create the tunnel between the local machine and the +remote machine. + +@example +ssh -L4005:localhost:4005 username@@remote.example.com +@end example + +That ssh invocation creates an ssh tunnel between the port 4005 on our +local machine and the port 4005 on the remote machine@footnote{By +default swank listens for incoming connections on port 4005, had we +passed a @code{:port} parameter to @code{swank:create-server} we'd be +using that port number instead}. + +Finally we can start @SLIME{}: + +@example +M-x slime-connect RET RET +@end example + +The @kbd{RET RET} sequence just means that we want to use the default +host (@code{localhost}) and the default port (@code{4005}). Even +though we're connecting to a remote machine the ssh tunnel fools Emacs +into thinking it's actually @code{localhost}. + +@c ----------------------- +@node Setting up pathname translations +@subsection Setting up pathname translations + +One of the main problems with running swank remotely is that Emacs +assumes the files can be found using normal filenames. if we want +things like @code{slime-compile-and-load-file} (@kbd{C-c C-k}) and +@code{slime-edit-definition} (@kbd{M-.}) to work correctly we need to +find a way to let our local Emacs refer to remote files. + +There are, mainly, two ways to do this. The first is to mount, using +NFS or similar, the remote machine's hard disk on the local machine's +file system in such a fashion that a filename like +@file{/opt/project/source.lisp} refers to the same file on both +machines. Unfortunately NFS is usually slow, often buggy, and not +always feasible, fortunately we have an ssh connection and Emacs' +@code{tramp-mode} can do the rest. +(See @inforef{Top, TRAMP User Manual,tramp}.) + +What we do is teach Emacs how to take a filename on the remote machine +and translate it into something that tramp can understand and access +(and vice versa). Assuming the remote machine's host name is +@code{remote.example.com}, @code{cl:machine-instance} returns +``remote'' and we login as the user ``user'' we can use @code{slime-tramp} +contrib to setup the proper translations by simply doing: + +@example +(add-to-list 'slime-filename-translations + (slime-create-filename-translator + :machine-instance "remote" + :remote-host "remote.example.com" + :username "user")) +@end example + +@c ----------------------- +@node Global IO Redirection +@section Globally redirecting all IO to the REPL + +When connecting via @kbd{M-x slime-connect} @SLIME{} does +not change @code{*standard-output*} and friends outside of the +@REPL{}. If you have any other threads which call @code{format}, +@code{write-string}, etc. that output will be seen only in +the @code{*inferior-lisp*} buffer or on the terminal, more often than +not this is inconvenient. So, if you want code such as this: + +@example +(run-in-new-thread + (lambda () + (write-line "In some random thread.~%" *standard-output*))) +@end example + +to send its output to @SLIME{}'s repl buffer, as opposed to +@code{*inferior-lisp*}, set @code{swank:*globally-redirect-io*} to T +in @file{~/.swank.lisp} + +But when started using @kbd{M-x slime} the streams are redirected by +default. + +@c ----------------------- +@node Auto-SLIME +@section Connecting to SLIME automatically + +To make @SLIME{} connect to your lisp whenever you open a lisp file +just add this to your @file{.emacs}: + +@example +(add-hook 'slime-mode-hook + (lambda () + (unless (slime-connected-p) + (save-excursion (slime))))) +@end example + +@node Contributed Packages +@chapter Contributed Packages + +In version 2.1 we moved some functionality to separate packages. This +chapter tells you how to load contrib modules and describes what the +particular packages do. + +@menu +* Loading Contribs:: +* REPL:: +* slime-mrepl:: +* inferior-slime-mode:: +* Compound Completion:: +* Fuzzy Completion:: +* slime-autodoc-mode:: +* ASDF:: +* Banner:: +* Editing Commands:: +* Fancy Inspector:: +* Presentations:: +* Typeout frames:: +* TRAMP:: +* Documentation Links:: +* Xref and Class Browser:: +* Highlight Edits:: +* Scratch Buffer:: +* SLIME Trace Dialog:: +* slime-sprof:: +* SLIME Enhanced M-.:: +* slime-fancy:: +* Quicklisp:: +@end menu + +@node Loading Contribs +@section Loading Contrib Packages + +@cindex Contribs +@cindex Contributions +@cindex Plugins + +Contrib packages aren't loaded by default. You have to modify your +setup a bit so that Emacs knows where to find them and which of them +to load. Generally, you set the variable @code{slime-contribs} with +the list of package-names that you want to use. For example, a setup +to load the @code{slime-scratch} and @code{slime-editing-commands} +packages looks like: + +@example +;; @emph{Setup load-path and autoloads} +(add-to-list 'load-path "~/dir/to/cloned/slime") +(require 'slime-autoloads) + +;; @emph{Set your lisp system and some contribs} +(setq inferior-lisp-program "/opt/sbcl/bin/sbcl") +(setq slime-contribs '(slime-scratch slime-editing-commands)) +@end example + +After starting @SLIME{}, the commands of both packages should be +available. + +The REPL and @code{slime-fancy} modules deserve special mention. Many +users consider the REPL (@pxref{REPL}) essential +while @code{slime-fancy} (@pxref{slime-fancy}) loads the REPL and +almost all of the popular contribs. So, if you aren't sure what to +choose start with: + +@example +(setq slime-contribs '(slime-repl)) ; repl only +@end example + +If you like what you see try this: + +@example +(setq slime-contribs '(slime-fancy)) ; almost everything +@end example + +@subsection Loading and unloading ``on the fly'' + +We recommend that you setup contribs @emph{before} starting @SLIME{} via +@kbd{M-x slime}, but if you want to enable more contribs @emph{after} +you do that, you can set the @code{slime-contribs} variable to another +value and call @code{M-x slime-setup}. Note this though: + +@itemize @bullet +@item +If you've removed contribs from the list they won't be unloaded +automatically. +@item +If you have more than one @SLIME{} connection currently active, you must +manually repeat the @code{slime-setup} step for each of them. +@end itemize + +Short of restarting Emacs, a reasonable way of unloading contribs is +by calling an Emacs Lisp function whose name is obtained by +adding @code{-unload} to the contrib's name, for every contrib you +wish to unload. So, to remove @code{slime-repl}, you must call +@code{slime-repl-unload}. Because the unload function will only, if +ever, unload the Emacs Lisp side of the contrib, you may also need to +restart your lisps. + +@c ----------------------- +@node REPL +@section REPL: the ``top level'' + +@cindex Listener + +@SLIME{} uses a custom Read-Eval-Print Loop (@REPL{}, also known as a +``top level'', or listener). The @REPL{} user-interface is written in +Emacs Lisp, which gives more Emacs-integration than the traditional +@code{comint}-based Lisp interaction: + +@itemize @bullet +@item +Conditions signalled in @REPL{} expressions are debugged with @SLDB{}. +@item +Return values are distinguished from printed output by separate Emacs +faces (colours). +@item +Emacs manages the @REPL{} prompt with markers. This ensures that Lisp +output is inserted in the right place, and doesn't get mixed up with +user input. +@end itemize + +To load the REPL use @code{(add-to-list 'slime-contribs 'slime-repl)} in your +@code{.emacs}. + +@table @kbd + +@kbditem{C-c C-z, slime-switch-to-output-buffer} +Select the output buffer, preferably in a different window. + +@kbditem{C-c C-y, slime-call-defun} +Insert a call to the function defined around point into the REPL. + +@kbditem{C-c C-j, slime-eval-last-expression-in-repl} +Inserts the last expression to the REPL and evaluates it there. +Switches to the current packae of the source buffer for the duration. +If used with a prefix argument, doesn't switch back afterwards. + +@end table + +@menu +* REPL commands:: +* Input Navigation:: +* Shortcuts:: +@end menu + +@c ----------------------- +@node REPL commands +@subsection REPL commands + +@table @kbd + +@kbditem{RET, slime-repl-return} +Evaluate the current input in Lisp if it is complete. If incomplete, +open a new line and indent. If a prefix argument is given then the +input is evaluated without checking for completeness. + +@kbditem{C-RET, slime-repl-closing-return} +Close any unmatched parenthesis and then evaluate the current input in +Lisp. Also bound to @kbd{M-RET}. + +@kbditem{TAB, slime-indent-and-complete-symbol} +Indent the current line and perform symbol completion. + +@kbditem{C-j, slime-repl-newline-and-indent} +Open and indent a new line. + +@kbditem{C-a, slime-repl-bol} +Go to the beginning of the line, but stop at the @REPL{} prompt. + +@c @anchor{slime-interrupt} +@kbditem{C-c C-c, slime-interrupt} +Interrupt the Lisp process with @code{SIGINT}. + +@c @kbditem{C-c M-g, slime-quit} +@c Quit @SLIME{}. + +@kbditem{C-c M-o, slime-repl-clear-buffer} +Clear the entire buffer, leaving only a prompt. + +@kbditem{C-c C-o, slime-repl-clear-output} +Remove the output and result of the previous expression from the +buffer. + +@end table + +@c ----------------------- +@node Input Navigation +@subsection Input navigation + +@cindex Input History + +The input navigation (a.k.a. history) commands are modelled after +@code{coming}-mode. Be careful if you are used to Bash-like +keybindings: @kbd{M-p} and @kbd{M-n} use the current input as search +pattern and only work Bash-like if the current line is +empty. @kbd{C-} and @kbd{C-} work like the up and down keys in +Bash. + +@table @kbd + +@kbditempair{C-, C-, slime-repl-forward-input, slime-repl-backward-input} +Go to the next/previous history item. + +@kbditempair{M-n, M-p, slime-repl-next-input, slime-repl-previous-input} +Search the next/previous item in the command history using the current +input as search pattern. If @kbd{M-n}/@kbd{M-n} is typed two times in +a row, the second invocation uses the same search pattern (even if the +current input has changed). + +@kbditempair{M-s, M-r, slime-repl-next-matching-input, slime-repl-previous-matching-input} +Search forward/reverse through command history with regex + +@c @code{slime-repl-@{next,previous@}-input}@* +@c @code{slime-repl-@{next,previous@}-matching-input}@* +@c @code{comint}-style input history commands. + +@kbditempair{C-c C-n, C-c C-p, slime-repl-next-prompt, slime-repl-previous-prompt} +Move between the current and previous prompts in the @REPL{} buffer. +Pressing RET on a line with old input copies that line to the newest +prompt. +@end table + +@vindex slime-repl-wrap-history +The variable @code{slime-repl-wrap-history} controls wrap around +behaviour, i.e. whether cycling should restart at the beginning of the +history if the end is reached. + +@c ----------------------- +@comment node-name, next, previous, up +@node Shortcuts +@subsection Shortcuts + +@cindex Shortcuts + +``Shortcuts'' are a special set of @REPL{} commands that are invoked +by name. To invoke a shortcut you first press @kbd{,} (comma) at the +@REPL{} prompt and then enter the shortcut's name when prompted. + +Shortcuts deal with things like switching between directories and +compiling and loading Lisp systems. The set of shortcuts is listed +below, and you can also use the @code{help} +shortcut to list them interactively. + +@table @kbd +@item change-directory (aka !d, cd) +Change the current directory. + +@item change-package (aka !p, in, in-package) +Change the current package. + +@item compile-and-load (aka cl) +Compile (if necessary) and load a lisp file. + +@item defparameter (aka !) +Define a new global, special, variable. + +@item disconnect +Disconnect all connections. + +@item help (aka ?) +Display the help. + +@item pop-directory (aka -d) +Pop the current directory. + +@item pop-package (aka -p) +Pop the top of the package stack. + +@item push-directory (aka +d, pushd) +Push a new directory onto the directory stack. + +@item push-package (aka +p) +Push a package onto the package stack. + +@item pwd +Show the current directory. + +@item quit +Quit the current Lisp. + +@item resend-form +Resend the last form. + +@item restart-inferior-lisp +Restart *inferior-lisp* and reconnect @SLIME{}. + +@item sayoonara +Quit all Lisps and close all @SLIME{} buffers. + +@end table + +@node slime-mrepl +@section Multiple REPLs + +The @code{slime-mrepl} package adds support for multiple listener +buffers. The command @kbd{M-x slime-new-mrepl} creates a new +buffer. In a multi-threaded Lisp, each listener is associated with a +separate thread. In a single-threaded Lisp it's also possible to +create multiple listener buffers but the commands are executed +sequentially by the same process. + +@node inferior-slime-mode +@section @code{inferior-slime-mode} + +The @code{inferior-slime-mode} is a minor mode is intended to use with +the @code{*inferior-lisp*} lisp buffer. It provides some of the +@SLIME{} commands, like symbol completion and documentation lookup. It +also tracks the current directory of the Lisp process. To install it, +add something like this to user @file{.emacs}: + +@example +(add-to-list 'slime-contribs 'inferior-slime) +@end example + +@table @kbd +@cmditem{inferior-slime-mode} +Turns inferior-slime-mode on or off. +@end table + +@vindex inferior-slime-mode-map +The variable @code{inferior-slime-mode-map} contains the extra +keybindings. + +@node Compound Completion +@section Compound Completion + +@anchor{slime-complete-symbol*} +The package @code{slime-c-p-c} provides a different symbol completion +algorithm, which performs completion ``in parallel'' over the +hyphen-delimited sub-words of a symbol name. +@footnote{This style of completion is modelled on @file{completer.el} +by Chris McConnell. That package is bundled with @acronym{ILISP}.} +Formally this means that ``@code{a-b-c}'' can complete to any symbol +matching the regular expression ``@code{^a.*-b.*-c.*}'' (where ``dot'' +matches anything but a hyphen). Examples give a more intuitive +feeling: +@itemize @bullet +@item +@code{m-v-b} completes to @code{multiple-value-bind}. +@item +@code{w-open} is ambiguous: it completes to either +@code{with-open-file} or @code{with-open-stream}. The symbol is +expanded to the longest common completion (@code{with-open-}) and the +point is placed at the first point of ambiguity, which in this case is +the end. +@item +@code{w--stream} completes to @code{with-open-stream}. +@end itemize + +The variable @code{slime-c-p-c-unambiguous-prefix-p} specifies where +point should be placed after completion. E.g. the possible +completions for @code{f-o} are @code{finish-output} and +@code{force-output}. By the default point is moved after the +@code{f}, because that is the unambiguous prefix. If +@code{slime-c-p-c-unambiguous-prefix-p} is nil, point moves to +the end of the inserted text, after the @code{o} in this case. + +In addition, @code{slime-c-p-c} provides completion for character names +(mostly useful for Unicode-aware implementations): + +@example +CL-USER> #\Sp +@end example + +Here @SLIME{} will usually complete the character to @code{#\Space}, but +in a Unicode-aware implementation, this might provide the following +completions: +@example +Space Space +Sparkle Spherical_Angle +Spherical_Angle_Opening_Left Spherical_Angle_Opening_Up +@end example + +The package @code{slime-c-p-c} also provides context-sensitive +completion for keywords. Example: + +@example +CL-USER> (find 1 '(1 2 3) :s +@end example + +Here @SLIME{} will complete @code{:start}, rather than suggesting all +ever-interned keywords starting with @code{:s}. + + +@table @kbd +@kbditem{C-c C-s, slime-complete-form} +Looks up and inserts into the current buffer the argument list for the +function at point, if there is one. More generally, the command +completes an incomplete form with a template for the missing arguments. +There is special code for discovering extra keywords of generic +functions and for handling @code{make-instance}, +@code{defmethod}, and many other functions. Examples: + +@example +(subseq "abc" + --inserts--> start [end]) +(find 17 + --inserts--> sequence :from-end from-end :test test + :test-not test-not :start start :end end + :key key) +(find 17 '(17 18 19) :test #'= + --inserts--> :from-end from-end + :test-not test-not :start start :end end + :key key) +(defclass foo () ((bar :initarg :bar))) +(defmethod print-object + --inserts--> (object stream) + body...) +(defmethod initialize-instance :after ((object foo) &key blub)) +(make-instance 'foo + --inserts--> :bar bar :blub blub initargs...) +@end example +@end table + +@node Fuzzy Completion +@section Fuzzy Completion + +The package @code{slime-fuzzy} implements yet another symbol +completion heuristic. + +@table @kbd +@anchor{slime-fuzzy-complete-symbol} +@kbditem{C-c M-i, slime-fuzzy-complete-symbol} +Presents a list of likely completions to choose from for an +abbreviation at point. If you set the +variable @code{slime-complete-symbol-function} to this command, fuzzy +completion will also be used for @kbd{M-TAB}. +@end table + +@subsection The Algorithm + +It attempts to complete a symbol all at once, instead of in pieces. +For example, ``mvb'' will find ``@code{multiple-value-bind}'' and +``norm-df'' will find +``@code{least-positive-normalized-double-float}''. + +The algorithm tries to expand every character in various ways and +rates the list of possible completions with the following heuristic. + +Letters are given scores based on their position in the string. +Letters at the beginning of a string or after a prefix letter at +the beginning of a string are scored highest. Letters after a +word separator such as #\- are scored next highest. Letters at +the end of a string or before a suffix letter at the end of a +string are scored medium, and letters anywhere else are scored +low. + +If a letter is directly after another matched letter, and its +intrinsic value in that position is less than a percentage of the +previous letter's value, it will use that percentage instead. + +Finally, a small scaling factor is applied to favor shorter +matches, all other things being equal. + +@subsection Duplicate Symbols + +In case a symbol is accessible via several packages, duplicate symbol +filter specified via @code{*fuzzy-duplicate-symbol-filter*} swank +variable is applied. @code{:nearest-package} value specifies that only +symbols in the package with highest score should be kept. +@code{:home-package} specifies that only the match that represents the home +package of the symbol is used, and @code{:all} value specifies that +duplicate symbol filter mode should be turned off. + +To specify a custom filter, set @code{*fuzzy-duplicate-symbol-filter*} +to a function accepting three arguments: the name of package being +examined, the list of names of all packages being examined with +packages with highest matching score listed first and an @code{equal} +hash-table that is shared between calls to the function and can be +used for deduplication purposes. The function should return a +deduplication filter function which accepts a symbol and returns true +if the symbol should be kept. + +For example, the effect of @code{:nearest-package} can be also achieved +by specifying the following custom filter in @file{~/.swank.lisp}: +@example +(setf *fuzzy-duplicate-symbol-filter* + (lambda (cur-package all-packages dedup-table) + (declare (ignore cur-package all-packages)) + (lambda (symbol) + (unless (gethash (symbol-name symbol) dedup-table) + (setf (gethash (symbol-name symbol) dedup-table) t))))) +@end example +And instead of @code{:home-package}, the following can be used: +@example +(setf *fuzzy-duplicate-symbol-filter* + (lambda (cur-package all-packages dedup-table) + (declare (ignore dedup-table)) + (let ((packages (mapcar #'find-package + (remove cur-package all-packages)))) + (lambda (symbol) + (not (member (symbol-package symbol) packages)))))) +@end example + +@node slime-autodoc-mode +@section @code{slime-autodoc-mode} + +Autodoc mode is an additional minor-mode for automatically showing +information about symbols near the point. For function names the +argument list is displayed, and for global variables, the value. +Autodoc is implemented by means of @code{eldoc-mode} of Emacs. + +The mode can be enabled by default in your @code{~/.emacs}: +@example +(add-to-list 'slime-contribs 'slime-autodoc) +@end example + +@table @kbd +@cmditem{slime-arglist NAME} +Show the argument list of the function NAME. + +@cmditem{slime-autodoc-mode} +Toggles autodoc-mode on or off according to the argument, and +toggles the mode when invoked without argument. +@kbditem{C-c C-d a, slime-autodoc-manually} +Like slime-autodoc, but when called twice, +or after slime-autodoc was already automatically called, +display multiline arglist. +@end table + +@vindex slime-use-autodoc-mode +If the variable @code{slime-use-autodoc-mode} is set (default), Emacs +starts a timer, otherwise the information is only displayed after +pressing SPC. + +@vindex slime-autodoc-use-multiline-p +If @code{slime-autodoc-use-multiline-p} is set to non-nil, +allow long autodoc messages to resize echo area display. + +@vindex slime-autodoc-mode-string +@code{slime-autodoc-mode-string} is a string that will be displayed in +the mode line when autodoc-mode is enabled, or nil, if you prefer no +indication. You can customize this variable. + +@node ASDF +@section ASDF + +@acronym{ASDF} is a popular ``system construction tool''. The package +@code{slime-asdf} provides some commands to load and compile such +systems from Emacs. @acronym{ASDF} itself is not included with +@SLIME{}; you have to load that yourself into your Lisp. In +particular, you must load @acronym{ASDF} before you connect, otherwise +you will get errors about missing symbols. + +@table @kbd +@cmditem{slime-load-system NAME} +Compile and load an ASDF system. The default system name is taken +from the first file matching *.asd in the current directory. +@cmditem{slime-reload-system NAME} +Recompile and load an ASDF system without recompiling its dependencies. +@cmditem{slime-open-system NAME &optional LOAD} +Open all files in a system, optionally load it if LOAD is non-nil. +@cmditem{slime-browse-system NAME} +Browse files in a system using Dired. +@cmditem{slime-delete-system-fasls NAME} +Delete FASLs produced by compiling a system. +@cmditem{slime-rgrep-system NAME REGEXP} +Run @code{rgrep} on the base directory of an ASDF system. +@cmditem{slime-isearch-system NAME} +Run @code{isearch-forward} on the files of an ASDF system. +@cmditem{slime-query-replace-system NAME FROM TO &OPTIONAL DELIMITED} +Run @code{query-replace} on an ASDF system. +@end table +The package also installs some new REPL shortcuts (@pxref{Shortcuts}): + +@table @kbd +@item load-system +Compile (as needed) and load an ASDF system. +@item reload-system +Recompile and load an ASDF system. +@item compile-system +Compile (but not load) an ASDF system. +@item force-compile-system +Recompile (but not load) an ASDF system. +@item force-load-system +Recompile and load an ASDF system. +@item open-system +Open all files in a system. +@item browse-system +Browse files in a system using Dired. +@item delete-system-fasls +Delete FASLs produced by compiling a system. +@end table + +@node Banner +@section Banner +The package @code{slime-banner} installs a window header line ( +@inforef{Header Lines, , elisp}.) in the REPL buffer. It also runs an +animation at startup. + +@vindex slime-startup-animation +@vindex slime-header-line-p +By setting the variable @code{slime-startup-animation} to nil you can +disable the animation respectively with the +variable @code{slime-header-line-p} the header line. + +@node Editing Commands +@section Editing Commands + +The package @code{slime-editing-commands} provides some commands to +edit Lisp expressions. + +@table @kbd +@kbditem{C-c M-q, slime-reindent-defun} +Re-indents the current defun, or refills 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 @code{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. + +@kbditem{C-c C-], slime-close-all-parens-in-sexp} +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. + +@cmditem{slime-insert-balanced-comments} +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. + +@kbditem{M-C-a, slime-beginning-of-defun} +@kbditem{M-C-e, slime-end-of-defun} +@end table + +@node Fancy Inspector +@section Fancy Inspector + +@cindex Methods + +An alternative to default inspector is provided by the package +`slime-fancy-inspector'. This inspector knows a lot about CLOS +objects and methods. It provides many ``actions'' that can be +selected to invoke Lisp code on the inspected object. For example, to +present a generic function the inspector shows the documentation in +plain text and presents each method with both a hyperlink to inspect +the method object and a ``remove method'' action that you can invoke +interactively. The key-bindings are the same as for the basic +inspector (@pxref{Inspector}). + +@node Presentations +@section Presentations + +@cindex Presentations + +A ``presentation''@footnote{Presentations are a feature originating +from the Lisp machines. It was possible to define @code{present} +methods specialized to various devices, e.g. to draw an object to +bitmapped screen or to write some text to a character stream.} in +@SLIME{} is a region of text associated with a Lisp object. +Right-clicking on the text brings up a menu with operations for the +particular object. Some operations, like inspecting, are available +for all objects, but the object may also have specialized operations. +For instance, pathnames have a dired operation. + +More importantly, it is possible to cut and paste presentations (i.e., +Lisp objects, not just their printed presentation), using all standard +Emacs commands. This way it is possible to cut and paste the results of +previous computations in the REPL. This is of particular importance for +unreadable objects. + +The package @code{slime-presentations} installs presentations in the +REPL, i.e. the results of evaluation commands become presentations. In +this way, presentations generalize the use of the standard Common Lisp +REPL history variables @code{*}, @code{**}, @code{***}. Example: + +@example +CL-USER> (find-class 'standard-class) +@emph{#} +CL-USER> +@end example + +Presentations appear in red color in the buffer. +(In this manual, we indicate the presentations @emph{like this}.) +Using standard Emacs +commands, the presentation can be copied to a new input in the REPL: + +@example +CL-USER> (eql '@emph{#} + '@emph{#}) +@emph{T} +@end example + +Note that standard evaluation and quoting rules still apply. So if a +presentation is a list, it needs to be quoted in an evaluated context to +avoid treating it as a function call: + +@example +CL-USER> (list (find-class 'standard-class) 2 3 4) +@emph{(# 2 3 4)} +CL-USER> @emph{(# 2 3 4)} +; Funcall of # which is a non-function. +; Evaluation aborted. +CL-USER> '@emph{(# 2 3 4)} +(# 2 3 4) +@end example + +When you copy an incomplete presentation or edit the text within a +presentation, the presentation changes to plain text, losing the +association with a Lisp object. In the buffer, this is indicated by +changing the color of the text from red to black. This can be undone. + +Presentations are also available in the inspector (all inspectable parts +are presentations) and the debugger (all local variables are +presentations). This makes it possible to evaluate expressions in the +REPL using objects that appear in local variables of some active +debugger frame; this can be more convenient than using @code{M-x +sldb-eval-in-frame}. @strong{Warning:} The presentations that stem from +the inspector and debugger are only valid as long as the corresponding +buffers are open. Using them later can cause errors or confusing +behavior. + +For some Lisp implementations you can also install the package +@code{slime-presentation-streams}, which enables presentations on the +Lisp @code{*standard-output*} stream and similar streams. This means +that not only results +of computations, but also some objects that are printed to the standard +output (as a side-effect of the computation) are associated with +presentations. Currently, all unreadable objects +and pathnames get printed as presentations. + +@example +CL-USER> (describe (find-class 'standard-object)) +@emph{#} is an instance of + @emph{#}: + The following slots have :INSTANCE allocation: + PLIST NIL + FLAGS 1 + DIRECT-METHODS ((@emph{#} + ... +@end example + +Again, this makes it possible to inspect and copy-paste these objects. + +In addition to the standard Emacs commands, there are several keyboard +commands, a menu-bar menu, and a context menu to operate on +presentations. We describe the keyboard commands below; they are also +shown in the menu-bar menu. + +@table @kbd +@kbditem{C-c C-v SPC, slime-mark-presentation} +If point is within a presentation, move point to the beginning of the +presentation and mark to the end of the presentation. +This makes it possible to copy the presentation. + +@kbditem{C-c C-v w, slime-copy-presentation-at-point-to-kill-ring} +If point is within a presentation, copy the surrounding presentation +to the kill ring. + +@kbditem{C-c C-v r, slime-copy-presentation-at-point-to-repl} +If point is within a presentation, copy the surrounding presentation +to the REPL. + +@kbditem{C-c C-v d, slime-describe-presentation-at-point} +If point is within a presentation, describe the associated object. + +@kbditem{C-c C-v i, slime-inspect-presentation-at-point} +If point is within a presentation, inspect the associated object with +the @SLIME{} inspector. + +@kbditem{C-c C-v n, slime-next-presentation} +Move point to the next presentation in the buffer. + +@kbditem{C-c C-v p, slime-previous-presentation} +Move point to the previous presentation in the buffer. + +@end table +Similar operations are also possible from the context menu of every +presentation. Using @kbd{mouse-3} on a presentation, the context menu +opens and offers various commands. For some objects, specialized +commands are also offered. Users can define additional specialized +commands by defining a method for +@code{swank::menu-choices-for-presentation}. + + +@strong{Warning:} On Lisp implementations without weak hash tables, +all objects associated with presentations are protected from garbage +collection. If your Lisp image grows too large because of that, +use @kbd{C-c C-v M-o} (@code{slime-clear-presentations}) to remove these +associations. You can also use the command @kbd{C-c M-o} +(@code{slime-repl-clear-buffer}), which both clears the REPL buffer and +removes all associations of objects with presentations. + +@strong{Warning:} Presentations can confuse new users. + +@example +CL-USER> (cons 1 2) +@emph{(1 . 2)} +CL-USER> (eq '@emph{(1 . 2)} '@emph{(1 . 2)}) +@emph{T} +@end example + +One could have expected @code{NIL} here, because it looks like two +fresh cons cells are compared regarding object identity. +However, in the example the presentation @code{@emph{(1 . 2)}} was copied twice +to the REPL. Thus @code{EQ} is really invoked with the same object, +namely the cons cell that was returned by the first form entered in the +REPL. + +@node Typeout frames +@section Typeout frames + +@cindex Typeout Frame + +A ``typeout frame'' is a special Emacs frame which is used instead of +the echo area (minibuffer) to display messages from @SLIME{} commands. +This is an optional feature. The advantage of a typeout frame over the +echo area is that it can hold more text, it can be scrolled, and its +contents don't disappear when you press a key. All potentially long +messages are sent to the typeout frame, such as argument lists, macro +expansions, and so on. + +@table @kbd +@cmditem{slime-ensure-typeout-frame} +Ensure that a typeout frame exists, creating one if necessary. +@end table + +If the typeout frame is closed then the echo area will be used again +as usual. + +To have a typeout frame created automatically at startup you should +load the @code{slime-typeout-frame} package. (@pxref{Loading Contribs}.) + +The variable @code{slime-typeout-frame-properties} specifies the +height and possibly other properties of the frame. Its value is +passed to @code{make-frame}. (@inforef{Creating Frames, ,elisp}.) + +@node TRAMP +@section TRAMP + +@cindex TRAMP + +The package @code{slime-tramp} provides some functions to set up +filename translations for TRAMP. (@pxref{Setting up pathname +translations}) + +@node Documentation Links +@section Documentation Links + +For certain error messages, SBCL includes references to the ANSI +Standard or the SBCL User Manual. The @code{slime-references} package +turns those references into clickable links. This makes finding the +referenced section of the HyperSpec much easier. + +@node Xref and Class Browser +@section Xref and Class Browser + +A rudimentary class browser is provided by +the @code{slime-xref-browser} package. + +@table @kbd +@cmditem{slime-browse-classes} +This command asks for a class name and displays inheritance tree of +for the class. + +@cmditem{slime-browse-xrefs} +This command prompts for a symbol and the kind of cross reference, +e.g. callers. The cross reference tree rooted at the symbol is then +then displayed. + +@end table + + +@node Highlight Edits +@section Highlight Edits + +@code{slime-highlight-edits} is a minor mode to highlight those +regions in a Lisp source file which are modified. This is useful to +quickly find those functions which need to be recompiled (with +@kbd{C-c C-c}) + +@table @kbd +@cmditem{slime-highlight-edits-mode} +Turns @code{slime-highlight-edits-mode} on or off. +@end table + +@node Scratch Buffer +@section Scratch Buffer + +@anchor{slime-scratch} +The @SLIME{} scratch buffer, in contrib package @code{slime-scratch}, +imitates Emacs' usual @code{*scratch*} buffer. +If @code{slime-scratch-file} is set, it is used to back the scratch +buffer, making it persistent. The buffer is like any other Lisp +buffer, except for the command bound to @kbd{C-j}. + +@table @kbd + +@kbditem{C-j, slime-eval-print-last-expression} +Evaluate the expression sexp before point and insert print value into +the current buffer. + +@cmditem{slime-scratch} +Create a @file{*slime-scratch*} buffer. In this +buffer you can enter Lisp expressions and evaluate them with +@kbd{C-j}, like in Emacs's @file{*scratch*} buffer. + +@end table + +@node SLIME Trace Dialog +@section SLIME Trace Dialog + +The @SLIME{} Trace Dialog, in package @code{slime-trace-dialog}, is a +tracing facility, similar to Common Lisp's @code{trace}, but +interactive rather than purely textual. It is an Emacs 24-only +contrib. + +You use it just like you would regular @code{trace}: after tracing a +function, calling it causes interesting information about that +particular call to be reported. + +However, instead of printing the trace results to the +the @code{*trace-output*} stream (usually the REPL), the @SLIME{} +Trace Dialog collects and stores them in your lisp environment until, +on user's request, they are fetched into Emacs and displayed in a +dialog-like interactive view. + +To use this contrib, add it to @code{slime-contribs} in your +@code{~/.emacs}, either directly by setting up @code{slime-fancy} +(@pxref{slime-fancy}). + +@example +;; setting up 'slime-fancy would also have worked +(add-to-list 'slime-contribs 'slime-trace-dialog) +@end example + +After starting up @SLIME{}, @SLIME{}'s Trace Dialog installs +a @emph{Trace} menu in the menu-bar of any @code{slime-mode} buffer and +adds two new commands, with respective key-bindings: + +@table @kbd +@kbditem{C-c M-t, slime-trace-dialog-toggle-trace} +If point is on a symbol name, toggle tracing of its function +definition. If point is not on a symbol, prompt user for a function. + +With a @kbd{C-u} prefix argument, and if your lisp implementation +allows it, attempt to decipher lambdas, methods and other complicated +function signatures. + +The function is traced for the @SLIME{} Trace Dialog only, i.e. it is +not found in the list returned by Common Lisp's @code{trace}. + +@kbditem{C-c T, slime-trace-dialog} +Pop to the interactive SLIME Trace Dialog buffer associated with the +current connection (@pxref{Multiple connections}). +@end table + +@page +Consider the (useless) program: + +@example +(defun foo (n) (if (plusp n) (* n (bar (1- n))) 1)) +(defun bar (n) (if (plusp n) (* n (foo (1- n))) 1)) +@end example + +After tracing both @code{foo} and @code{bar} with @kbd{C-c M-t}, +calling call @code{(foo 2)} and moving to the trace dialog with +@kbd{C-c T}, we are presented with this buffer. + +@example +Traced specs (2) [refresh] + [untrace all] + [untrace] common-lisp-user::bar + [untrace] common-lisp-user::foo + +Trace collection status (3/3) [refresh] + [clear] + + 0 - common-lisp-user::foo + | > 2 + | < 2 + 1 `--- common-lisp-user::bar + | > 1 + | < 1 + 2 `-- common-lisp-user::foo + > 0 + < 1 +@end example + +The dialog is divided into sections displaying the functions already +traced, the trace collection progress and the actual trace tree that +follow your program's logic. The most important key-bindings in this +buffer are: + +@table @kbd +@kbditem{g, slime-trace-dialog-fetch-status} +Update information on the trace collection and traced specs. +@kbditem{G, slime-trace-dialog-fetch-traces} +Fetch the next batch of outstanding (not fetched yet) traces. With a +@kbd{C-u} prefix argument, repeat until no more outstanding traces. +@kbditem{C-k, slime-trace-dialog-clear-fetched-traces} +Prompt for confirmation, then clear all traces, both fetched and +outstanding. +@end table + +The arguments and return values below each entry are interactive +buttons. Clicking them opens the inspector +(@pxref{Inspector}). Invoking @kbd{M-RET} +(@code{slime-trace-dialog-copy-down-to-repl}) returns them to the REPL +for manipulation (@pxref{REPL}). The number left of each entry +indicates its absolute position in the calling order, which might +differ from display order in case multiple threads call the same +traced function. + +@code{slime-trace-dialog-hide-details-mode} hides arguments and return +values so you can concentrate on the calling logic. Additionally, +@code{slime-trace-dialog-autofollow-mode} will automatically +display additional detail about an entry when the cursor moves over +it. + +@node slime-sprof +@section @code{slime-sprof} + +@code{slime-sprof} is a package for integrating SBCL's statistical profiler, sb-sprof. + +The variable @code{slime-sprof-exclude-swank} controls whether to +display swank functions. The default value is NIL. + +@table @kbd + +@cmditem{slime-sprof-start} +Start profiling. + +@cmditem{slime-sprof-stop} +Stop profiling. +@cmditem{slime-sprof-report} +Report results of the profiling. +@end table + +The following keys are defined in slime-sprof-browser mode: +@table @kbd + +@kbditem{RET, slime-sprof-browser-toggle} +Expand / collapse function details (callers, calls to) +@kbditem{v, slime-sprof-browser-view-source} +View function sources. +@kbditem{d, slime-sprof-browser-disassemble-function} +Disassemble function. +@kbditem{s, slime-sprof-toggle-swank-exclusion} +Toggle exclusion of swank functions from the report. + +@end table + +@node SLIME Enhanced M-. +@section SLIME Enhanced M-. +@code{slime-mdot-fu} enables meta-point to jump to local variables +bound with @code{let} and @code{let*}, in addition to function bindings +declared with @code{flet} and @code{labels}, via +@code{slime-edit-local-definition}. + +@node slime-fancy +@section Meta package: @code{slime-fancy} + +@code{slime-fancy} is a meta package which loads a combination of the +most popular packages. + +@node Quicklisp +@section Quicklisp +The package @code{slime-quicklisp} adds support for loading Quicklisp +systems in the REPL buffer. In order for this to work, Quicklisp +should have already been loaded in the Lisp implementation. Refer +to @url{https://www.quicklisp.org/} for Quicklisp installation +details. + +The package installs the following REPL shortcuts (@pxref{Shortcuts}): + +@table @kbd +@item quicklisp-quickload (aka ql) +Load a Quicklisp system. +@end table + +@c ----------------------- +@node Credits +@chapter Credits + +@emph{The soppy ending...} + +@unnumberedsec Hackers of the good hack + +@SLIME{} is an Extension of @acronym{SLIM} by Eric Marsden. At the +time of writing, the authors and code-contributors of @SLIME{} are: + +@include contributors.texi + +... not counting the bundled code from @file{hyperspec.el}, +@cite{CLOCC}, and the @cite{CMU AI Repository}. + +Many people on the @code{slime-devel} mailing list have made non-code +contributions to @SLIME{}. Life is hard though: you gotta send code to +get your name in the manual. @code{:-)} + +@unnumberedsec Thanks! + +We're indebted to the good people of @code{common-lisp.net} for their +hosting and help, and for rescuing us from ``Sourceforge hell.'' + +Implementors of the Lisps that we support have been a great help. We'd +like to thank the @acronym{CMUCL} maintainers for their helpful +answers, Craig Norvell and Kevin Layer at Franz providing Allegro CL +licenses for @SLIME{} development, and Peter Graves for his help to +get @SLIME{} running with @acronym{ABCL}. + +Most of all we're happy to be working with the Lisp implementors +who've joined in the @SLIME{} development: Dan Barlow and Christophe +Rhodes of @acronym{SBCL}, Gary Byers of OpenMCL, and Martin Simmons of +LispWorks. Thanks also to Alain Picard and Memetrics for funding +Martin's initial work on the LispWorks backend! + +@ignore +This index is currently ignored, because texinfo's built-in indexing +produces nicer results. -- Helmut Eller + +@c@node Index to Functions +@c@appendix Index to Functions + +These functions are all available (when relevant). To find the +keybinding (if there is one) refer to the function description. + +@c Note to editors: @fcnindex{...} lines commented out below are place holders +@c ---------------- +@c They have yet to be documented +@c Please feel free to add descriptions in the text where appropriate, add the +@c appropriate anchors and uncomment them. +@c +@c [jkc] + +@table @code +@fcnindex{common-lisp-hyperspec-format} +@fcnindex{sldb-abort} +@c @fcnindex{sldb-activate} +@c @fcnindex{sldb-add-face} +@c @fcnindex{sldb-backward-frame} +@c @fcnindex{sldb-beginning-of-backtrace} +@c @fcnindex{sldb-break} +@c @fcnindex{sldb-break-on-return} +@fcnindex{sldb-break-with-default-debugger} +@c @fcnindex{sldb-buffers} +@c @fcnindex{sldb-catch-tags} +@fcnindex{sldb-continue} +@c @fcnindex{sldb-debugged-continuations} +@c @fcnindex{sldb-default-action} +@c @fcnindex{sldb-default-action/mouse} +@c @fcnindex{sldb-delete-overlays} +@c @fcnindex{sldb-details-down} +@c @fcnindex{sldb-details-up} +@fcnindex{sldb-disassemble} +@c @fcnindex{sldb-dispatch-extras} +@c @fcnindex{sldb-down} +@c @fcnindex{sldb-end-of-backtrace} +@fcnindex{sldb-eval-in-frame} +@c @fcnindex{sldb-exit} +@c @fcnindex{sldb-fetch-all-frames} +@c @fcnindex{sldb-fetch-more-frames} +@c @fcnindex{sldb-find-buffer} +@c @fcnindex{sldb-format-reference-node} +@c @fcnindex{sldb-format-reference-source} +@c @fcnindex{sldb-forward-frame} +@c @fcnindex{sldb-frame-details-visible-p} +@c @fcnindex{sldb-frame-locals} +@c @fcnindex{sldb-frame-number-at-point} +@c @fcnindex{sldb-frame-region} +@c @fcnindex{sldb-get-buffer} +@c @fcnindex{sldb-get-default-buffer} +@c @fcnindex{sldb-goto-last-frame} +@c @fcnindex{sldb-help-summary} +@c @fcnindex{sldb-hide-frame-details} +@c @fcnindex{sldb-highlight-sexp} +@c @fcnindex{sldb-insert-condition} +@c @fcnindex{sldb-insert-frame} +@c @fcnindex{sldb-insert-frames} +@c @fcnindex{sldb-insert-locals} +@c @fcnindex{sldb-insert-references} +@c @fcnindex{sldb-insert-restarts} +@c @fcnindex{sldb-inspect-condition} +@fcnindex{sldb-inspect-in-frame} +@c @fcnindex{sldb-inspect-var} +@c @fcnindex{sldb-invoke-restart} +@c @fcnindex{sldb-level} +@c @fcnindex{sldb-list-catch-tags} +@c @fcnindex{sldb-list-locals} +@c @fcnindex{sldb-lookup-reference} +@c @fcnindex{sldb-maybe-recenter-region} +@c @fcnindex{sldb-mode-hook} +@c @fcnindex{sldb-next} +@c @fcnindex{sldb-out} +@fcnindex{sldb-pprint-eval-in-frame} +@c @fcnindex{sldb-previous-frame-number} +@c @fcnindex{sldb-print-condition} +@c @fcnindex{sldb-prune-initial-frames} +@fcnindex{sldb-quit} +@c @fcnindex{sldb-reference-properties} +@c @fcnindex{sldb-restart-at-point} +@fcnindex{sldb-restart-frame} +@fcnindex{sldb-return-from-frame} +@c @fcnindex{sldb-setup} +@c @fcnindex{sldb-show-frame-details} +@c @fcnindex{sldb-show-frame-source} +@fcnindex{sldb-show-source} +@fcnindex{sldb-step} +@c @fcnindex{sldb-sugar-move} +@fcnindex{sldb-toggle-details} +@c @fcnindex{sldb-up} +@c @fcnindex{sldb-var-number-at-point} +@c @fcnindex{sldb-xemacs-emulate-point-entered-hook} +@c @fcnindex{sldb-xemacs-post-command-hook} + + +@c @fcnindex{inferior-slime-closing-return} +@c @fcnindex{inferior-slime-indent-line} +@c @fcnindex{inferior-slime-mode} +@c @fcnindex{inferior-slime-return} +@fcnindex{slime-abort-connection} +@fcnindex{slime-apropos} +@fcnindex{slime-apropos-all} +@fcnindex{slime-apropos-package} +@c @fcnindex{slime-arglist} +@fcnindex{slime-autodoc-mode} +@c @fcnindex{slime-autodoc-start-timer} +@c @fcnindex{slime-background-activities-enabled-p} +@c @fcnindex{slime-background-message} +@c @fcnindex{slime-browse-classes} +@c @fcnindex{slime-browse-xrefs} +@fcnindex{slime-call-defun} +@fcnindex{slime-calls-who} +@c @fcnindex{slime-check-coding-system} +@fcnindex{slime-close-all-sexp} +@fcnindex{slime-close-parens-at-point} +@fcnindex{slime-compile-and-load-file} +@fcnindex{slime-compile-defun} +@fcnindex{slime-compile-file} +@fcnindex{slime-compile-region} +@fcnindex{slime-compiler-macroexpand} +@fcnindex{slime-compiler-macroexpand-1} +@c @fcnindex{slime-compiler-notes-default-action-or-show-details} +@c @fcnindex{slime-compiler-notes-default-action-or-show-details/mouse} +@c @fcnindex{slime-compiler-notes-quit} +@c @fcnindex{slime-compiler-notes-show-details} +@c @fcnindex{slime-complete-form} +@fcnindex{slime-complete-symbol} +@fcnindex{slime-connect} +@fcnindex{slime-connection-list-make-default} +@c @fcnindex{slime-connection-list-mode} +@c @fcnindex{slime-copy-presentation-at-point} +@fcnindex{slime-describe-function} +@fcnindex{slime-describe-symbol} +@fcnindex{slime-disassemble-symbol} +@fcnindex{slime-disconnect} +@c @fcnindex{slime-documentation} +@fcnindex{slime-edit-definition} +@fcnindex{slime-edit-definition-other-frame} +@fcnindex{slime-edit-definition-other-window} +@fcnindex{slime-edit-definition-with-etags} +@fcnindex{slime-edit-value} +@c @fcnindex{slime-edit-value-commit} +@c @fcnindex{slime-edit-value-mode} +@fcnindex{slime-ensure-typeout-frame} +@c @fcnindex{slime-eval-buffer} +@fcnindex{slime-eval-defun} +@fcnindex{slime-eval-last-expression} +@c @fcnindex{slime-eval-print-last-expression} +@fcnindex{slime-eval-region} +@fcnindex{slime-fuzzy-abort} +@fcnindex{slime-fuzzy-complete-symbol} +@fcnindex{slime-fuzzy-completions-mode} +@c @fcnindex{slime-fuzzy-next} +@c @fcnindex{slime-fuzzy-prev} +@c @fcnindex{slime-fuzzy-select} +@c @fcnindex{slime-fuzzy-select/mouse} +@fcnindex{slime-goto-connection} +@fcnindex{slime-goto-xref} +@c @fcnindex{slime-handle-repl-shortcut} +@c @fcnindex{slime-highlight-notes} +@fcnindex{slime-hyperspec-lookup} +@c @fcnindex{slime-indent-and-complete-symbol} +@c @fcnindex{slime-init-keymaps} +@c @fcnindex{slime-insert-arglist} +@c @fcnindex{slime-insert-balanced-comments} +@fcnindex{slime-inspect} +@fcnindex{slime-inspector-copy-down} +@fcnindex{slime-inspector-describe} +@fcnindex{slime-inspector-next} +@c @fcnindex{slime-inspector-next-inspectable-object} +@fcnindex{slime-inspector-quit} +@c @fcnindex{slime-inspector-reinspect} +@fcnindex{slime-interactive-eval} +@fcnindex{slime-interrupt} +@fcnindex{slime-list-callees} +@fcnindex{slime-list-callers} +@c @fcnindex{slime-list-compiler-notes} +@fcnindex{slime-list-connections} +@c @fcnindex{slime-list-repl-shortcuts} +@fcnindex{slime-list-threads} +@fcnindex{slime-load-file} +@c @fcnindex{slime-load-system} +@fcnindex{slime-macroexpand-1} +@fcnindex{slime-macroexpand-1-inplace} +@fcnindex{slime-macroexpand-all} +@c @fcnindex{slime-make-default-connection} +@c @fcnindex{slime-make-typeout-frame} +@fcnindex{slime-mode} +@c @fcnindex{slime-next-location} +@fcnindex{slime-next-note} +@fcnindex{slime-nop} +@c @fcnindex{slime-ping} +@fcnindex{slime-pop-find-definition-stack} +@fcnindex{slime-pprint-eval-last-expression} +@c @fcnindex{slime-presentation-menu} +@c @fcnindex{slime-pretty-lambdas} +@fcnindex{slime-previous-note} +@fcnindex{slime-profile-package} +@fcnindex{slime-profile-report} +@fcnindex{slime-profile-reset} +@fcnindex{slime-profiled-functions} +@fcnindex{slime-quit} +@c @fcnindex{slime-quit-connection-at-point} +@c @fcnindex{slime-quit-lisp} +@c @fcnindex{slime-re-evaluate-defvar} +@c @fcnindex{slime-recompile-bytecode} +@c @fcnindex{slime-register-lisp-implementation} +@fcnindex{slime-reindent-defun} +@c @fcnindex{slime-remove-balanced-comments} +@fcnindex{slime-remove-notes} +@c @fcnindex{slime-repl} +@fcnindex{slime-repl-beginning-of-defun} +@fcnindex{slime-repl-bol} +@fcnindex{slime-repl-clear-buffer} +@fcnindex{slime-repl-clear-output} +@fcnindex{slime-repl-closing-return} +@c @fcnindex{slime-repl-compile-and-load} +@c @fcnindex{slime-repl-compile-system} +@c @fcnindex{slime-repl-compile/force-system} +@c @fcnindex{slime-repl-defparameter} +@fcnindex{slime-repl-end-of-defun} +@c @fcnindex{slime-repl-eol} +@c @fcnindex{slime-repl-load-system} +@c @fcnindex{slime-repl-load/force-system} +@c @fcnindex{slime-repl-mode} +@fcnindex{slime-repl-newline-and-indent} +@fcnindex{slime-repl-next-input} +@fcnindex{slime-repl-next-matching-input} +@fcnindex{slime-repl-next-prompt} +@c @fcnindex{slime-repl-pop-directory} +@c @fcnindex{slime-repl-pop-packages} +@fcnindex{slime-repl-previous-input} +@fcnindex{slime-repl-previous-matching-input} +@fcnindex{slime-repl-previous-prompt} +@c @fcnindex{slime-repl-push-directory} +@c @fcnindex{slime-repl-push-package} +@c @fcnindex{slime-repl-read-break} +@c @fcnindex{slime-repl-read-mode} +@fcnindex{slime-repl-return} +@fcnindex{slime-repl-set-package} +@c @fcnindex{slime-repl-shortcut-help} +@c @fcnindex{slime-reset} +@c @fcnindex{slime-restart-connection-at-point} +@c @fcnindex{slime-restart-inferior-lisp} +@c @fcnindex{slime-restart-inferior-lisp-aux} +@fcnindex{slime-scratch} +@c @fcnindex{slime-select-lisp-implementation} +@fcnindex{slime-selector} +@c @fcnindex{slime-send-sigint} +@c @fcnindex{slime-set-default-directory} +@c @fcnindex{slime-set-package} +@c @fcnindex{slime-show-xref} +@fcnindex{slime-space} +@c @fcnindex{slime-start-and-load} +@fcnindex{slime-switch-to-output-buffer} +@fcnindex{slime-sync-package-and-default-directory} +@c @fcnindex{slime-temp-buffer-mode} +@fcnindex{slime-temp-buffer-quit} +@c @fcnindex{slime-thread-attach} +@c @fcnindex{slime-thread-debug} +@c @fcnindex{slime-thread-control-mode} +@c @fcnindex{slime-thread-kill} +@c @fcnindex{slime-thread-quit} +@fcnindex{slime-toggle-profile-fdefinition} +@fcnindex{slime-toggle-trace-fdefinition} +@fcnindex{slime-undefine-function} +@fcnindex{slime-unprofile-all} +@fcnindex{slime-untrace-all} +@fcnindex{slime-update-connection-list} +@c @fcnindex{slime-update-indentation} ??? +@fcnindex{slime-who-binds} +@fcnindex{slime-who-calls} +@fcnindex{slime-who-macroexpands} +@fcnindex{slime-who-references} +@fcnindex{slime-who-sets} +@fcnindex{slime-who-specializes} +@c @fcnindex{slime-xref-mode} +@c @fcnindex{slime-xref-quit} +@end table + +@end ignore + +@node Key Index +@unnumbered Key (Character) Index +@printindex ky + +@node Command Index +@unnumbered Command and Function Index +@printindex fn + +@node Variable Index +@unnumbered Variable and Concept Index +@printindex vr + +@bye +Local Variables: +paragraph-start: "@[a-zA-Z]+\\({[^}]+}\\)?[ \n]\\|[ ]*$" +paragraph-separate: "@[a-zA-Z]+\\({[^}]+}\\)?[ \n]\\|[ ]*$" +End: diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/texinfo-tabulate.awk b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/texinfo-tabulate.awk new file mode 100644 index 0000000..87e7fe7 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/doc/texinfo-tabulate.awk @@ -0,0 +1,21 @@ +#!/usr/bin/env awk -f +# +# Format input lines into a multi-column texinfo table. +# Note: does not do texinfo-escaping of the input. + +# This code has been placed in the Public Domain. All warranties +# are disclaimed. + +BEGIN { + columns = 3; + printf("@multitable @columnfractions"); + for (i = 0; i < columns; i++) + printf(" %f", 1.0/columns); + print +} + +{ if (NR % columns == 1) printf("\n@item %s", $0); + else printf(" @tab %s", $0); } + +END { printf("\n@end multitable\n"); } + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/.nosearch b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/.nosearch new file mode 100644 index 0000000..5529475 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/.nosearch @@ -0,0 +1 @@ +;; normal-top-level-add-subdirs-to-load-path needs this file diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/cl-lib.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/cl-lib.el new file mode 100644 index 0000000..ce11309 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/cl-lib.el @@ -0,0 +1,410 @@ +;;; cl-lib.el --- Properly prefixed CL functions and macros -*- coding: utf-8 -*- + +;; Copyright (C) 2012, 2013, 2014 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; vcomment: Emacs-24.3's version is 1.0 so this has to stay below. +;; Version: 0.5 + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This is a forward compatibility package, which provides (a subset of) the +;; features of the cl-lib package introduced in Emacs-24.3, for use on +;; previous emacsen. + +;; Make sure this is installed *late* in your `load-path`, i.e. after Emacs's +;; built-in .../lisp/emacs-lisp directory, so that if/when you upgrade to +;; Emacs-24.3, the built-in version of the file will take precedence, otherwise +;; you could get into trouble (although we try to hack our way around the +;; problem in case it happens). + +;; This code is largely copied from Emacs-24.3's cl.el, with the alias bindings +;; simply reversed. + +;;; Code: + +;; We need to handle the situation where this package is used with an Emacs +;; that comes with a real cl-lib (i.e. ≥24.3). + +;; First line of defense: try to make sure the built-in cl-lib comes earlier in +;; load-path so we never get loaded: +;;;###autoload (let ((d (file-name-directory #$))) +;;;###autoload (when (member d load-path) +;;;###autoload (setq load-path (append (remove d load-path) (list d))))) + +(when (functionp 'macroexp--compiler-macro) + ;; `macroexp--compiler-macro' was introduced as part of the big CL + ;; reorganization which moved/reimplemented some of CL into core (mostly the + ;; setf and compiler-macro support), so its presence indicates we're running + ;; in an Emacs that comes with the new cl-lib.el, where this file should + ;; never be loaded! + (message "Real cl-lib shadowed by compatibility cl-lib? (%s)" load-file-name) + (when load-file-name + ;; (message "Let's try to patch things up") + (let ((loaddir (file-name-directory load-file-name)) + load-path-dir) + ;; Find the problematic directory from load-path. + (dolist (dir load-path) + (if (equal loaddir (expand-file-name (file-name-as-directory dir))) + (setq load-path-dir dir))) + (when load-path-dir + ;; (message "Let's move the offending dir to the end") + (setq load-path (append (remove load-path-dir load-path) + (list load-path-dir))) + ;; Here we could manually load cl-lib and then return immediately. + ;; But Emacs currently doesn't provide any way for a file to "return + ;; immediately", so instead we make sure the rest of the file does not + ;; throw away any pre-existing definition. + )))) + +(require 'cl) + +;; Some of Emacs-24.3's cl.el definition are not just aliases, because either +;; the feature was dropped from cl-lib.el or because the cl-lib version is +;; not fully compatible. +;; Let's just not include them here, since it is very important that if code +;; works with this cl-lib.el it should also work with Emacs-24.3's cl-lib.el, +;; whereas the reverse is much less important. + +(dolist (var '( + ;; loop-result-var + ;; loop-result + ;; loop-initially + ;; loop-finally + ;; loop-bindings + ;; loop-args + ;; bind-inits + ;; bind-block + ;; lambda-list-keywords + float-negative-epsilon + float-epsilon + least-negative-normalized-float + least-positive-normalized-float + least-negative-float + least-positive-float + most-negative-float + most-positive-float + ;; custom-print-functions + )) + (let ((new (intern (format "cl-%s" var)))) + (unless (boundp new) (defvaralias new var)))) + +;; The following cl-lib functions were already defined in the old cl.el, +;; with a different meaning: +;; - cl-position and cl-delete-duplicates +;; the two meanings are clearly different, but we can distinguish which was +;; meant by looking at the arguments. +;; - cl-member +;; the old meaning hasn't been used for a long time and is a subset of the +;; new, so we can simply override it. +;; - cl-adjoin +;; the old meaning is actually the same as the new except for optimizations. + +(dolist (fun '( + (get* . cl-get) + (random* . cl-random) + (rem* . cl-rem) + (mod* . cl-mod) + (round* . cl-round) + (truncate* . cl-truncate) + (ceiling* . cl-ceiling) + (floor* . cl-floor) + (rassoc* . cl-rassoc) + (assoc* . cl-assoc) + ;; (member* . cl-member) ;Handle specially below. + (delete* . cl-delete) + (remove* . cl-remove) + (defsubst* . cl-defsubst) + (sort* . cl-sort) + (function* . cl-function) + (defmacro* . cl-defmacro) + (defun* . cl-defun) + (mapcar* . cl-mapcar) + + remprop + getf + tailp + list-length + nreconc + revappend + concatenate + subseq + random-state-p + make-random-state + signum + isqrt + lcm + gcd + notevery + notany + every + some + mapcon + mapcan + mapl + maplist + map + equalp + coerce + tree-equal + nsublis + sublis + nsubst-if-not + nsubst-if + nsubst + subst-if-not + subst-if + subsetp + nset-exclusive-or + set-exclusive-or + nset-difference + set-difference + nintersection + intersection + nunion + union + rassoc-if-not + rassoc-if + assoc-if-not + assoc-if + member-if-not + member-if + merge + stable-sort + search + mismatch + count-if-not + count-if + count + position-if-not + position-if + ;; position ;Handle specially via defadvice below. + find-if-not + find-if + find + nsubstitute-if-not + nsubstitute-if + nsubstitute + substitute-if-not + substitute-if + substitute + ;; delete-duplicates ;Handle specially via defadvice below. + remove-duplicates + delete-if-not + delete-if + remove-if-not + remove-if + replace + fill + reduce + compiler-macroexpand + define-compiler-macro + assert + check-type + typep + deftype + defstruct + callf2 + callf + letf* + letf + rotatef + shiftf + remf + psetf + declare + the + locally + multiple-value-setq + multiple-value-bind + symbol-macrolet + macrolet + progv + psetq + do-all-symbols + do-symbols + dotimes + dolist + do* + do + loop + return-from + return + block + etypecase + typecase + ecase + case + load-time-value + eval-when + destructuring-bind + gentemp + gensym + pairlis + acons + subst + ;; adjoin ;It's already defined. + copy-list + ldiff + list* + cddddr + cdddar + cddadr + cddaar + cdaddr + cdadar + cdaadr + cdaaar + cadddr + caddar + cadadr + cadaar + caaddr + caadar + caaadr + caaaar + cdddr + cddar + cdadr + cdaar + caddr + cadar + caadr + caaar + tenth + ninth + eighth + seventh + sixth + fifth + fourth + third + endp + rest + second + first + svref + copy-seq + evenp + oddp + minusp + plusp + floatp-safe + declaim + proclaim + nth-value + multiple-value-call + multiple-value-apply + multiple-value-list + values-list + values + pushnew + decf + incf + + dolist + dotimes + )) + (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun))) + (intern (format "cl-%s" fun))))) + (if (fboundp new) + (unless (or (eq (symbol-function new) fun) + (eq new (and (symbolp fun) (fboundp fun) + (symbol-function fun)))) + (message "%S already defined, not rebinding" new)) + (defalias new fun)))) + +(unless (symbolp (symbol-function 'position)) + (autoload 'cl-position "cl-seq") + (defadvice cl-position (around cl-lib (cl-item cl-seq &rest cl-keys) activate) + (let ((argk (ad-get-args 2))) + (if (or (null argk) (keywordp (car argk))) + ;; This is a call to cl-lib's `cl-position'. + (setq ad-return-value + (apply #'position (ad-get-arg 0) (ad-get-arg 1) argk)) + ;; Must be a call to cl's old `cl-position'. + ad-do-it)))) + +(unless (symbolp (symbol-function 'delete-duplicates)) + (autoload 'cl-delete-duplicates "cl-seq") + (defadvice cl-delete-duplicates (around cl-lib (cl-seq &rest cl-keys) activate) + (let ((argk (ad-get-args 1))) + (if (or (null argk) (keywordp (car argk))) + ;; This is a call to cl-lib's `cl-delete-duplicates'. + (setq ad-return-value + (apply #'delete-duplicates (ad-get-arg 0) argk)) + ;; Must be a call to cl's old `cl-delete-duplicates'. + ad-do-it)))) + +(when (or (not (fboundp 'cl-member)) + (eq (symbol-function 'cl-member) #'memq)) + (defalias 'cl-member #'member*)) + +;; `cl-labels' is not 100% compatible with `labels' when using dynamic scoping +;; (mostly because it does not turn lambdas that refer to those functions into +;; closures). OTOH it is compatible when using lexical scoping. + +(unless (fboundp 'cl-labels) + (defmacro cl-labels (&rest args) + (unless (and (boundp 'lexical-binding) lexical-binding) + ;; We used to signal an error rather than a message, but in many uses of + ;; cl-labels, the value of lexical-binding doesn't actually matter. + ;; More importantly, the value of `lexical-binding' here is unreliable + ;; (it does not necessarily reflect faithfully whether the output of this + ;; macro will be interpreted as lexically bound code or not). + (message "This `cl-labels' requires `lexical-binding' to be non-nil")) + `(labels ,@args))) + +;;;; ChangeLog: + +;; 2014-02-25 Stefan Monnier +;; +;; Fixes: debbugs:16671 +;; +;; * cl-lib.el (cl-position, cl-delete-duplicate): Don't advise if >=24.3. +;; (load-path): Try to make sure we're at the end. +;; +;; 2014-01-25 Stefan Monnier +;; +;; * cl-lib.el: Resolve conflicts with old internal definitions +;; (bug#16353). +;; (dolist fun): Don't skip definitions silently. +;; (define-setf-expander): Remove, not in cl-lib. +;; (cl-position, cl-delete-duplicates): Add advice to distinguish the use +;; case. +;; (cl-member): Override old definition. +;; +;; 2013-05-22 Stefan Monnier +;; +;; * cl-lib.el (cl-labels): Demote error to message and improve it. +;; +;; 2012-11-30 Stefan Monnier +;; +;; * cl-lib.el: Try and patch things up in case we're hiding the real +;; cl-lib. +;; +;; 2012-11-22 Stefan Monnier +;; +;; Add cl-letf and cl-labels. +;; +;; 2012-11-16 Stefan Monnier +;; +;; * packages/cl-lib: New package. +;; + + +(provide 'cl-lib) +;;; cl-lib.el ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/ert-x.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/ert-x.el new file mode 100644 index 0000000..53b76f7 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/ert-x.el @@ -0,0 +1,2544 @@ +;;; ert.el --- Emacs Lisp Regression Testing + +;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc. + +;; Author: Christian M. Ohler +;; Keywords: lisp, tools + +;; This file is NOT part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; ERT is a tool for automated testing in Emacs Lisp. Its main +;; features are facilities for defining and running test cases and +;; reporting the results as well as for debugging test failures +;; interactively. +;; +;; The main entry points are `ert-deftest', which is similar to +;; `defun' but defines a test, and `ert-run-tests-interactively', +;; which runs tests and offers an interactive interface for inspecting +;; results and debugging. There is also +;; `ert-run-tests-batch-and-exit' for non-interactive use. +;; +;; The body of `ert-deftest' forms resembles a function body, but the +;; additional operators `should', `should-not' and `should-error' are +;; available. `should' is similar to cl's `assert', but signals a +;; different error when its condition is violated that is caught and +;; processed by ERT. In addition, it analyzes its argument form and +;; records information that helps debugging (`assert' tries to do +;; something similar when its second argument SHOW-ARGS is true, but +;; `should' is more sophisticated). For information on `should-not' +;; and `should-error', see their docstrings. +;; +;; See ERT's info manual as well as the docstrings for more details. +;; To compile the manual, run `makeinfo ert.texinfo' in the ERT +;; directory, then C-u M-x info ert.info in Emacs to view it. +;; +;; To see some examples of tests written in ERT, see its self-tests in +;; ert-tests.el. Some of these are tricky due to the bootstrapping +;; problem of writing tests for a testing tool, others test simple +;; functions and are straightforward. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'button) +(require 'debug) +(require 'easymenu) +(require 'ewoc) +(require 'find-func) +(require 'help) + + +;;; UI customization options. + +(defgroup ert () + "ERT, the Emacs Lisp regression testing tool." + :prefix "ert-" + :group 'lisp) + +(defface ert-test-result-expected '((((class color) (background light)) + :background "green1") + (((class color) (background dark)) + :background "green3")) + "Face used for expected results in the ERT results buffer." + :group 'ert) + +(defface ert-test-result-unexpected '((((class color) (background light)) + :background "red1") + (((class color) (background dark)) + :background "red3")) + "Face used for unexpected results in the ERT results buffer." + :group 'ert) + + +;;; Copies/reimplementations of cl functions. + +(defun ert--cl-do-remf (plist tag) + "Copy of `cl-do-remf'. Modify PLIST by removing TAG." + (let ((p (cdr plist))) + (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) + (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) + +(defun ert--remprop (sym tag) + "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." + (let ((plist (symbol-plist sym))) + (if (and plist (eq tag (car plist))) + (progn (setplist sym (cdr (cdr plist))) t) + (ert--cl-do-remf plist tag)))) + +(defun ert--remove-if-not (ert-pred ert-list) + "A reimplementation of `remove-if-not'. + +ERT-PRED is a predicate, ERT-LIST is the input list." + (loop for ert-x in ert-list + if (funcall ert-pred ert-x) + collect ert-x)) + +(defun ert--intersection (a b) + "A reimplementation of `intersection'. Intersect the sets A and B. + +Elements are compared using `eql'." + (loop for x in a + if (memql x b) + collect x)) + +(defun ert--set-difference (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eql'." + (loop for x in a + unless (memql x b) + collect x)) + +(defun ert--set-difference-eq (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eq'." + (loop for x in a + unless (memq x b) + collect x)) + +(defun ert--union (a b) + "A reimplementation of `union'. Compute the union of the sets A and B. + +Elements are compared using `eql'." + (append a (ert--set-difference b a))) + +(eval-and-compile + (defvar ert--gensym-counter 0)) + +(eval-and-compile + (defun ert--gensym (&optional prefix) + "Only allows string PREFIX, not compatible with CL." + (unless prefix (setq prefix "G")) + (make-symbol (format "%s%s" + prefix + (prog1 ert--gensym-counter + (incf ert--gensym-counter)))))) + +(defun ert--coerce-to-vector (x) + "Coerce X to a vector." + (when (char-table-p x) (error "Not supported")) + (if (vectorp x) + x + (vconcat x))) + +(defun* ert--remove* (x list &key key test) + "Does not support all the keywords of remove*." + (unless key (setq key #'identity)) + (unless test (setq test #'eql)) + (loop for y in list + unless (funcall test x (funcall key y)) + collect y)) + +(defun ert--string-position (c s) + "Return the position of the first occurrence of C in S, or nil if none." + (loop for i from 0 + for x across s + when (eql x c) return i)) + +(defun ert--mismatch (a b) + "Return index of first element that differs between A and B. + +Like `mismatch'. Uses `equal' for comparison." + (cond ((or (listp a) (listp b)) + (ert--mismatch (ert--coerce-to-vector a) + (ert--coerce-to-vector b))) + ((> (length a) (length b)) + (ert--mismatch b a)) + (t + (let ((la (length a)) + (lb (length b))) + (assert (arrayp a) t) + (assert (arrayp b) t) + (assert (<= la lb) t) + (loop for i below la + when (not (equal (aref a i) (aref b i))) return i + finally (return (if (/= la lb) + la + (assert (equal a b) t) + nil))))))) + +(defun ert--subseq (seq start &optional end) + "Return a subsequence of SEQ from START to END." + (when (char-table-p seq) (error "Not supported")) + (let ((vector (substring (ert--coerce-to-vector seq) start end))) + (etypecase seq + (vector vector) + (string (concat vector)) + (list (append vector nil)) + (bool-vector (loop with result = (make-bool-vector (length vector) nil) + for i below (length vector) do + (setf (aref result i) (aref vector i)) + finally (return result))) + (char-table (assert nil))))) + +(defun ert-equal-including-properties (a b) + "Return t if A and B have similar structure and contents. + +This is like `equal-including-properties' except that it compares +the property values of text properties structurally (by +recursing) rather than with `eq'. Perhaps this is what +`equal-including-properties' should do in the first place; see +Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." + ;; This implementation is inefficient. Rather than making it + ;; efficient, let's hope bug 6581 gets fixed so that we can delete + ;; it altogether. + (not (ert--explain-not-equal-including-properties a b))) + + +;;; Defining and locating tests. + +;; The data structure that represents a test case. +(defstruct ert-test + (name nil) + (documentation nil) + (body (assert nil)) + (most-recent-result nil) + (expected-result-type ':passed) + (tags '())) + +(defun ert-test-boundp (symbol) + "Return non-nil if SYMBOL names a test." + (and (get symbol 'ert--test) t)) + +(defun ert-get-test (symbol) + "If SYMBOL names a test, return that. Signal an error otherwise." + (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) + (get symbol 'ert--test)) + +(defun ert-set-test (symbol definition) + "Make SYMBOL name the test DEFINITION, and return DEFINITION." + (when (eq symbol 'nil) + ;; We disallow nil since `ert-test-at-point' and related functions + ;; want to return a test name, but also need an out-of-band value + ;; on failure. Nil is the most natural out-of-band value; using 0 + ;; or "" or signalling an error would be too awkward. + ;; + ;; Note that nil is still a valid value for the `name' slot in + ;; ert-test objects. It designates an anonymous test. + (error "Attempt to define a test named nil")) + (put symbol 'ert--test definition) + definition) + +(defun ert-make-test-unbound (symbol) + "Make SYMBOL name no test. Return SYMBOL." + (ert--remprop symbol 'ert--test) + symbol) + +(defun ert--parse-keys-and-body (keys-and-body) + "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. + +KEYS-AND-BODY should have the form of a property list, with the +exception that only keywords are permitted as keys and that the +tail -- the body -- is a list of forms that does not start with a +keyword. + +Returns a two-element list containing the keys-and-values plist +and the body." + (let ((extracted-key-accu '()) + (remaining keys-and-body)) + (while (and (consp remaining) (keywordp (first remaining))) + (let ((keyword (pop remaining))) + (unless (consp remaining) + (error "Value expected after keyword %S in %S" + keyword keys-and-body)) + (when (assoc keyword extracted-key-accu) + (warn "Keyword %S appears more than once in %S" keyword + keys-and-body)) + (push (cons keyword (pop remaining)) extracted-key-accu))) + (setq extracted-key-accu (nreverse extracted-key-accu)) + (list (loop for (key . value) in extracted-key-accu + collect key + collect value) + remaining))) + +;;;###autoload +(defmacro* ert-deftest (name () &body docstring-keys-and-body) + "Define NAME (a symbol) as a test. + +BODY is evaluated as a `progn' when the test is run. It should +signal a condition on failure or just return if the test passes. + +`should', `should-not' and `should-error' are useful for +assertions in BODY. + +Use `ert' to run tests interactively. + +Tests that are expected to fail can be marked as such +using :expected-result. See `ert-test-result-type-p' for a +description of valid values for RESULT-TYPE. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +\[:tags '(TAG...)] BODY...)" + (declare (debug (&define :name test + name sexp [&optional stringp] + [&rest keywordp sexp] def-body)) + (doc-string 3) + (indent 2)) + (let ((documentation nil) + (documentation-supplied-p nil)) + (when (stringp (first docstring-keys-and-body)) + (setq documentation (pop docstring-keys-and-body) + documentation-supplied-p t)) + (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) + (ert--parse-keys-and-body docstring-keys-and-body) + `(progn + (ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when expected-result-supplied-p + `(:expected-result-type ,expected-result)) + ,@(when tags-supplied-p + `(:tags ,tags)) + :body (lambda () ,@body))) + ;; This hack allows `symbol-file' to associate `ert-deftest' + ;; forms with files, and therefore enables `find-function' to + ;; work with tests. However, it leads to warnings in + ;; `unload-feature', which doesn't know how to undefine tests + ;; and has no mechanism for extension. + (push '(ert-deftest . ,name) current-load-list) + ',name)))) + +;; We use these `put' forms in addition to the (declare (indent)) in +;; the defmacro form since the `declare' alone does not lead to +;; correct indentation before the .el/.elc file is loaded. +;; Autoloading these `put' forms solves this. +;;;###autoload +(progn + ;; TODO(ohler): Figure out what these mean and make sure they are correct. + (put 'ert-deftest 'lisp-indent-function 2) + (put 'ert-info 'lisp-indent-function 1)) + +(defvar ert--find-test-regexp + (concat "^\\s-*(ert-deftest" + find-function-space-re + "%s\\(\\s-\\|$\\)") + "The regexp the `find-function' mechanisms use for finding test definitions.") + + +(put 'ert-test-failed 'error-conditions '(error ert-test-failed)) +(put 'ert-test-failed 'error-message "Test failed") + +(defun ert-pass () + "Terminate the current test and mark it passed. Does not return." + (throw 'ert--pass nil)) + +(defun ert-fail (data) + "Terminate the current test and mark it failed. Does not return. +DATA is displayed to the user and should state the reason of the failure." + (signal 'ert-test-failed (list data))) + + +;;; The `should' macros. + +(defvar ert--should-execution-observer nil) + +(defun ert--signal-should-execution (form-description) + "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." + (when ert--should-execution-observer + (funcall ert--should-execution-observer form-description))) + +(defun ert--special-operator-p (thing) + "Return non-nil if THING is a symbol naming a special operator." + (and (symbolp thing) + (let ((definition (indirect-function thing t))) + (and (subrp definition) + (eql (cdr (subr-arity definition)) 'unevalled))))) + +(defun ert--expand-should-1 (whole form inner-expander) + "Helper function for the `should' macro and its variants." + (let ((form + ;; If `cl-macroexpand' isn't bound, the code that we're + ;; compiling doesn't depend on cl and thus doesn't need an + ;; environment arg for `macroexpand'. + (if (fboundp 'cl-macroexpand) + ;; Suppress warning about run-time call to cl funtion: we + ;; only call it if it's fboundp. + (with-no-warnings + (cl-macroexpand form (and (boundp 'cl-macro-environment) + cl-macro-environment))) + (macroexpand form)))) + (cond + ((or (atom form) (ert--special-operator-p (car form))) + (let ((value (ert--gensym "value-"))) + `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) + ,(funcall inner-expander + `(setq ,value ,form) + `(list ',whole :form ',form :value ,value) + value) + ,value))) + (t + (let ((fn-name (car form)) + (arg-forms (cdr form))) + (assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) + (let ((fn (ert--gensym "fn-")) + (args (ert--gensym "args-")) + (value (ert--gensym "value-")) + (default-value (ert--gensym "ert-form-evaluation-aborted-"))) + `(let ((,fn (function ,fn-name)) + (,args (list ,@arg-forms))) + (let ((,value ',default-value)) + ,(funcall inner-expander + `(setq ,value (apply ,fn ,args)) + `(nconc (list ',whole) + (list :form `(,,fn ,@,args)) + (unless (eql ,value ',default-value) + (list :value ,value)) + (let ((-explainer- + (and (symbolp ',fn-name) + (get ',fn-name 'ert-explainer)))) + (when -explainer- + (list :explanation + (apply -explainer- ,args))))) + value) + ,value)))))))) + +(defun ert--expand-should (whole form inner-expander) + "Helper function for the `should' macro and its variants. + +Analyzes FORM and returns an expression that has the same +semantics under evaluation but records additional debugging +information. + +INNER-EXPANDER should be a function and is called with two +arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM +is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is +an expression that returns a description of FORM. INNER-EXPANDER +should return code that calls INNER-FORM and performs the checks +and error signalling specific to the particular variant of +`should'. The code that INNER-EXPANDER returns must not call +FORM-DESCRIPTION-FORM before it has called INNER-FORM." + (lexical-let ((inner-expander inner-expander)) + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (ert--gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var))))))) + +(defmacro* should (form) + "Evaluate FORM. If it returns nil, abort the current test as failed. + +Returns the value of FORM." + (ert--expand-should `(should ,form) form + (lambda (inner-form form-description-form value-var) + `(unless ,inner-form + (ert-fail ,form-description-form))))) + +(defmacro* should-not (form) + "Evaluate FORM. If it returns non-nil, abort the current test as failed. + +Returns nil." + (ert--expand-should `(should-not ,form) form + (lambda (inner-form form-description-form value-var) + `(unless (not ,inner-form) + (ert-fail ,form-description-form))))) + +(defun ert--should-error-handle-error (form-description-fn + condition type exclude-subtypes) + "Helper function for `should-error'. + +Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, +and aborts the current test as failed if it doesn't." + (let ((signalled-conditions (get (car condition) 'error-conditions)) + (handled-conditions (etypecase type + (list type) + (symbol (list type))))) + (assert signalled-conditions) + (unless (ert--intersection signalled-conditions handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled did not" + " have the expected type"))))) + (when exclude-subtypes + (unless (member (car condition) handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled was a subtype" + " of the expected type")))))))) + +;; FIXME: The expansion will evaluate the keyword args (if any) in +;; nonstandard order. +(defmacro* should-error (form &rest keys &key type exclude-subtypes) + "Evaluate FORM and check that it signals an error. + +The error signalled needs to match TYPE. TYPE should be a list +of condition names. (It can also be a non-nil symbol, which is +equivalent to a singleton list containing that symbol.) If +EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its +condition names is an element of TYPE. If EXCLUDE-SUBTYPES is +non-nil, the error matches TYPE if it is an element of TYPE. + +If the error matches, returns (ERROR-SYMBOL . DATA) from the +error. If not, or if no error was signalled, abort the test as +failed." + (unless type (setq type ''error)) + (ert--expand-should + `(should-error ,form ,@keys) + form + (lambda (inner-form form-description-form value-var) + (let ((errorp (ert--gensym "errorp")) + (form-description-fn (ert--gensym "form-description-fn-"))) + `(let ((,errorp nil) + (,form-description-fn (lambda () ,form-description-form))) + (condition-case -condition- + ,inner-form + ;; We can't use ,type here because we want to evaluate it. + (error + (setq ,errorp t) + (ert--should-error-handle-error ,form-description-fn + -condition- + ,type ,exclude-subtypes) + (setq ,value-var -condition-))) + (unless ,errorp + (ert-fail (append + (funcall ,form-description-fn) + (list + :fail-reason "did not signal an error"))))))))) + + +;;; Explanation of `should' failures. + +;; TODO(ohler): Rework explanations so that they are displayed in a +;; similar way to `ert-info' messages; in particular, allow text +;; buttons in explanations that give more detail or open an ediff +;; buffer. Perhaps explanations should be reported through `ert-info' +;; rather than as part of the condition. + +(defun ert--proper-list-p (x) + "Return non-nil if X is a proper list, nil otherwise." + (loop + for firstp = t then nil + for fast = x then (cddr fast) + for slow = x then (cdr slow) do + (when (null fast) (return t)) + (when (not (consp fast)) (return nil)) + (when (null (cdr fast)) (return t)) + (when (not (consp (cdr fast))) (return nil)) + (when (and (not firstp) (eq fast slow)) (return nil)))) + +(defun ert--explain-format-atom (x) + "Format the atom X for `ert--explain-not-equal'." + (typecase x + (fixnum (list x (format "#x%x" x) (format "?%c" x))) + (t x))) + +(defun ert--explain-not-equal (a b) + "Explainer function for `equal'. + +Returns a programmer-readable explanation of why A and B are not +`equal', or nil if they are." + (if (not (equal (type-of a) (type-of b))) + `(different-types ,a ,b) + (etypecase a + (cons + (let ((a-proper-p (ert--proper-list-p a)) + (b-proper-p (ert--proper-list-p b))) + (if (not (eql (not a-proper-p) (not b-proper-p))) + `(one-list-proper-one-improper ,a ,b) + (if a-proper-p + (if (not (equal (length a) (length b))) + `(proper-lists-of-different-length ,(length a) ,(length b) + ,a ,b + first-mismatch-at + ,(ert--mismatch a b)) + (loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-not-equal ai bi) + do (when xi (return `(list-elt ,i ,xi))) + finally (assert (equal a b) t))) + (let ((car-x (ert--explain-not-equal (car a) (car b)))) + (if car-x + `(car ,car-x) + (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b)))) + (if cdr-x + `(cdr ,cdr-x) + (assert (equal a b) t) + nil)))))))) + (array (if (not (equal (length a) (length b))) + `(arrays-of-different-length ,(length a) ,(length b) + ,a ,b + ,@(unless (char-table-p a) + `(first-mismatch-at + ,(ert--mismatch a b)))) + (loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-not-equal ai bi) + do (when xi (return `(array-elt ,i ,xi))) + finally (assert (equal a b) t)))) + (atom (if (not (equal a b)) + (if (and (symbolp a) (symbolp b) (string= a b)) + `(different-symbols-with-the-same-name ,a ,b) + `(different-atoms ,(ert--explain-format-atom a) + ,(ert--explain-format-atom b))) + nil))))) +(put 'equal 'ert-explainer 'ert--explain-not-equal) + +(defun ert--significant-plist-keys (plist) + "Return the keys of PLIST that have non-null values, in order." + (assert (zerop (mod (length plist) 2)) t) + (loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (return accu))) + +(defun ert--plist-difference-explanation (a b) + "Return a programmer-readable explanation of why A and B are different plists. + +Returns nil if they are equivalent, i.e., have the same value for +each key, where absent values are treated as nil. The order of +key/value pairs in each list does not matter." + (assert (zerop (mod (length a) 2)) t) + (assert (zerop (mod (length b) 2)) t) + ;; Normalizing the plists would be another way to do this but it + ;; requires a total ordering on all lisp objects (since any object + ;; is valid as a text property key). Perhaps defining such an + ;; ordering is useful in other contexts, too, but it's a lot of + ;; work, so let's punt on it for now. + (let* ((keys-a (ert--significant-plist-keys a)) + (keys-b (ert--significant-plist-keys b)) + (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) + (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) + (flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-not-equal-including-properties value-a + value-b))))) + (cond (keys-in-a-not-in-b + (explain-with-key (first keys-in-a-not-in-b))) + (keys-in-b-not-in-a + (explain-with-key (first keys-in-b-not-in-a))) + (t + (loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) + +(defun ert--abbreviate-string (s len suffixp) + "Shorten string S to at most LEN chars. + +If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." + (let ((n (length s))) + (cond ((< n len) + s) + (suffixp + (substring s (- n len))) + (t + (substring s 0 len))))) + +(defun ert--explain-not-equal-including-properties (a b) + "Explainer function for `ert-equal-including-properties'. + +Returns a programmer-readable explanation of why A and B are not +`ert-equal-including-properties', or nil if they are." + (if (not (equal a b)) + (ert--explain-not-equal a b) + (assert (stringp a) t) + (assert (stringp b) t) + (assert (eql (length a) (length b)) t) + (loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation props-a props-b) + do (when difference + (return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + ;; TODO(ohler): Get `equal-including-properties' fixed in + ;; Emacs, delete `ert-equal-including-properties', and + ;; re-enable this assertion. + ;;finally (assert (equal-including-properties a b) t) + ))) +(put 'ert-equal-including-properties + 'ert-explainer + 'ert--explain-not-equal-including-properties) + + +;;; Implementation of `ert-info'. + +;; TODO(ohler): The name `info' clashes with +;; `ert--test-execution-info'. One or both should be renamed. +(defvar ert--infos '() + "The stack of `ert-info' infos that currently apply. + +Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") + +(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) + "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. + +To be used within ERT tests. MESSAGE-FORM should evaluate to a +string that will be displayed together with the test result if +the test fails. PREFIX-FORM should evaluate to a string as well +and is displayed in front of the value of MESSAGE-FORM." + (declare (debug ((form &rest [sexp form]) body)) + (indent 1)) + `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) + ,@body)) + + + +;;; Facilities for running a single test. + +(defvar ert-debug-on-error nil + "Non-nil means enter debugger when a test fails or terminates with an error.") + +;; The data structures that represent the result of running a test. +(defstruct ert-test-result + (messages nil) + (should-forms nil) + ) +(defstruct (ert-test-passed (:include ert-test-result))) +(defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (assert nil)) + (backtrace (assert nil)) + (infos (assert nil))) +(defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) + + +(defun ert--record-backtrace () + "Record the current backtrace (as a list) and return it." + ;; Since the backtrace is stored in the result object, result + ;; objects must only be printed with appropriate limits + ;; (`print-level' and `print-length') in place. For interactive + ;; use, the cost of ensuring this possibly outweighs the advantage + ;; of storing the backtrace for + ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we + ;; already have `ert-results-rerun-test-debugging-errors-at-point'. + ;; For batch use, however, printing the backtrace may be useful. + (loop + ;; 6 is the number of frames our own debugger adds (when + ;; compiled; more when interpreted). FIXME: Need to describe a + ;; procedure for determining this constant. + for i from 6 + for frame = (backtrace-frame i) + while frame + collect frame)) + +(defun ert--print-backtrace (backtrace) + "Format the backtrace BACKTRACE to the current buffer." + ;; This is essentially a reimplementation of Fbacktrace + ;; (src/eval.c), but for a saved backtrace, not the current one. + (let ((print-escape-newlines t) + (print-level 8) + (print-length 50)) + (dolist (frame backtrace) + (ecase (first frame) + ((nil) + ;; Special operator. + (destructuring-bind (special-operator &rest arg-forms) + (cdr frame) + (insert + (format " %S\n" (list* special-operator arg-forms))))) + ((t) + ;; Function call. + (destructuring-bind (fn &rest args) (cdr frame) + (insert (format " %S(" fn)) + (loop for firstp = t then nil + for arg in args do + (unless firstp + (insert " ")) + (insert (format "%S" arg))) + (insert ")\n"))))))) + +;; A container for the state of the execution of a single test and +;; environment data needed during its execution. +(defstruct ert--test-execution-info + (test (assert nil)) + (result (assert nil)) + ;; A thunk that may be called when RESULT has been set to its final + ;; value and test execution should be terminated. Should not + ;; return. + (exit-continuation (assert nil)) + ;; The binding of `debugger' outside of the execution of the test. + next-debugger + ;; The binding of `ert-debug-on-error' that is in effect for the + ;; execution of the current test. We store it to avoid being + ;; affected by any new bindings the test itself may establish. (I + ;; don't remember whether this feature is important.) + ert-debug-on-error) + +(defun ert--run-test-debugger (info debugger-args) + "During a test run, `debugger' is bound to a closure that calls this function. + +This function records failures and errors and either terminates +the test silently or calls the interactive debugger, as +appropriate. + +INFO is the ert--test-execution-info corresponding to this test +run. DEBUGGER-ARGS are the arguments to `debugger'." + (destructuring-bind (first-debugger-arg &rest more-debugger-args) + debugger-args + (ecase first-debugger-arg + ((lambda debug t exit nil) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (error + (let* ((condition (first more-debugger-args)) + (type (case (car condition) + ((quit) 'quit) + (otherwise 'failed))) + (backtrace (ert--record-backtrace)) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; Work around Emacs' heuristic (in eval.c) for detecting + ;; errors in the debugger. + (incf num-nonmacro-input-events) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info))))))) + +(defun ert--run-test-internal (ert-test-execution-info) + "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. + +This mainly sets up debugger-related bindings." + (lexical-let ((info ert-test-execution-info)) + (setf (ert--test-execution-info-next-debugger info) debugger + (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((debugger (lambda (&rest debugger-args) + (ert--run-test-debugger info debugger-args))) + (debug-on-error t) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result info) (make-ert-test-passed))) + nil) + +(defun ert--force-message-log-buffer-truncation () + "Immediately truncate *Messages* buffer according to `message-log-max'. + +This can be useful after reducing the value of `message-log-max'." + (with-current-buffer (get-buffer-create "*Messages*") + ;; This is a reimplementation of this part of message_dolog() in xdisp.c: + ;; if (NATNUMP (Vmessage_log_max)) + ;; { + ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, + ;; -XFASTINT (Vmessage_log_max) - 1, 0); + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); + ;; } + (when (and (integerp message-log-max) (>= message-log-max 0)) + (let ((begin (point-min)) + (end (save-excursion + (goto-char (point-max)) + (forward-line (- message-log-max)) + (point)))) + (delete-region begin end))))) + +(defvar ert--running-tests nil + "List of tests that are currently in execution. + +This list is empty while no test is running, has one element +while a test is running, two elements while a test run from +inside a test is running, etc. The list is in order of nesting, +innermost test first. + +The elements are of type `ert-test'.") + +(defun ert-run-test (ert-test) + "Run ERT-TEST. + +Returns the result and stores it in ERT-TEST's `most-recent-result' slot." + (setf (ert-test-most-recent-result ert-test) nil) + (block error + (lexical-let ((begin-marker + (with-current-buffer (get-buffer-create "*Messages*") + (set-marker (make-marker) (point-max))))) + (unwind-protect + (lexical-let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (return-from error nil)))) + (should-form-accu (list))) + (unwind-protect + (let ((ert--should-execution-observer + (lambda (form-description) + (push form-description should-form-accu))) + (message-log-max t) + (ert--running-tests (cons ert-test ert--running-tests))) + (ert--run-test-internal info)) + (let ((result (ert--test-execution-info-result info))) + (setf (ert-test-result-messages result) + (with-current-buffer (get-buffer-create "*Messages*") + (buffer-substring begin-marker (point-max)))) + (ert--force-message-log-buffer-truncation) + (setq should-form-accu (nreverse should-form-accu)) + (setf (ert-test-result-should-forms result) + should-form-accu) + (setf (ert-test-most-recent-result ert-test) result)))) + (set-marker begin-marker nil)))) + (ert-test-most-recent-result ert-test)) + +(defun ert-running-test () + "Return the top-level test currently executing." + (car (last ert--running-tests))) + + +;;; Test selectors. + +(defun ert-test-result-type-p (result result-type) + "Return non-nil if RESULT matches type RESULT-TYPE. + +Valid result types: + +nil -- Never matches. +t -- Always matches. +:failed, :passed -- Matches corresponding results. +\(and TYPES...\) -- Matches if all TYPES match. +\(or TYPES...\) -- Matches if some TYPES match. +\(not TYPE\) -- Matches if TYPE does not match. +\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with + RESULT." + ;; It would be easy to add `member' and `eql' types etc., but I + ;; haven't bothered yet. + (etypecase result-type + ((member nil) nil) + ((member t) t) + ((member :failed) (ert-test-failed-p result)) + ((member :passed) (ert-test-passed-p result)) + (cons + (destructuring-bind (operator &rest operands) result-type + (ecase operator + (and + (case (length operands) + (0 t) + (t + (and (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(and ,@(rest operands))))))) + (or + (case (length operands) + (0 nil) + (t + (or (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(or ,@(rest operands))))))) + (not + (assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (first operands)))) + (satisfies + (assert (eql (length operands) 1)) + (funcall (first operands) result))))))) + +(defun ert-test-result-expected-p (test result) + "Return non-nil if TEST's expected result type matches RESULT." + (ert-test-result-type-p result (ert-test-expected-result-type test))) + +(defun ert-select-tests (selector universe) + "Return the tests that match SELECTOR. + +UNIVERSE specifies the set of tests to select from; it should be +a list of tests, or t, which refers to all tests named by symbols +in `obarray'. + +Returns the set of tests as a list. + +Valid selectors: + +nil -- Selects the empty set. +t -- Selects UNIVERSE. +:new -- Selects all tests that have not been run yet. +:failed, :passed -- Select tests according to their most recent result. +:expected, :unexpected -- Select tests according to their most recent result. +a string -- Selects all tests that have a name that matches the string, + a regexp. +a test -- Selects that test. +a symbol -- Selects the test that the symbol names, errors if none. +\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests. +\(eql TEST\) -- Selects TEST, a test or a symbol naming a test. +\(and SELECTORS...\) -- Selects the tests that match all SELECTORS. +\(or SELECTORS...\) -- Selects the tests that match any SELECTOR. +\(not SELECTOR\) -- Selects all tests that do not match SELECTOR. +\(tag TAG) -- Selects all tests that have TAG on their tags list. +\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE. + +Only selectors that require a superset of tests, such +as (satisfies ...), strings, :new, etc. make use of UNIVERSE. +Selectors that do not, such as \(member ...\), just return the +set implied by them without checking whether it is really +contained in UNIVERSE." + ;; This code needs to match the etypecase in + ;; `ert-insert-human-readable-selector'. + (etypecase selector + ((member nil) nil) + ((member t) (etypecase universe + (list universe) + ((member t) (ert-select-tests "" universe)))) + ((member :new) (ert-select-tests + `(satisfies ,(lambda (test) + (null (ert-test-most-recent-result test)))) + universe)) + ((member :failed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':failed))) + universe)) + ((member :passed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':passed))) + universe)) + ((member :expected) (ert-select-tests + `(satisfies + ,(lambda (test) + (ert-test-result-expected-p + test + (ert-test-most-recent-result test)))) + universe)) + ((member :unexpected) (ert-select-tests `(not :expected) universe)) + (string + (etypecase universe + ((member t) (mapcar #'ert-get-test + (apropos-internal selector #'ert-test-boundp))) + (list (ert--remove-if-not (lambda (test) + (and (ert-test-name test) + (string-match selector + (ert-test-name test)))) + universe)))) + (ert-test (list selector)) + (symbol + (assert (ert-test-boundp selector)) + (list (ert-get-test selector))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + (member + (mapcar (lambda (purported-test) + (etypecase purported-test + (symbol (assert (ert-test-boundp purported-test)) + (ert-get-test purported-test)) + (ert-test purported-test))) + operands)) + (eql + (assert (eql (length operands) 1)) + (ert-select-tests `(member ,@operands) universe)) + (and + ;; Do these definitions of AND, NOT and OR satisfy de + ;; Morgan's laws? Should they? + (case (length operands) + (0 (ert-select-tests 't universe)) + (t (ert-select-tests `(and ,@(rest operands)) + (ert-select-tests (first operands) + universe))))) + (not + (assert (eql (length operands) 1)) + (let ((all-tests (ert-select-tests 't universe))) + (ert--set-difference all-tests + (ert-select-tests (first operands) + all-tests)))) + (or + (case (length operands) + (0 (ert-select-tests 'nil universe)) + (t (ert--union (ert-select-tests (first operands) universe) + (ert-select-tests `(or ,@(rest operands)) + universe))))) + (tag + (assert (eql (length operands) 1)) + (let ((tag (first operands))) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe))) + (satisfies + (assert (eql (length operands) 1)) + (ert--remove-if-not (first operands) + (ert-select-tests 't universe)))))))) + +(defun ert--insert-human-readable-selector (selector) + "Insert a human-readable presentation of SELECTOR into the current buffer." + ;; This is needed to avoid printing the (huge) contents of the + ;; `backtrace' slot of the result objects in the + ;; `most-recent-result' slots of test case objects in (eql ...) or + ;; (member ...) selectors. + (labels ((rec (selector) + ;; This code needs to match the etypecase in `ert-select-tests'. + (etypecase selector + ((or (member nil t + :new :failed :passed + :expected :unexpected) + string + symbol) + selector) + (ert-test + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol ""))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + ((member eql and not or) + `(,operator ,@(mapcar #'rec operands))) + ((member tag satisfies) + selector))))))) + (insert (format "%S" (rec selector))))) + + +;;; Facilities for running a whole set of tests. + +;; The data structure that contains the set of tests being executed +;; during one particular test run, their results, the state of the +;; execution, and some statistics. +;; +;; The data about results and expected results of tests may seem +;; redundant here, since the test objects also carry such information. +;; However, the information in the test objects may be more recent, it +;; may correspond to a different test run. We need the information +;; that corresponds to this run in order to be able to update the +;; statistics correctly when a test is re-run interactively and has a +;; different result than before. +(defstruct ert--stats + (selector (assert nil)) + ;; The tests, in order. + (tests (assert nil) :type vector) + ;; A map of test names (or the test objects themselves for unnamed + ;; tests) to indices into the `tests' vector. + (test-map (assert nil) :type hash-table) + ;; The results of the tests during this run, in order. + (test-results (assert nil) :type vector) + ;; The start times of the tests, in order, as reported by + ;; `current-time'. + (test-start-times (assert nil) :type vector) + ;; The end times of the tests, in order, as reported by + ;; `current-time'. + (test-end-times (assert nil) :type vector) + (passed-expected 0) + (passed-unexpected 0) + (failed-expected 0) + (failed-unexpected 0) + (start-time nil) + (end-time nil) + (aborted-p nil) + (current-test nil) + ;; The time at or after which the next redisplay should occur, as a + ;; float. + (next-redisplay 0.0)) + +(defun ert-stats-completed-expected (stats) + "Return the number of tests in STATS that had expected results." + (+ (ert--stats-passed-expected stats) + (ert--stats-failed-expected stats))) + +(defun ert-stats-completed-unexpected (stats) + "Return the number of tests in STATS that had unexpected results." + (+ (ert--stats-passed-unexpected stats) + (ert--stats-failed-unexpected stats))) + +(defun ert-stats-completed (stats) + "Number of tests in STATS that have run so far." + (+ (ert-stats-completed-expected stats) + (ert-stats-completed-unexpected stats))) + +(defun ert-stats-total (stats) + "Number of tests in STATS, regardless of whether they have run yet." + (length (ert--stats-tests stats))) + +;; The stats object of the current run, dynamically bound. This is +;; used for the mode line progress indicator. +(defvar ert--current-run-stats nil) + +(defun ert--stats-test-key (test) + "Return the key used for TEST in the test map of ert--stats objects. + +Returns the name of TEST if it has one, or TEST itself otherwise." + (or (ert-test-name test) test)) + +(defun ert--stats-set-test-and-result (stats pos test result) + "Change STATS by replacing the test at position POS with TEST and RESULT. + +Also changes the counters in STATS to match." + (let* ((tests (ert--stats-tests stats)) + (results (ert--stats-test-results stats)) + (old-test (aref tests pos)) + (map (ert--stats-test-map stats))) + (flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-expected stats) d)) + (ert-test-failed (incf (ert--stats-failed-expected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit))))) + ;; Adjust counters to remove the result that is currently in stats. + (update -1) + ;; Put new test and result into stats. + (setf (aref tests pos) test + (aref results pos) result) + (remhash (ert--stats-test-key old-test) map) + (setf (gethash (ert--stats-test-key test) map) pos) + ;; Adjust counters to match new result. + (update +1) + nil))) + +(defun ert--make-stats (tests selector) + "Create a new `ert--stats' object for running TESTS. + +SELECTOR is the selector that was used to select TESTS." + (setq tests (ert--coerce-to-vector tests)) + (let ((map (make-hash-table :size (length tests)))) + (loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (assert (not (gethash key map))) + (setf (gethash key map) i)) + (make-ert--stats :selector selector + :tests tests + :test-map map + :test-results (make-vector (length tests) nil) + :test-start-times (make-vector (length tests) nil) + :test-end-times (make-vector (length tests) nil)))) + +(defun ert-run-or-rerun-test (stats test listener) + ;; checkdoc-order: nil + "Run the single test TEST and record the result using STATS and LISTENER." + (let ((ert--current-run-stats stats) + (pos (ert--stats-test-pos stats test))) + (ert--stats-set-test-and-result stats pos test nil) + ;; Call listener after setting/before resetting + ;; (ert--stats-current-test stats); the listener might refresh the + ;; mode line display, and if the value is not set yet/any more + ;; during this refresh, the mode line will flicker unnecessarily. + (setf (ert--stats-current-test stats) test) + (funcall listener 'test-started stats test) + (setf (ert-test-most-recent-result test) nil) + (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) + (unwind-protect + (ert-run-test test) + (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) + (let ((result (ert-test-most-recent-result test))) + (ert--stats-set-test-and-result stats pos test result) + (funcall listener 'test-ended stats test result)) + (setf (ert--stats-current-test stats) nil)))) + +(defun ert-run-tests (selector listener) + "Run the tests specified by SELECTOR, sending progress updates to LISTENER." + (let* ((tests (ert-select-tests selector t)) + (stats (ert--make-stats tests selector))) + (setf (ert--stats-start-time stats) (current-time)) + (funcall listener 'run-started stats) + (let ((abortedp t)) + (unwind-protect + (let ((ert--current-run-stats stats)) + (force-mode-line-update) + (unwind-protect + (progn + (loop for test in tests do + (ert-run-or-rerun-test stats test listener)) + (setq abortedp nil)) + (setf (ert--stats-aborted-p stats) abortedp) + (setf (ert--stats-end-time stats) (current-time)) + (funcall listener 'run-ended stats abortedp))) + (force-mode-line-update)) + stats))) + +(defun ert--stats-test-pos (stats test) + ;; checkdoc-order: nil + "Return the position (index) of TEST in the run represented by STATS." + (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) + + +;;; Formatting functions shared across UIs. + +(defun ert--format-time-iso8601 (time) + "Format TIME in the variant of ISO 8601 used for timestamps in ERT." + (format-time-string "%Y-%m-%d %T%z" time)) + +(defun ert-char-for-test-result (result expectedp) + "Return a character that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed ".P") + (ert-test-failed "fF") + (null "--") + (ert-test-aborted-with-non-local-exit "aA")))) + (elt s (if expectedp 0 1)))) + +(defun ert-string-for-test-result (result expectedp) + "Return a string that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed '("passed" "PASSED")) + (ert-test-failed '("failed" "FAILED")) + (null '("unknown" "UNKNOWN")) + (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))))) + (elt s (if expectedp 0 1)))) + +(defun ert--pp-with-indentation-and-newline (object) + "Pretty-print OBJECT, indenting it to the current column of point. +Ensures a final newline is inserted." + (let ((begin (point))) + (pp object (current-buffer)) + (unless (bolp) (insert "\n")) + (save-excursion + (goto-char begin) + (indent-sexp)))) + +(defun ert--insert-infos (result) + "Insert `ert-info' infos from RESULT into current buffer. + +RESULT must be an `ert-test-result-with-condition'." + (check-type result ert-test-result-with-condition) + (dolist (info (ert-test-result-with-condition-infos result)) + (destructuring-bind (prefix . message) info + (let ((begin (point)) + (indentation (make-string (+ (length prefix) 4) ?\s)) + (end nil)) + (unwind-protect + (progn + (insert message "\n") + (setq end (copy-marker (point))) + (goto-char begin) + (insert " " prefix) + (forward-line 1) + (while (< (point) end) + (insert indentation) + (forward-line 1))) + (when end (set-marker end nil))))))) + + +;;; Running tests in batch mode. + +(defvar ert-batch-backtrace-right-margin 70 + "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") + +;;;###autoload +(defun ert-run-tests-batch (&optional selector) + "Run the tests specified by SELECTOR, printing results to the terminal. + +SELECTOR works as described in `ert-select-tests', except if +SELECTOR is nil, in which case all tests rather than none will be +run; this makes the command line \"emacs -batch -l my-tests.el -f +ert-run-tests-batch-and-exit\" useful. + +Returns the stats object." + (unless selector (setq selector 't)) + (ert-run-tests + selector + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (message "Running %s tests (%s)" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats))))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (let ((unexpected (ert-stats-completed-unexpected stats)) + (expected-failures (ert--stats-failed-expected stats))) + (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)) + (ert--format-time-iso8601 (ert--stats-end-time stats)) + (if (zerop expected-failures) + "" + (format "\n%s expected failures" expected-failures))) + (unless (zerop unexpected) + (message "%s unexpected results:" unexpected) + (loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) + (message "%s" ""))))) + (test-started + ) + (test-ended + (destructuring-bind (stats test result) event-args + (unless (ert-test-result-expected-p test result) + (etypecase result + (ert-test-passed + (message "Test %S passed unexpectedly" (ert-test-name test))) + (ert-test-result-with-condition + (message "Test %S backtrace:" (ert-test-name test)) + (with-temp-buffer + (ert--print-backtrace (ert-test-result-with-condition-backtrace + result)) + (goto-char (point-min)) + (while (not (eobp)) + (let ((start (point)) + (end (progn (end-of-line) (point)))) + (setq end (min end + (+ start ert-batch-backtrace-right-margin))) + (message "%s" (buffer-substring-no-properties + start end))) + (forward-line 1))) + (with-temp-buffer + (ert--insert-infos result) + (insert " ") + (let ((print-escape-newlines t) + (print-level 5) + (print-length 10)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)))) + (goto-char (1- (point-max))) + (assert (looking-at "\n")) + (delete-char 1) + (message "Test %S condition:" (ert-test-name test)) + (message "%s" (buffer-string)))) + (ert-test-aborted-with-non-local-exit + (message "Test %S aborted with non-local exit" + (ert-test-name test))))) + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S"))) + (message format-string + (ert-string-for-test-result result + (ert-test-result-expected-p + test result)) + (1+ (ert--stats-test-pos stats test)) + (ert-test-name test))))))))) + +;;;###autoload +(defun ert-run-tests-batch-and-exit (&optional selector) + "Like `ert-run-tests-batch', but exits Emacs when done. + +The exit status will be 0 if all test results were as expected, 1 +on unexpected results, or 2 if the framework detected an error +outside of the tests (e.g. invalid SELECTOR or bug in the code +that runs the tests)." + (unwind-protect + (let ((stats (ert-run-tests-batch selector))) + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 2)))) + + +;;; Utility functions for load/unload actions. + +(defun ert--activate-font-lock-keywords () + "Activate font-lock keywords for some of ERT's symbols." + (font-lock-add-keywords + nil + '(("(\\(\\\\s *\\(\\sw+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t))))) + +(defun* ert--remove-from-list (list-var element &key key test) + "Remove ELEMENT from the value of LIST-VAR if present. + +This can be used as an inverse of `add-to-list'." + (unless key (setq key #'identity)) + (unless test (setq test #'equal)) + (setf (symbol-value list-var) + (ert--remove* element + (symbol-value list-var) + :key key + :test test))) + + +;;; Some basic interactive functions. + +(defun ert-read-test-name (prompt &optional default history + add-default-to-prompt) + "Read the name of a test and return it as a symbol. + +Prompt with PROMPT. If DEFAULT is a valid test name, use it as a +default. HISTORY is the history to use; see `completing-read'. +If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to +include the default, if any. + +Signals an error if no test name was read." + (etypecase default + (string (let ((symbol (intern-soft default))) + (unless (and symbol (ert-test-boundp symbol)) + (setq default nil)))) + (symbol (setq default + (if (ert-test-boundp default) + (symbol-name default) + nil))) + (ert-test (setq default (ert-test-name default)))) + (when add-default-to-prompt + (setq prompt (if (null default) + (format "%s: " prompt) + (format "%s (default %s): " prompt default)))) + (let ((input (completing-read prompt obarray #'ert-test-boundp + t nil history default nil))) + ;; completing-read returns an empty string if default was nil and + ;; the user just hit enter. + (let ((sym (intern-soft input))) + (if (ert-test-boundp sym) + sym + (error "Input does not name a test"))))) + +(defun ert-read-test-name-at-point (prompt) + "Read the name of a test and return it as a symbol. +As a default, use the symbol at point, or the test at point if in +the ERT results buffer. Prompt with PROMPT, augmented with the +default (if any)." + (ert-read-test-name prompt (ert-test-at-point) nil t)) + +(defun ert-find-test-other-window (test-name) + "Find, in another window, the definition of TEST-NAME." + (interactive (list (ert-read-test-name-at-point "Find test definition: "))) + (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) + +(defun ert-delete-test (test-name) + "Make the test TEST-NAME unbound. + +Nothing more than an interactive interface to `ert-make-test-unbound'." + (interactive (list (ert-read-test-name-at-point "Delete test"))) + (ert-make-test-unbound test-name)) + +(defun ert-delete-all-tests () + "Make all symbols in `obarray' name no test." + (interactive) + (when (interactive-p) + (unless (y-or-n-p "Delete all tests? ") + (error "Aborted"))) + ;; We can't use `ert-select-tests' here since that gives us only + ;; test objects, and going from them back to the test name symbols + ;; can fail if the `ert-test' defstruct has been redefined. + (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) + t) + + +;;; Display of test progress and results. + +;; An entry in the results buffer ewoc. There is one entry per test. +(defstruct ert--ewoc-entry + (test (assert nil)) + ;; If the result of this test was expected, its ewoc entry is hidden + ;; initially. + (hidden-p (assert nil)) + ;; An ewoc entry may be collapsed to hide details such as the error + ;; condition. + ;; + ;; I'm not sure the ability to expand and collapse entries is still + ;; a useful feature. + (expanded-p t) + ;; By default, the ewoc entry presents the error condition with + ;; certain limits on how much to print (`print-level', + ;; `print-length'). The user can interactively switch to a set of + ;; higher limits. + (extended-printer-limits-p nil)) + +;; Variables local to the results buffer. + +;; The ewoc. +(defvar ert--results-ewoc) +;; The stats object. +(defvar ert--results-stats) +;; A string with one character per test. Each character represents +;; the result of the corresponding test. The string is displayed near +;; the top of the buffer and serves as a progress bar. +(defvar ert--results-progress-bar-string) +;; The position where the progress bar button begins. +(defvar ert--results-progress-bar-button-begin) +;; The test result listener that updates the buffer when tests are run. +(defvar ert--results-listener) + +(defun ert-insert-test-name-button (test-name) + "Insert a button that links to TEST-NAME." + (insert-text-button (format "%S" test-name) + :type 'ert--test-name-button + 'ert-test-name test-name)) + +(defun ert--results-format-expected-unexpected (expected unexpected) + "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." + (if (zerop unexpected) + (format "%s" expected) + (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) + +(defun ert--results-update-ewoc-hf (ewoc stats) + "Update the header and footer of EWOC to show certain information from STATS. + +Also sets `ert--results-progress-bar-button-begin'." + (let ((run-count (ert-stats-completed stats)) + (results-buffer (current-buffer)) + ;; Need to save buffer-local value. + (font-lock font-lock-mode)) + (ewoc-set-hf + ewoc + ;; header + (with-temp-buffer + (insert "Selector: ") + (ert--insert-human-readable-selector (ert--stats-selector stats)) + (insert "\n") + (insert + (format (concat "Passed: %s\n" + "Failed: %s\n" + "Total: %s/%s\n\n") + (ert--results-format-expected-unexpected + (ert--stats-passed-expected stats) + (ert--stats-passed-unexpected stats)) + (ert--results-format-expected-unexpected + (ert--stats-failed-expected stats) + (ert--stats-failed-unexpected stats)) + run-count + (ert-stats-total stats))) + (insert + (format "Started at: %s\n" + (ert--format-time-iso8601 (ert--stats-start-time stats)))) + ;; FIXME: This is ugly. Need to properly define invariants of + ;; the `stats' data structure. + (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) + ((ert--stats-current-test stats) 'running) + ((ert--stats-end-time stats) 'finished) + (t 'preparing)))) + (ecase state + (preparing + (insert "")) + (aborted + (cond ((ert--stats-current-test stats) + (insert "Aborted during test: ") + (ert-insert-test-name-button + (ert-test-name (ert--stats-current-test stats)))) + (t + (insert "Aborted.")))) + (running + (assert (ert--stats-current-test stats)) + (insert "Running test: ") + (ert-insert-test-name-button (ert-test-name + (ert--stats-current-test stats)))) + (finished + (assert (not (ert--stats-current-test stats))) + (insert "Finished."))) + (insert "\n") + (if (ert--stats-end-time stats) + (insert + (format "%s%s\n" + (if (ert--stats-aborted-p stats) + "Aborted at: " + "Finished at: ") + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + (insert "\n")) + (insert "\n")) + (let ((progress-bar-string (with-current-buffer results-buffer + ert--results-progress-bar-string))) + (let ((progress-bar-button-begin + (insert-text-button progress-bar-string + :type 'ert--results-progress-bar-button + 'face (or (and font-lock + (ert-face-for-stats stats)) + 'button)))) + ;; The header gets copied verbatim to the results buffer, + ;; and all positions remain the same, so + ;; `progress-bar-button-begin' will be the right position + ;; even in the results buffer. + (with-current-buffer results-buffer + (set (make-local-variable 'ert--results-progress-bar-button-begin) + progress-bar-button-begin)))) + (insert "\n\n") + (buffer-string)) + ;; footer + ;; + ;; We actually want an empty footer, but that would trigger a bug + ;; in ewoc, sometimes clearing the entire buffer. (It's possible + ;; that this bug has been fixed since this has been tested; we + ;; should test it again.) + "\n"))) + + +(defvar ert-test-run-redisplay-interval-secs .1 + "How many seconds ERT should wait between redisplays while running tests. + +While running tests, ERT shows the current progress, and this variable +determines how frequently the progress display is updated.") + +(defun ert--results-update-stats-display (ewoc stats) + "Update EWOC and the mode line to show data from STATS." + ;; TODO(ohler): investigate using `make-progress-reporter'. + (ert--results-update-ewoc-hf ewoc stats) + (force-mode-line-update) + (redisplay t) + (setf (ert--stats-next-redisplay stats) + (+ (float-time) ert-test-run-redisplay-interval-secs))) + +(defun ert--results-update-stats-display-maybe (ewoc stats) + "Call `ert--results-update-stats-display' if not called recently. + +EWOC and STATS are arguments for `ert--results-update-stats-display'." + (when (>= (float-time) (ert--stats-next-redisplay stats)) + (ert--results-update-stats-display ewoc stats))) + +(defun ert--tests-running-mode-line-indicator () + "Return a string for the mode line that shows the test run progress." + (let* ((stats ert--current-run-stats) + (tests-total (ert-stats-total stats)) + (tests-completed (ert-stats-completed stats))) + (if (>= tests-completed tests-total) + (format " ERT(%s/%s,finished)" tests-completed tests-total) + (format " ERT(%s/%s):%s" + (1+ tests-completed) + tests-total + (if (null (ert--stats-current-test stats)) + "?" + (format "%S" + (ert-test-name (ert--stats-current-test stats)))))))) + +(defun ert--make-xrefs-region (begin end) + "Attach cross-references to function names between BEGIN and END. + +BEGIN and END specify a region in the current buffer." + (save-excursion + (save-restriction + (narrow-to-region begin (point)) + ;; Inhibit optimization in `debugger-make-xrefs' that would + ;; sometimes insert unrelated backtrace info into our buffer. + (let ((debugger-previous-backtrace nil)) + (debugger-make-xrefs))))) + +(defun ert--string-first-line (s) + "Return the first line of S, or S if it contains no newlines. + +The return value does not include the line terminator." + (substring s 0 (ert--string-position ?\n s))) + +(defun ert-face-for-test-result (expectedp) + "Return a face that shows whether a test result was expected or unexpected. + +If EXPECTEDP is nil, returns the face for unexpected results; if +non-nil, returns the face for expected results.." + (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) + +(defun ert-face-for-stats (stats) + "Return a face that represents STATS." + (cond ((ert--stats-aborted-p stats) 'nil) + ((plusp (ert-stats-completed-unexpected stats)) + (ert-face-for-test-result nil)) + ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) + (ert-face-for-test-result t)) + (t 'nil))) + +(defun ert--print-test-for-ewoc (entry) + "The ewoc print function for ewoc test entries. ENTRY is the entry to print." + (let* ((test (ert--ewoc-entry-test entry)) + (stats ert--results-stats) + (result (let ((pos (ert--stats-test-pos stats test))) + (assert pos) + (aref (ert--stats-test-results stats) pos))) + (hiddenp (ert--ewoc-entry-hidden-p entry)) + (expandedp (ert--ewoc-entry-expanded-p entry)) + (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p + entry))) + (cond (hiddenp) + (t + (let ((expectedp (ert-test-result-expected-p test result))) + (insert-text-button (format "%c" (ert-char-for-test-result + result expectedp)) + :type 'ert--results-expand-collapse-button + 'face (or (and font-lock-mode + (ert-face-for-test-result + expectedp)) + 'button))) + (insert " ") + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n") + (when (and expandedp (not (eql result 'nil))) + (when (ert-test-documentation test) + (insert " " + (propertize + (ert--string-first-line (ert-test-documentation test)) + 'font-lock-face 'font-lock-doc-face) + "\n")) + (etypecase result + (ert-test-passed + (if (ert-test-result-expected-p test result) + (insert " passed\n") + (insert " passed unexpectedly\n")) + (insert "")) + (ert-test-result-with-condition + (ert--insert-infos result) + (let ((print-escape-newlines t) + (print-level (if extended-printer-limits-p 12 6)) + (print-length (if extended-printer-limits-p 100 10))) + (insert " ") + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)) + (ert--make-xrefs-region begin (point))))) + (ert-test-aborted-with-non-local-exit + (insert " aborted\n"))) + (insert "\n"))))) + nil) + +(defun ert--results-font-lock-function (enabledp) + "Redraw the ERT results buffer after font-lock-mode was switched on or off. + +ENABLEDP is true if font-lock-mode is switched on, false +otherwise." + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (ewoc-refresh ert--results-ewoc) + (font-lock-default-function enabledp)) + +(defun ert--setup-results-buffer (stats listener buffer-name) + "Set up a test results buffer. + +STATS is the stats object; LISTENER is the results listener; +BUFFER-NAME, if non-nil, is the buffer name to use." + (unless buffer-name (setq buffer-name "*ert*")) + (let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-results-mode) + ;; Erase buffer again in case switching out of the previous + ;; mode inserted anything. (This happens e.g. when switching + ;; from ert-results-mode to ert-results-mode when + ;; font-lock-mode turns itself off in change-major-mode-hook.) + (erase-buffer) + (set (make-local-variable 'font-lock-function) + 'ert--results-font-lock-function) + (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) + (set (make-local-variable 'ert--results-ewoc) ewoc) + (set (make-local-variable 'ert--results-stats) stats) + (set (make-local-variable 'ert--results-progress-bar-string) + (make-string (ert-stats-total stats) + (ert-char-for-test-result nil t))) + (set (make-local-variable 'ert--results-listener) listener) + (loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test :hidden-p t))) + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (goto-char (1- (point-max))) + buffer))))) + + +(defvar ert--selector-history nil + "List of recent test selectors read from terminal.") + +;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? +;; They are needed only for our automated self-tests at the moment. +;; Or should there be some other mechanism? +;;;###autoload +(defun ert-run-tests-interactively (selector + &optional output-buffer-name message-fn) + "Run the tests specified by SELECTOR and display the results in a buffer. + +SELECTOR works as described in `ert-select-tests'. +OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they +are used for automated self-tests and specify which buffer to use +and how to display message." + (interactive + (list (let ((default (if ert--selector-history + ;; Can't use `first' here as this form is + ;; not compiled, and `first' is not + ;; defined without cl. + (car ert--selector-history) + "t"))) + (read-from-minibuffer (if (null default) + "Run tests: " + (format "Run tests (default %s): " default)) + nil nil t 'ert--selector-history + default nil)) + nil)) + (unless message-fn (setq message-fn 'message)) + (lexical-let ((output-buffer-name output-buffer-name) + buffer + listener + (message-fn message-fn)) + (setq listener + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (setq buffer (ert--setup-results-buffer stats + listener + output-buffer-name)) + (pop-to-buffer buffer))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (funcall message-fn + "%sRan %s tests, %s results were as expected%s" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (let ((unexpected + (ert-stats-completed-unexpected stats))) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)))) + (ert--results-update-stats-display (with-current-buffer buffer + ert--results-ewoc) + stats))) + (test-started + (destructuring-bind (stats test) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (assert node) + (setf (ert--ewoc-entry-test (ewoc-data node)) test) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result nil t)) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node))))) + (test-ended + (destructuring-bind (stats test result) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (when (ert--ewoc-entry-hidden-p (ewoc-data node)) + (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) + (ert-test-result-expected-p test result))) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result result + (ert-test-result-expected-p + test result))) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node)))))))) + (ert-run-tests + selector + listener))) +;;;###autoload +(defalias 'ert 'ert-run-tests-interactively) + + +;;; Simple view mode for auxiliary information like stack traces or +;;; messages. Mainly binds "q" for quit. + +(define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View" + "Major mode for viewing auxiliary information in ERT.") + +(loop for (key binding) in + '(("q" quit-window) + ) + do + (define-key ert-simple-view-mode-map key binding)) + + +;;; Commands and button actions for the results buffer. + +(define-derived-mode ert-results-mode fundamental-mode "ERT-Results" + "Major mode for viewing results of ERT test runs.") + +(loop for (key binding) in + '(;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("q" quit-window) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) + +(easy-menu-define ert-results-mode-menu ert-results-mode-map + "Menu for `ert-results-mode'." + '("ERT Results" + ["Re-run all tests" ert-results-rerun-all-tests] + "--" + ["Re-run test" ert-results-rerun-test-at-point] + ["Debug test" ert-results-rerun-test-at-point-debugging-errors] + ["Show test definition" ert-results-find-test-at-point-other-window] + "--" + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] + ["Show messages" ert-results-pop-to-messages-for-test-at-point] + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] + ["Describe test" ert-results-describe-test-at-point] + "--" + ["Delete test" ert-delete-test] + "--" + ["Show execution time of each test" ert-results-pop-to-timings] + )) + +(define-button-type 'ert--results-progress-bar-button + 'action #'ert--results-progress-bar-button-action + 'help-echo "mouse-2, RET: Reveal test result") + +(define-button-type 'ert--test-name-button + 'action #'ert--test-name-button-action + 'help-echo "mouse-2, RET: Find test definition") + +(define-button-type 'ert--results-expand-collapse-button + 'action #'ert--results-expand-collapse-button-action + 'help-echo "mouse-2, RET: Expand/collapse test result") + +(defun ert--results-test-node-or-null-at-point () + "If point is on a valid ewoc node, return it; return nil otherwise. + +To be used in the ERT results buffer." + (let* ((ewoc ert--results-ewoc) + (node (ewoc-locate ewoc))) + ;; `ewoc-locate' will return an arbitrary node when point is on + ;; header or footer, or when all nodes are invisible. So we need + ;; to validate its return value here. + ;; + ;; Update: I'm seeing nil being returned in some cases now, + ;; perhaps this has been changed? + (if (and node + (>= (point) (ewoc-location node)) + (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) + node + nil))) + +(defun ert--results-test-node-at-point () + "If point is on a valid ewoc node, return it; signal an error otherwise. + +To be used in the ERT results buffer." + (or (ert--results-test-node-or-null-at-point) + (error "No test at point"))) + +(defun ert-results-next-test () + "Move point to the next test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next + "No tests below")) + +(defun ert-results-previous-test () + "Move point to the previous test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev + "No tests above")) + +(defun ert--results-move (node ewoc-fn error-message) + "Move point from NODE to the previous or next node. + +EWOC-FN specifies the direction and should be either `ewoc-prev' +or `ewoc-next'. If there are no more nodes in that direction, an +error is signalled with the message ERROR-MESSAGE." + (loop + (setq node (funcall ewoc-fn ert--results-ewoc node)) + (when (null node) + (error "%s" error-message)) + (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) + (goto-char (ewoc-location node)) + (return)))) + +(defun ert--results-expand-collapse-button-action (button) + "Expand or collapse the test node BUTTON belongs to." + (let* ((ewoc ert--results-ewoc) + (node (save-excursion + (goto-char (ert--button-action-position)) + (ert--results-test-node-at-point))) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-expanded-p entry) + (not (ert--ewoc-entry-expanded-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-find-test-at-point-other-window () + "Find the definition of the test at point in another window. + +To be used in the ERT results buffer." + (interactive) + (let ((name (ert-test-at-point))) + (unless name + (error "No test at point")) + (ert-find-test-other-window name))) + +(defun ert--test-name-button-action (button) + "Find the definition of the test BUTTON belongs to, in another window." + (let ((name (button-get button 'ert-test-name))) + (ert-find-test-other-window name))) + +(defun ert--ewoc-position (ewoc node) + ;; checkdoc-order: nil + "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." + (loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (return i)) + finally (return nil))) + +(defun ert-results-jump-between-summary-and-result () + "Jump back and forth between the test run summary and individual test results. + +From an ewoc node, jumps to the character that represents the +same test in the progress bar, and vice versa. + +To be used in the ERT results buffer." + ;; Maybe this command isn't actually needed much, but if it is, it + ;; seems like an indication that the UI design is not optimal. If + ;; jumping back and forth between a summary at the top of the buffer + ;; and the error log in the remainder of the buffer is useful, then + ;; the summary apparently needs to be easily accessible from the + ;; error log, and perhaps it would be better to have it in a + ;; separate buffer to keep it visible. + (interactive) + (let ((ewoc ert--results-ewoc) + (progress-bar-begin ert--results-progress-bar-button-begin)) + (cond ((ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (pos (ert--ewoc-position ewoc node))) + (goto-char (+ progress-bar-begin pos)))) + ((and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) + (entry (ewoc-data node))) + (when (ert--ewoc-entry-hidden-p entry) + (setf (ert--ewoc-entry-hidden-p entry) nil) + (ewoc-invalidate ewoc node)) + (ewoc-goto-node ewoc node))) + (t + (goto-char progress-bar-begin))))) + +(defun ert-test-at-point () + "Return the name of the test at point as a symbol, or nil if none." + (or (and (eql major-mode 'ert-results-mode) + (let ((test (ert--results-test-at-point-no-redefinition))) + (and test (ert-test-name test)))) + (let* ((thing (thing-at-point 'symbol)) + (sym (intern-soft thing))) + (and (ert-test-boundp sym) + sym)))) + +(defun ert--results-test-at-point-no-redefinition () + "Return the test at point, or nil. + +To be used in the ERT results buffer." + (assert (eql major-mode 'ert-results-mode)) + (if (ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (test (ert--ewoc-entry-test (ewoc-data node)))) + test) + (let ((progress-bar-begin ert--results-progress-bar-button-begin)) + (when (and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((test-index (- (point) progress-bar-begin)) + (test (aref (ert--stats-tests ert--results-stats) + test-index))) + test))))) + +(defun ert--results-test-at-point-allow-redefinition () + "Look up the test at point, and check whether it has been redefined. + +To be used in the ERT results buffer. + +Returns a list of two elements: the test (or nil) and a symbol +specifying whether the test has been redefined. + +If a new test has been defined with the same name as the test at +point, replaces the test at point with the new test, and returns +the new test and the symbol `redefined'. + +If the test has been deleted, returns the old test and the symbol +`deleted'. + +If the test is still current, returns the test and the symbol nil. + +If there is no test at point, returns a list with two nils." + (let ((test (ert--results-test-at-point-no-redefinition))) + (cond ((null test) + `(nil nil)) + ((null (ert-test-name test)) + `(,test nil)) + (t + (let* ((name (ert-test-name test)) + (new-test (and (ert-test-boundp name) + (ert-get-test name)))) + (cond ((eql test new-test) + `(,test nil)) + ((null new-test) + `(,test deleted)) + (t + (ert--results-update-after-test-redefinition + (ert--stats-test-pos ert--results-stats test) + new-test) + `(,new-test redefined)))))))) + +(defun ert--results-update-after-test-redefinition (pos new-test) + "Update results buffer after the test at pos POS has been redefined. + +Also updates the stats object. NEW-TEST is the new test +definition." + (let* ((stats ert--results-stats) + (ewoc ert--results-ewoc) + (node (ewoc-nth ewoc pos)) + (entry (ewoc-data node))) + (ert--stats-set-test-and-result stats pos new-test nil) + (setf (ert--ewoc-entry-test entry) new-test + (aref ert--results-progress-bar-string pos) (ert-char-for-test-result + nil t)) + (ewoc-invalidate ewoc node)) + nil) + +(defun ert--button-action-position () + "The buffer position where the last button action was triggered." + (cond ((integerp last-command-event) + (point)) + ((eventp last-command-event) + (posn-point (event-start last-command-event))) + (t (assert nil)))) + +(defun ert--results-progress-bar-button-action (button) + "Jump to details for the test represented by the character clicked in BUTTON." + (goto-char (ert--button-action-position)) + (ert-results-jump-between-summary-and-result)) + +(defun ert-results-rerun-all-tests () + "Re-run all tests, using the same selector. + +To be used in the ERT results buffer." + (interactive) + (assert (eql major-mode 'ert-results-mode)) + (let ((selector (ert--stats-selector ert--results-stats))) + (ert-run-tests-interactively selector (buffer-name)))) + +(defun ert-results-rerun-test-at-point () + "Re-run the test at point. + +To be used in the ERT results buffer." + (interactive) + (destructuring-bind (test redefinition-state) + (ert--results-test-at-point-allow-redefinition) + (when (null test) + (error "No test at point")) + (let* ((stats ert--results-stats) + (progress-message (format "Running %stest %S" + (ecase redefinition-state + ((nil) "") + (redefined "new definition of ") + (deleted "deleted ")) + (ert-test-name test)))) + ;; Need to save and restore point manually here: When point is on + ;; the first visible ewoc entry while the header is updated, point + ;; moves to the top of the buffer. This is undesirable, and a + ;; simple `save-excursion' doesn't prevent it. + (let ((point (point))) + (unwind-protect + (unwind-protect + (progn + (message "%s..." progress-message) + (ert-run-or-rerun-test stats test + ert--results-listener)) + (ert--results-update-stats-display ert--results-ewoc stats) + (message "%s...%s" + progress-message + (let ((result (ert-test-most-recent-result test))) + (ert-string-for-test-result + result (ert-test-result-expected-p test result))))) + (goto-char point)))))) + +(defun ert-results-rerun-test-at-point-debugging-errors () + "Re-run the test at point with `ert-debug-on-error' bound to t. + +To be used in the ERT results buffer." + (interactive) + (let ((ert-debug-on-error t)) + (ert-results-rerun-test-at-point))) + +(defun ert-results-pop-to-backtrace-for-test-at-point () + "Display the backtrace for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (etypecase result + (ert-test-passed (error "Test passed, no backtrace available")) + (ert-test-result-with-condition + (let ((backtrace (ert-test-result-with-condition-backtrace result)) + (buffer (get-buffer-create "*ERT Backtrace*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + ;; Use unibyte because `debugger-setup-buffer' also does so. + (set-buffer-multibyte nil) + (setq truncate-lines t) + (ert--print-backtrace backtrace) + (debugger-make-xrefs) + (goto-char (point-min)) + (insert "Backtrace for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))))) + +(defun ert-results-pop-to-messages-for-test-at-point () + "Display the part of the *Messages* buffer generated during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT Messages*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (insert (ert-test-result-messages result)) + (goto-char (point-min)) + (insert "Messages for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))) + +(defun ert-results-pop-to-should-forms-for-test-at-point () + "Display the list of `should' forms executed during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT list of should forms*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null (ert-test-result-should-forms result)) + (insert "\n(No should forms during this test.)\n") + (loop for form-description in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) + (goto-char (point-min)) + (insert "`should' forms executed during test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n") + (insert "\n") + (insert (concat "(Values are shallow copies and may have " + "looked different during the test if they\n" + "have been modified destructively.)\n")) + (forward-line 1))))) + +(defun ert-results-toggle-printer-limits-for-test-at-point () + "Toggle how much of the condition to print for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((ewoc ert--results-ewoc) + (node (ert--results-test-node-at-point)) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-extended-printer-limits-p entry) + (not (ert--ewoc-entry-extended-printer-limits-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-pop-to-timings () + "Display test timings for the last run. + +To be used in the ERT results buffer." + (interactive) + (let* ((stats ert--results-stats) + (start-times (ert--stats-test-start-times stats)) + (end-times (ert--stats-test-end-times stats)) + (buffer (get-buffer-create "*ERT timings*")) + (data (loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (subtract-time end-time + start-time)))))) + (setq data (sort data (lambda (a b) + (> (second a) (second b))))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null data) + (insert "(No data)\n") + (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) + (loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (let ((begin (point))) + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) + (goto-char (point-min)) + (insert "Tests by run time (seconds):\n\n") + (forward-line 1)))) + +;;;###autoload +(defun ert-describe-test (test-or-test-name) + "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." + (interactive (list (ert-read-test-name-at-point "Describe test"))) + (when (< emacs-major-version 24) + (error "Requires Emacs 24")) + (let (test-name + test-definition) + (etypecase test-or-test-name + (symbol (setq test-name test-or-test-name + test-definition (ert-get-test test-or-test-name))) + (ert-test (setq test-name (ert-test-name test-or-test-name) + test-definition test-or-test-name))) + (help-setup-xref (list #'ert-describe-test test-or-test-name) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert (if test-name (format "%S" test-name) "")) + (insert " is a test") + (let ((file-name (and test-name + (symbol-file test-name 'ert-deftest)))) + (when file-name + (insert " defined in `" (file-name-nondirectory file-name) "'") + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-def test-name file-name))) + (insert ".") + (fill-region-as-paragraph (point-min) (point)) + (insert "\n\n") + (unless (and (ert-test-boundp test-name) + (eql (ert-get-test test-name) test-definition)) + (let ((begin (point))) + (insert "Note: This test has been redefined or deleted, " + "this documentation refers to an old definition.") + (fill-region-as-paragraph begin (point))) + (insert "\n\n")) + (insert (or (ert-test-documentation test-definition) + "It is not documented.") + "\n"))))))) + +(defun ert-results-describe-test-at-point () + "Display the documentation of the test at point. + +To be used in the ERT results buffer." + (interactive) + (ert-describe-test (ert--results-test-at-point-no-redefinition))) + + +;;; Actions on load/unload. + +(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) +(add-to-list 'minor-mode-alist '(ert--current-run-stats + (:eval + (ert--tests-running-mode-line-indicator)))) +(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) + +(defun ert--unload-function () + "Unload function to undo the side-effects of loading ert.el." + (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) + (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) + (ert--remove-from-list 'emacs-lisp-mode-hook + 'ert--activate-font-lock-keywords) + nil) + +(defvar ert-unload-hook '()) +(add-hook 'ert-unload-hook 'ert--unload-function) + + +(provide 'ert) + +;;; ert.el ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/ert.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/ert.el new file mode 100644 index 0000000..53b76f7 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/ert.el @@ -0,0 +1,2544 @@ +;;; ert.el --- Emacs Lisp Regression Testing + +;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc. + +;; Author: Christian M. Ohler +;; Keywords: lisp, tools + +;; This file is NOT part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; ERT is a tool for automated testing in Emacs Lisp. Its main +;; features are facilities for defining and running test cases and +;; reporting the results as well as for debugging test failures +;; interactively. +;; +;; The main entry points are `ert-deftest', which is similar to +;; `defun' but defines a test, and `ert-run-tests-interactively', +;; which runs tests and offers an interactive interface for inspecting +;; results and debugging. There is also +;; `ert-run-tests-batch-and-exit' for non-interactive use. +;; +;; The body of `ert-deftest' forms resembles a function body, but the +;; additional operators `should', `should-not' and `should-error' are +;; available. `should' is similar to cl's `assert', but signals a +;; different error when its condition is violated that is caught and +;; processed by ERT. In addition, it analyzes its argument form and +;; records information that helps debugging (`assert' tries to do +;; something similar when its second argument SHOW-ARGS is true, but +;; `should' is more sophisticated). For information on `should-not' +;; and `should-error', see their docstrings. +;; +;; See ERT's info manual as well as the docstrings for more details. +;; To compile the manual, run `makeinfo ert.texinfo' in the ERT +;; directory, then C-u M-x info ert.info in Emacs to view it. +;; +;; To see some examples of tests written in ERT, see its self-tests in +;; ert-tests.el. Some of these are tricky due to the bootstrapping +;; problem of writing tests for a testing tool, others test simple +;; functions and are straightforward. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'button) +(require 'debug) +(require 'easymenu) +(require 'ewoc) +(require 'find-func) +(require 'help) + + +;;; UI customization options. + +(defgroup ert () + "ERT, the Emacs Lisp regression testing tool." + :prefix "ert-" + :group 'lisp) + +(defface ert-test-result-expected '((((class color) (background light)) + :background "green1") + (((class color) (background dark)) + :background "green3")) + "Face used for expected results in the ERT results buffer." + :group 'ert) + +(defface ert-test-result-unexpected '((((class color) (background light)) + :background "red1") + (((class color) (background dark)) + :background "red3")) + "Face used for unexpected results in the ERT results buffer." + :group 'ert) + + +;;; Copies/reimplementations of cl functions. + +(defun ert--cl-do-remf (plist tag) + "Copy of `cl-do-remf'. Modify PLIST by removing TAG." + (let ((p (cdr plist))) + (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) + (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) + +(defun ert--remprop (sym tag) + "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." + (let ((plist (symbol-plist sym))) + (if (and plist (eq tag (car plist))) + (progn (setplist sym (cdr (cdr plist))) t) + (ert--cl-do-remf plist tag)))) + +(defun ert--remove-if-not (ert-pred ert-list) + "A reimplementation of `remove-if-not'. + +ERT-PRED is a predicate, ERT-LIST is the input list." + (loop for ert-x in ert-list + if (funcall ert-pred ert-x) + collect ert-x)) + +(defun ert--intersection (a b) + "A reimplementation of `intersection'. Intersect the sets A and B. + +Elements are compared using `eql'." + (loop for x in a + if (memql x b) + collect x)) + +(defun ert--set-difference (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eql'." + (loop for x in a + unless (memql x b) + collect x)) + +(defun ert--set-difference-eq (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eq'." + (loop for x in a + unless (memq x b) + collect x)) + +(defun ert--union (a b) + "A reimplementation of `union'. Compute the union of the sets A and B. + +Elements are compared using `eql'." + (append a (ert--set-difference b a))) + +(eval-and-compile + (defvar ert--gensym-counter 0)) + +(eval-and-compile + (defun ert--gensym (&optional prefix) + "Only allows string PREFIX, not compatible with CL." + (unless prefix (setq prefix "G")) + (make-symbol (format "%s%s" + prefix + (prog1 ert--gensym-counter + (incf ert--gensym-counter)))))) + +(defun ert--coerce-to-vector (x) + "Coerce X to a vector." + (when (char-table-p x) (error "Not supported")) + (if (vectorp x) + x + (vconcat x))) + +(defun* ert--remove* (x list &key key test) + "Does not support all the keywords of remove*." + (unless key (setq key #'identity)) + (unless test (setq test #'eql)) + (loop for y in list + unless (funcall test x (funcall key y)) + collect y)) + +(defun ert--string-position (c s) + "Return the position of the first occurrence of C in S, or nil if none." + (loop for i from 0 + for x across s + when (eql x c) return i)) + +(defun ert--mismatch (a b) + "Return index of first element that differs between A and B. + +Like `mismatch'. Uses `equal' for comparison." + (cond ((or (listp a) (listp b)) + (ert--mismatch (ert--coerce-to-vector a) + (ert--coerce-to-vector b))) + ((> (length a) (length b)) + (ert--mismatch b a)) + (t + (let ((la (length a)) + (lb (length b))) + (assert (arrayp a) t) + (assert (arrayp b) t) + (assert (<= la lb) t) + (loop for i below la + when (not (equal (aref a i) (aref b i))) return i + finally (return (if (/= la lb) + la + (assert (equal a b) t) + nil))))))) + +(defun ert--subseq (seq start &optional end) + "Return a subsequence of SEQ from START to END." + (when (char-table-p seq) (error "Not supported")) + (let ((vector (substring (ert--coerce-to-vector seq) start end))) + (etypecase seq + (vector vector) + (string (concat vector)) + (list (append vector nil)) + (bool-vector (loop with result = (make-bool-vector (length vector) nil) + for i below (length vector) do + (setf (aref result i) (aref vector i)) + finally (return result))) + (char-table (assert nil))))) + +(defun ert-equal-including-properties (a b) + "Return t if A and B have similar structure and contents. + +This is like `equal-including-properties' except that it compares +the property values of text properties structurally (by +recursing) rather than with `eq'. Perhaps this is what +`equal-including-properties' should do in the first place; see +Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." + ;; This implementation is inefficient. Rather than making it + ;; efficient, let's hope bug 6581 gets fixed so that we can delete + ;; it altogether. + (not (ert--explain-not-equal-including-properties a b))) + + +;;; Defining and locating tests. + +;; The data structure that represents a test case. +(defstruct ert-test + (name nil) + (documentation nil) + (body (assert nil)) + (most-recent-result nil) + (expected-result-type ':passed) + (tags '())) + +(defun ert-test-boundp (symbol) + "Return non-nil if SYMBOL names a test." + (and (get symbol 'ert--test) t)) + +(defun ert-get-test (symbol) + "If SYMBOL names a test, return that. Signal an error otherwise." + (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) + (get symbol 'ert--test)) + +(defun ert-set-test (symbol definition) + "Make SYMBOL name the test DEFINITION, and return DEFINITION." + (when (eq symbol 'nil) + ;; We disallow nil since `ert-test-at-point' and related functions + ;; want to return a test name, but also need an out-of-band value + ;; on failure. Nil is the most natural out-of-band value; using 0 + ;; or "" or signalling an error would be too awkward. + ;; + ;; Note that nil is still a valid value for the `name' slot in + ;; ert-test objects. It designates an anonymous test. + (error "Attempt to define a test named nil")) + (put symbol 'ert--test definition) + definition) + +(defun ert-make-test-unbound (symbol) + "Make SYMBOL name no test. Return SYMBOL." + (ert--remprop symbol 'ert--test) + symbol) + +(defun ert--parse-keys-and-body (keys-and-body) + "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. + +KEYS-AND-BODY should have the form of a property list, with the +exception that only keywords are permitted as keys and that the +tail -- the body -- is a list of forms that does not start with a +keyword. + +Returns a two-element list containing the keys-and-values plist +and the body." + (let ((extracted-key-accu '()) + (remaining keys-and-body)) + (while (and (consp remaining) (keywordp (first remaining))) + (let ((keyword (pop remaining))) + (unless (consp remaining) + (error "Value expected after keyword %S in %S" + keyword keys-and-body)) + (when (assoc keyword extracted-key-accu) + (warn "Keyword %S appears more than once in %S" keyword + keys-and-body)) + (push (cons keyword (pop remaining)) extracted-key-accu))) + (setq extracted-key-accu (nreverse extracted-key-accu)) + (list (loop for (key . value) in extracted-key-accu + collect key + collect value) + remaining))) + +;;;###autoload +(defmacro* ert-deftest (name () &body docstring-keys-and-body) + "Define NAME (a symbol) as a test. + +BODY is evaluated as a `progn' when the test is run. It should +signal a condition on failure or just return if the test passes. + +`should', `should-not' and `should-error' are useful for +assertions in BODY. + +Use `ert' to run tests interactively. + +Tests that are expected to fail can be marked as such +using :expected-result. See `ert-test-result-type-p' for a +description of valid values for RESULT-TYPE. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +\[:tags '(TAG...)] BODY...)" + (declare (debug (&define :name test + name sexp [&optional stringp] + [&rest keywordp sexp] def-body)) + (doc-string 3) + (indent 2)) + (let ((documentation nil) + (documentation-supplied-p nil)) + (when (stringp (first docstring-keys-and-body)) + (setq documentation (pop docstring-keys-and-body) + documentation-supplied-p t)) + (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) + (ert--parse-keys-and-body docstring-keys-and-body) + `(progn + (ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when expected-result-supplied-p + `(:expected-result-type ,expected-result)) + ,@(when tags-supplied-p + `(:tags ,tags)) + :body (lambda () ,@body))) + ;; This hack allows `symbol-file' to associate `ert-deftest' + ;; forms with files, and therefore enables `find-function' to + ;; work with tests. However, it leads to warnings in + ;; `unload-feature', which doesn't know how to undefine tests + ;; and has no mechanism for extension. + (push '(ert-deftest . ,name) current-load-list) + ',name)))) + +;; We use these `put' forms in addition to the (declare (indent)) in +;; the defmacro form since the `declare' alone does not lead to +;; correct indentation before the .el/.elc file is loaded. +;; Autoloading these `put' forms solves this. +;;;###autoload +(progn + ;; TODO(ohler): Figure out what these mean and make sure they are correct. + (put 'ert-deftest 'lisp-indent-function 2) + (put 'ert-info 'lisp-indent-function 1)) + +(defvar ert--find-test-regexp + (concat "^\\s-*(ert-deftest" + find-function-space-re + "%s\\(\\s-\\|$\\)") + "The regexp the `find-function' mechanisms use for finding test definitions.") + + +(put 'ert-test-failed 'error-conditions '(error ert-test-failed)) +(put 'ert-test-failed 'error-message "Test failed") + +(defun ert-pass () + "Terminate the current test and mark it passed. Does not return." + (throw 'ert--pass nil)) + +(defun ert-fail (data) + "Terminate the current test and mark it failed. Does not return. +DATA is displayed to the user and should state the reason of the failure." + (signal 'ert-test-failed (list data))) + + +;;; The `should' macros. + +(defvar ert--should-execution-observer nil) + +(defun ert--signal-should-execution (form-description) + "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." + (when ert--should-execution-observer + (funcall ert--should-execution-observer form-description))) + +(defun ert--special-operator-p (thing) + "Return non-nil if THING is a symbol naming a special operator." + (and (symbolp thing) + (let ((definition (indirect-function thing t))) + (and (subrp definition) + (eql (cdr (subr-arity definition)) 'unevalled))))) + +(defun ert--expand-should-1 (whole form inner-expander) + "Helper function for the `should' macro and its variants." + (let ((form + ;; If `cl-macroexpand' isn't bound, the code that we're + ;; compiling doesn't depend on cl and thus doesn't need an + ;; environment arg for `macroexpand'. + (if (fboundp 'cl-macroexpand) + ;; Suppress warning about run-time call to cl funtion: we + ;; only call it if it's fboundp. + (with-no-warnings + (cl-macroexpand form (and (boundp 'cl-macro-environment) + cl-macro-environment))) + (macroexpand form)))) + (cond + ((or (atom form) (ert--special-operator-p (car form))) + (let ((value (ert--gensym "value-"))) + `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) + ,(funcall inner-expander + `(setq ,value ,form) + `(list ',whole :form ',form :value ,value) + value) + ,value))) + (t + (let ((fn-name (car form)) + (arg-forms (cdr form))) + (assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) + (let ((fn (ert--gensym "fn-")) + (args (ert--gensym "args-")) + (value (ert--gensym "value-")) + (default-value (ert--gensym "ert-form-evaluation-aborted-"))) + `(let ((,fn (function ,fn-name)) + (,args (list ,@arg-forms))) + (let ((,value ',default-value)) + ,(funcall inner-expander + `(setq ,value (apply ,fn ,args)) + `(nconc (list ',whole) + (list :form `(,,fn ,@,args)) + (unless (eql ,value ',default-value) + (list :value ,value)) + (let ((-explainer- + (and (symbolp ',fn-name) + (get ',fn-name 'ert-explainer)))) + (when -explainer- + (list :explanation + (apply -explainer- ,args))))) + value) + ,value)))))))) + +(defun ert--expand-should (whole form inner-expander) + "Helper function for the `should' macro and its variants. + +Analyzes FORM and returns an expression that has the same +semantics under evaluation but records additional debugging +information. + +INNER-EXPANDER should be a function and is called with two +arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM +is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is +an expression that returns a description of FORM. INNER-EXPANDER +should return code that calls INNER-FORM and performs the checks +and error signalling specific to the particular variant of +`should'. The code that INNER-EXPANDER returns must not call +FORM-DESCRIPTION-FORM before it has called INNER-FORM." + (lexical-let ((inner-expander inner-expander)) + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (ert--gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var))))))) + +(defmacro* should (form) + "Evaluate FORM. If it returns nil, abort the current test as failed. + +Returns the value of FORM." + (ert--expand-should `(should ,form) form + (lambda (inner-form form-description-form value-var) + `(unless ,inner-form + (ert-fail ,form-description-form))))) + +(defmacro* should-not (form) + "Evaluate FORM. If it returns non-nil, abort the current test as failed. + +Returns nil." + (ert--expand-should `(should-not ,form) form + (lambda (inner-form form-description-form value-var) + `(unless (not ,inner-form) + (ert-fail ,form-description-form))))) + +(defun ert--should-error-handle-error (form-description-fn + condition type exclude-subtypes) + "Helper function for `should-error'. + +Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, +and aborts the current test as failed if it doesn't." + (let ((signalled-conditions (get (car condition) 'error-conditions)) + (handled-conditions (etypecase type + (list type) + (symbol (list type))))) + (assert signalled-conditions) + (unless (ert--intersection signalled-conditions handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled did not" + " have the expected type"))))) + (when exclude-subtypes + (unless (member (car condition) handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled was a subtype" + " of the expected type")))))))) + +;; FIXME: The expansion will evaluate the keyword args (if any) in +;; nonstandard order. +(defmacro* should-error (form &rest keys &key type exclude-subtypes) + "Evaluate FORM and check that it signals an error. + +The error signalled needs to match TYPE. TYPE should be a list +of condition names. (It can also be a non-nil symbol, which is +equivalent to a singleton list containing that symbol.) If +EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its +condition names is an element of TYPE. If EXCLUDE-SUBTYPES is +non-nil, the error matches TYPE if it is an element of TYPE. + +If the error matches, returns (ERROR-SYMBOL . DATA) from the +error. If not, or if no error was signalled, abort the test as +failed." + (unless type (setq type ''error)) + (ert--expand-should + `(should-error ,form ,@keys) + form + (lambda (inner-form form-description-form value-var) + (let ((errorp (ert--gensym "errorp")) + (form-description-fn (ert--gensym "form-description-fn-"))) + `(let ((,errorp nil) + (,form-description-fn (lambda () ,form-description-form))) + (condition-case -condition- + ,inner-form + ;; We can't use ,type here because we want to evaluate it. + (error + (setq ,errorp t) + (ert--should-error-handle-error ,form-description-fn + -condition- + ,type ,exclude-subtypes) + (setq ,value-var -condition-))) + (unless ,errorp + (ert-fail (append + (funcall ,form-description-fn) + (list + :fail-reason "did not signal an error"))))))))) + + +;;; Explanation of `should' failures. + +;; TODO(ohler): Rework explanations so that they are displayed in a +;; similar way to `ert-info' messages; in particular, allow text +;; buttons in explanations that give more detail or open an ediff +;; buffer. Perhaps explanations should be reported through `ert-info' +;; rather than as part of the condition. + +(defun ert--proper-list-p (x) + "Return non-nil if X is a proper list, nil otherwise." + (loop + for firstp = t then nil + for fast = x then (cddr fast) + for slow = x then (cdr slow) do + (when (null fast) (return t)) + (when (not (consp fast)) (return nil)) + (when (null (cdr fast)) (return t)) + (when (not (consp (cdr fast))) (return nil)) + (when (and (not firstp) (eq fast slow)) (return nil)))) + +(defun ert--explain-format-atom (x) + "Format the atom X for `ert--explain-not-equal'." + (typecase x + (fixnum (list x (format "#x%x" x) (format "?%c" x))) + (t x))) + +(defun ert--explain-not-equal (a b) + "Explainer function for `equal'. + +Returns a programmer-readable explanation of why A and B are not +`equal', or nil if they are." + (if (not (equal (type-of a) (type-of b))) + `(different-types ,a ,b) + (etypecase a + (cons + (let ((a-proper-p (ert--proper-list-p a)) + (b-proper-p (ert--proper-list-p b))) + (if (not (eql (not a-proper-p) (not b-proper-p))) + `(one-list-proper-one-improper ,a ,b) + (if a-proper-p + (if (not (equal (length a) (length b))) + `(proper-lists-of-different-length ,(length a) ,(length b) + ,a ,b + first-mismatch-at + ,(ert--mismatch a b)) + (loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-not-equal ai bi) + do (when xi (return `(list-elt ,i ,xi))) + finally (assert (equal a b) t))) + (let ((car-x (ert--explain-not-equal (car a) (car b)))) + (if car-x + `(car ,car-x) + (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b)))) + (if cdr-x + `(cdr ,cdr-x) + (assert (equal a b) t) + nil)))))))) + (array (if (not (equal (length a) (length b))) + `(arrays-of-different-length ,(length a) ,(length b) + ,a ,b + ,@(unless (char-table-p a) + `(first-mismatch-at + ,(ert--mismatch a b)))) + (loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-not-equal ai bi) + do (when xi (return `(array-elt ,i ,xi))) + finally (assert (equal a b) t)))) + (atom (if (not (equal a b)) + (if (and (symbolp a) (symbolp b) (string= a b)) + `(different-symbols-with-the-same-name ,a ,b) + `(different-atoms ,(ert--explain-format-atom a) + ,(ert--explain-format-atom b))) + nil))))) +(put 'equal 'ert-explainer 'ert--explain-not-equal) + +(defun ert--significant-plist-keys (plist) + "Return the keys of PLIST that have non-null values, in order." + (assert (zerop (mod (length plist) 2)) t) + (loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (return accu))) + +(defun ert--plist-difference-explanation (a b) + "Return a programmer-readable explanation of why A and B are different plists. + +Returns nil if they are equivalent, i.e., have the same value for +each key, where absent values are treated as nil. The order of +key/value pairs in each list does not matter." + (assert (zerop (mod (length a) 2)) t) + (assert (zerop (mod (length b) 2)) t) + ;; Normalizing the plists would be another way to do this but it + ;; requires a total ordering on all lisp objects (since any object + ;; is valid as a text property key). Perhaps defining such an + ;; ordering is useful in other contexts, too, but it's a lot of + ;; work, so let's punt on it for now. + (let* ((keys-a (ert--significant-plist-keys a)) + (keys-b (ert--significant-plist-keys b)) + (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) + (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) + (flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-not-equal-including-properties value-a + value-b))))) + (cond (keys-in-a-not-in-b + (explain-with-key (first keys-in-a-not-in-b))) + (keys-in-b-not-in-a + (explain-with-key (first keys-in-b-not-in-a))) + (t + (loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) + +(defun ert--abbreviate-string (s len suffixp) + "Shorten string S to at most LEN chars. + +If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." + (let ((n (length s))) + (cond ((< n len) + s) + (suffixp + (substring s (- n len))) + (t + (substring s 0 len))))) + +(defun ert--explain-not-equal-including-properties (a b) + "Explainer function for `ert-equal-including-properties'. + +Returns a programmer-readable explanation of why A and B are not +`ert-equal-including-properties', or nil if they are." + (if (not (equal a b)) + (ert--explain-not-equal a b) + (assert (stringp a) t) + (assert (stringp b) t) + (assert (eql (length a) (length b)) t) + (loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation props-a props-b) + do (when difference + (return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + ;; TODO(ohler): Get `equal-including-properties' fixed in + ;; Emacs, delete `ert-equal-including-properties', and + ;; re-enable this assertion. + ;;finally (assert (equal-including-properties a b) t) + ))) +(put 'ert-equal-including-properties + 'ert-explainer + 'ert--explain-not-equal-including-properties) + + +;;; Implementation of `ert-info'. + +;; TODO(ohler): The name `info' clashes with +;; `ert--test-execution-info'. One or both should be renamed. +(defvar ert--infos '() + "The stack of `ert-info' infos that currently apply. + +Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") + +(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) + "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. + +To be used within ERT tests. MESSAGE-FORM should evaluate to a +string that will be displayed together with the test result if +the test fails. PREFIX-FORM should evaluate to a string as well +and is displayed in front of the value of MESSAGE-FORM." + (declare (debug ((form &rest [sexp form]) body)) + (indent 1)) + `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) + ,@body)) + + + +;;; Facilities for running a single test. + +(defvar ert-debug-on-error nil + "Non-nil means enter debugger when a test fails or terminates with an error.") + +;; The data structures that represent the result of running a test. +(defstruct ert-test-result + (messages nil) + (should-forms nil) + ) +(defstruct (ert-test-passed (:include ert-test-result))) +(defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (assert nil)) + (backtrace (assert nil)) + (infos (assert nil))) +(defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) + + +(defun ert--record-backtrace () + "Record the current backtrace (as a list) and return it." + ;; Since the backtrace is stored in the result object, result + ;; objects must only be printed with appropriate limits + ;; (`print-level' and `print-length') in place. For interactive + ;; use, the cost of ensuring this possibly outweighs the advantage + ;; of storing the backtrace for + ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we + ;; already have `ert-results-rerun-test-debugging-errors-at-point'. + ;; For batch use, however, printing the backtrace may be useful. + (loop + ;; 6 is the number of frames our own debugger adds (when + ;; compiled; more when interpreted). FIXME: Need to describe a + ;; procedure for determining this constant. + for i from 6 + for frame = (backtrace-frame i) + while frame + collect frame)) + +(defun ert--print-backtrace (backtrace) + "Format the backtrace BACKTRACE to the current buffer." + ;; This is essentially a reimplementation of Fbacktrace + ;; (src/eval.c), but for a saved backtrace, not the current one. + (let ((print-escape-newlines t) + (print-level 8) + (print-length 50)) + (dolist (frame backtrace) + (ecase (first frame) + ((nil) + ;; Special operator. + (destructuring-bind (special-operator &rest arg-forms) + (cdr frame) + (insert + (format " %S\n" (list* special-operator arg-forms))))) + ((t) + ;; Function call. + (destructuring-bind (fn &rest args) (cdr frame) + (insert (format " %S(" fn)) + (loop for firstp = t then nil + for arg in args do + (unless firstp + (insert " ")) + (insert (format "%S" arg))) + (insert ")\n"))))))) + +;; A container for the state of the execution of a single test and +;; environment data needed during its execution. +(defstruct ert--test-execution-info + (test (assert nil)) + (result (assert nil)) + ;; A thunk that may be called when RESULT has been set to its final + ;; value and test execution should be terminated. Should not + ;; return. + (exit-continuation (assert nil)) + ;; The binding of `debugger' outside of the execution of the test. + next-debugger + ;; The binding of `ert-debug-on-error' that is in effect for the + ;; execution of the current test. We store it to avoid being + ;; affected by any new bindings the test itself may establish. (I + ;; don't remember whether this feature is important.) + ert-debug-on-error) + +(defun ert--run-test-debugger (info debugger-args) + "During a test run, `debugger' is bound to a closure that calls this function. + +This function records failures and errors and either terminates +the test silently or calls the interactive debugger, as +appropriate. + +INFO is the ert--test-execution-info corresponding to this test +run. DEBUGGER-ARGS are the arguments to `debugger'." + (destructuring-bind (first-debugger-arg &rest more-debugger-args) + debugger-args + (ecase first-debugger-arg + ((lambda debug t exit nil) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (error + (let* ((condition (first more-debugger-args)) + (type (case (car condition) + ((quit) 'quit) + (otherwise 'failed))) + (backtrace (ert--record-backtrace)) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; Work around Emacs' heuristic (in eval.c) for detecting + ;; errors in the debugger. + (incf num-nonmacro-input-events) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info))))))) + +(defun ert--run-test-internal (ert-test-execution-info) + "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. + +This mainly sets up debugger-related bindings." + (lexical-let ((info ert-test-execution-info)) + (setf (ert--test-execution-info-next-debugger info) debugger + (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((debugger (lambda (&rest debugger-args) + (ert--run-test-debugger info debugger-args))) + (debug-on-error t) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result info) (make-ert-test-passed))) + nil) + +(defun ert--force-message-log-buffer-truncation () + "Immediately truncate *Messages* buffer according to `message-log-max'. + +This can be useful after reducing the value of `message-log-max'." + (with-current-buffer (get-buffer-create "*Messages*") + ;; This is a reimplementation of this part of message_dolog() in xdisp.c: + ;; if (NATNUMP (Vmessage_log_max)) + ;; { + ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, + ;; -XFASTINT (Vmessage_log_max) - 1, 0); + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); + ;; } + (when (and (integerp message-log-max) (>= message-log-max 0)) + (let ((begin (point-min)) + (end (save-excursion + (goto-char (point-max)) + (forward-line (- message-log-max)) + (point)))) + (delete-region begin end))))) + +(defvar ert--running-tests nil + "List of tests that are currently in execution. + +This list is empty while no test is running, has one element +while a test is running, two elements while a test run from +inside a test is running, etc. The list is in order of nesting, +innermost test first. + +The elements are of type `ert-test'.") + +(defun ert-run-test (ert-test) + "Run ERT-TEST. + +Returns the result and stores it in ERT-TEST's `most-recent-result' slot." + (setf (ert-test-most-recent-result ert-test) nil) + (block error + (lexical-let ((begin-marker + (with-current-buffer (get-buffer-create "*Messages*") + (set-marker (make-marker) (point-max))))) + (unwind-protect + (lexical-let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (return-from error nil)))) + (should-form-accu (list))) + (unwind-protect + (let ((ert--should-execution-observer + (lambda (form-description) + (push form-description should-form-accu))) + (message-log-max t) + (ert--running-tests (cons ert-test ert--running-tests))) + (ert--run-test-internal info)) + (let ((result (ert--test-execution-info-result info))) + (setf (ert-test-result-messages result) + (with-current-buffer (get-buffer-create "*Messages*") + (buffer-substring begin-marker (point-max)))) + (ert--force-message-log-buffer-truncation) + (setq should-form-accu (nreverse should-form-accu)) + (setf (ert-test-result-should-forms result) + should-form-accu) + (setf (ert-test-most-recent-result ert-test) result)))) + (set-marker begin-marker nil)))) + (ert-test-most-recent-result ert-test)) + +(defun ert-running-test () + "Return the top-level test currently executing." + (car (last ert--running-tests))) + + +;;; Test selectors. + +(defun ert-test-result-type-p (result result-type) + "Return non-nil if RESULT matches type RESULT-TYPE. + +Valid result types: + +nil -- Never matches. +t -- Always matches. +:failed, :passed -- Matches corresponding results. +\(and TYPES...\) -- Matches if all TYPES match. +\(or TYPES...\) -- Matches if some TYPES match. +\(not TYPE\) -- Matches if TYPE does not match. +\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with + RESULT." + ;; It would be easy to add `member' and `eql' types etc., but I + ;; haven't bothered yet. + (etypecase result-type + ((member nil) nil) + ((member t) t) + ((member :failed) (ert-test-failed-p result)) + ((member :passed) (ert-test-passed-p result)) + (cons + (destructuring-bind (operator &rest operands) result-type + (ecase operator + (and + (case (length operands) + (0 t) + (t + (and (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(and ,@(rest operands))))))) + (or + (case (length operands) + (0 nil) + (t + (or (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(or ,@(rest operands))))))) + (not + (assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (first operands)))) + (satisfies + (assert (eql (length operands) 1)) + (funcall (first operands) result))))))) + +(defun ert-test-result-expected-p (test result) + "Return non-nil if TEST's expected result type matches RESULT." + (ert-test-result-type-p result (ert-test-expected-result-type test))) + +(defun ert-select-tests (selector universe) + "Return the tests that match SELECTOR. + +UNIVERSE specifies the set of tests to select from; it should be +a list of tests, or t, which refers to all tests named by symbols +in `obarray'. + +Returns the set of tests as a list. + +Valid selectors: + +nil -- Selects the empty set. +t -- Selects UNIVERSE. +:new -- Selects all tests that have not been run yet. +:failed, :passed -- Select tests according to their most recent result. +:expected, :unexpected -- Select tests according to their most recent result. +a string -- Selects all tests that have a name that matches the string, + a regexp. +a test -- Selects that test. +a symbol -- Selects the test that the symbol names, errors if none. +\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests. +\(eql TEST\) -- Selects TEST, a test or a symbol naming a test. +\(and SELECTORS...\) -- Selects the tests that match all SELECTORS. +\(or SELECTORS...\) -- Selects the tests that match any SELECTOR. +\(not SELECTOR\) -- Selects all tests that do not match SELECTOR. +\(tag TAG) -- Selects all tests that have TAG on their tags list. +\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE. + +Only selectors that require a superset of tests, such +as (satisfies ...), strings, :new, etc. make use of UNIVERSE. +Selectors that do not, such as \(member ...\), just return the +set implied by them without checking whether it is really +contained in UNIVERSE." + ;; This code needs to match the etypecase in + ;; `ert-insert-human-readable-selector'. + (etypecase selector + ((member nil) nil) + ((member t) (etypecase universe + (list universe) + ((member t) (ert-select-tests "" universe)))) + ((member :new) (ert-select-tests + `(satisfies ,(lambda (test) + (null (ert-test-most-recent-result test)))) + universe)) + ((member :failed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':failed))) + universe)) + ((member :passed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':passed))) + universe)) + ((member :expected) (ert-select-tests + `(satisfies + ,(lambda (test) + (ert-test-result-expected-p + test + (ert-test-most-recent-result test)))) + universe)) + ((member :unexpected) (ert-select-tests `(not :expected) universe)) + (string + (etypecase universe + ((member t) (mapcar #'ert-get-test + (apropos-internal selector #'ert-test-boundp))) + (list (ert--remove-if-not (lambda (test) + (and (ert-test-name test) + (string-match selector + (ert-test-name test)))) + universe)))) + (ert-test (list selector)) + (symbol + (assert (ert-test-boundp selector)) + (list (ert-get-test selector))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + (member + (mapcar (lambda (purported-test) + (etypecase purported-test + (symbol (assert (ert-test-boundp purported-test)) + (ert-get-test purported-test)) + (ert-test purported-test))) + operands)) + (eql + (assert (eql (length operands) 1)) + (ert-select-tests `(member ,@operands) universe)) + (and + ;; Do these definitions of AND, NOT and OR satisfy de + ;; Morgan's laws? Should they? + (case (length operands) + (0 (ert-select-tests 't universe)) + (t (ert-select-tests `(and ,@(rest operands)) + (ert-select-tests (first operands) + universe))))) + (not + (assert (eql (length operands) 1)) + (let ((all-tests (ert-select-tests 't universe))) + (ert--set-difference all-tests + (ert-select-tests (first operands) + all-tests)))) + (or + (case (length operands) + (0 (ert-select-tests 'nil universe)) + (t (ert--union (ert-select-tests (first operands) universe) + (ert-select-tests `(or ,@(rest operands)) + universe))))) + (tag + (assert (eql (length operands) 1)) + (let ((tag (first operands))) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe))) + (satisfies + (assert (eql (length operands) 1)) + (ert--remove-if-not (first operands) + (ert-select-tests 't universe)))))))) + +(defun ert--insert-human-readable-selector (selector) + "Insert a human-readable presentation of SELECTOR into the current buffer." + ;; This is needed to avoid printing the (huge) contents of the + ;; `backtrace' slot of the result objects in the + ;; `most-recent-result' slots of test case objects in (eql ...) or + ;; (member ...) selectors. + (labels ((rec (selector) + ;; This code needs to match the etypecase in `ert-select-tests'. + (etypecase selector + ((or (member nil t + :new :failed :passed + :expected :unexpected) + string + symbol) + selector) + (ert-test + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol ""))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + ((member eql and not or) + `(,operator ,@(mapcar #'rec operands))) + ((member tag satisfies) + selector))))))) + (insert (format "%S" (rec selector))))) + + +;;; Facilities for running a whole set of tests. + +;; The data structure that contains the set of tests being executed +;; during one particular test run, their results, the state of the +;; execution, and some statistics. +;; +;; The data about results and expected results of tests may seem +;; redundant here, since the test objects also carry such information. +;; However, the information in the test objects may be more recent, it +;; may correspond to a different test run. We need the information +;; that corresponds to this run in order to be able to update the +;; statistics correctly when a test is re-run interactively and has a +;; different result than before. +(defstruct ert--stats + (selector (assert nil)) + ;; The tests, in order. + (tests (assert nil) :type vector) + ;; A map of test names (or the test objects themselves for unnamed + ;; tests) to indices into the `tests' vector. + (test-map (assert nil) :type hash-table) + ;; The results of the tests during this run, in order. + (test-results (assert nil) :type vector) + ;; The start times of the tests, in order, as reported by + ;; `current-time'. + (test-start-times (assert nil) :type vector) + ;; The end times of the tests, in order, as reported by + ;; `current-time'. + (test-end-times (assert nil) :type vector) + (passed-expected 0) + (passed-unexpected 0) + (failed-expected 0) + (failed-unexpected 0) + (start-time nil) + (end-time nil) + (aborted-p nil) + (current-test nil) + ;; The time at or after which the next redisplay should occur, as a + ;; float. + (next-redisplay 0.0)) + +(defun ert-stats-completed-expected (stats) + "Return the number of tests in STATS that had expected results." + (+ (ert--stats-passed-expected stats) + (ert--stats-failed-expected stats))) + +(defun ert-stats-completed-unexpected (stats) + "Return the number of tests in STATS that had unexpected results." + (+ (ert--stats-passed-unexpected stats) + (ert--stats-failed-unexpected stats))) + +(defun ert-stats-completed (stats) + "Number of tests in STATS that have run so far." + (+ (ert-stats-completed-expected stats) + (ert-stats-completed-unexpected stats))) + +(defun ert-stats-total (stats) + "Number of tests in STATS, regardless of whether they have run yet." + (length (ert--stats-tests stats))) + +;; The stats object of the current run, dynamically bound. This is +;; used for the mode line progress indicator. +(defvar ert--current-run-stats nil) + +(defun ert--stats-test-key (test) + "Return the key used for TEST in the test map of ert--stats objects. + +Returns the name of TEST if it has one, or TEST itself otherwise." + (or (ert-test-name test) test)) + +(defun ert--stats-set-test-and-result (stats pos test result) + "Change STATS by replacing the test at position POS with TEST and RESULT. + +Also changes the counters in STATS to match." + (let* ((tests (ert--stats-tests stats)) + (results (ert--stats-test-results stats)) + (old-test (aref tests pos)) + (map (ert--stats-test-map stats))) + (flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-expected stats) d)) + (ert-test-failed (incf (ert--stats-failed-expected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit))))) + ;; Adjust counters to remove the result that is currently in stats. + (update -1) + ;; Put new test and result into stats. + (setf (aref tests pos) test + (aref results pos) result) + (remhash (ert--stats-test-key old-test) map) + (setf (gethash (ert--stats-test-key test) map) pos) + ;; Adjust counters to match new result. + (update +1) + nil))) + +(defun ert--make-stats (tests selector) + "Create a new `ert--stats' object for running TESTS. + +SELECTOR is the selector that was used to select TESTS." + (setq tests (ert--coerce-to-vector tests)) + (let ((map (make-hash-table :size (length tests)))) + (loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (assert (not (gethash key map))) + (setf (gethash key map) i)) + (make-ert--stats :selector selector + :tests tests + :test-map map + :test-results (make-vector (length tests) nil) + :test-start-times (make-vector (length tests) nil) + :test-end-times (make-vector (length tests) nil)))) + +(defun ert-run-or-rerun-test (stats test listener) + ;; checkdoc-order: nil + "Run the single test TEST and record the result using STATS and LISTENER." + (let ((ert--current-run-stats stats) + (pos (ert--stats-test-pos stats test))) + (ert--stats-set-test-and-result stats pos test nil) + ;; Call listener after setting/before resetting + ;; (ert--stats-current-test stats); the listener might refresh the + ;; mode line display, and if the value is not set yet/any more + ;; during this refresh, the mode line will flicker unnecessarily. + (setf (ert--stats-current-test stats) test) + (funcall listener 'test-started stats test) + (setf (ert-test-most-recent-result test) nil) + (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) + (unwind-protect + (ert-run-test test) + (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) + (let ((result (ert-test-most-recent-result test))) + (ert--stats-set-test-and-result stats pos test result) + (funcall listener 'test-ended stats test result)) + (setf (ert--stats-current-test stats) nil)))) + +(defun ert-run-tests (selector listener) + "Run the tests specified by SELECTOR, sending progress updates to LISTENER." + (let* ((tests (ert-select-tests selector t)) + (stats (ert--make-stats tests selector))) + (setf (ert--stats-start-time stats) (current-time)) + (funcall listener 'run-started stats) + (let ((abortedp t)) + (unwind-protect + (let ((ert--current-run-stats stats)) + (force-mode-line-update) + (unwind-protect + (progn + (loop for test in tests do + (ert-run-or-rerun-test stats test listener)) + (setq abortedp nil)) + (setf (ert--stats-aborted-p stats) abortedp) + (setf (ert--stats-end-time stats) (current-time)) + (funcall listener 'run-ended stats abortedp))) + (force-mode-line-update)) + stats))) + +(defun ert--stats-test-pos (stats test) + ;; checkdoc-order: nil + "Return the position (index) of TEST in the run represented by STATS." + (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) + + +;;; Formatting functions shared across UIs. + +(defun ert--format-time-iso8601 (time) + "Format TIME in the variant of ISO 8601 used for timestamps in ERT." + (format-time-string "%Y-%m-%d %T%z" time)) + +(defun ert-char-for-test-result (result expectedp) + "Return a character that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed ".P") + (ert-test-failed "fF") + (null "--") + (ert-test-aborted-with-non-local-exit "aA")))) + (elt s (if expectedp 0 1)))) + +(defun ert-string-for-test-result (result expectedp) + "Return a string that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed '("passed" "PASSED")) + (ert-test-failed '("failed" "FAILED")) + (null '("unknown" "UNKNOWN")) + (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))))) + (elt s (if expectedp 0 1)))) + +(defun ert--pp-with-indentation-and-newline (object) + "Pretty-print OBJECT, indenting it to the current column of point. +Ensures a final newline is inserted." + (let ((begin (point))) + (pp object (current-buffer)) + (unless (bolp) (insert "\n")) + (save-excursion + (goto-char begin) + (indent-sexp)))) + +(defun ert--insert-infos (result) + "Insert `ert-info' infos from RESULT into current buffer. + +RESULT must be an `ert-test-result-with-condition'." + (check-type result ert-test-result-with-condition) + (dolist (info (ert-test-result-with-condition-infos result)) + (destructuring-bind (prefix . message) info + (let ((begin (point)) + (indentation (make-string (+ (length prefix) 4) ?\s)) + (end nil)) + (unwind-protect + (progn + (insert message "\n") + (setq end (copy-marker (point))) + (goto-char begin) + (insert " " prefix) + (forward-line 1) + (while (< (point) end) + (insert indentation) + (forward-line 1))) + (when end (set-marker end nil))))))) + + +;;; Running tests in batch mode. + +(defvar ert-batch-backtrace-right-margin 70 + "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") + +;;;###autoload +(defun ert-run-tests-batch (&optional selector) + "Run the tests specified by SELECTOR, printing results to the terminal. + +SELECTOR works as described in `ert-select-tests', except if +SELECTOR is nil, in which case all tests rather than none will be +run; this makes the command line \"emacs -batch -l my-tests.el -f +ert-run-tests-batch-and-exit\" useful. + +Returns the stats object." + (unless selector (setq selector 't)) + (ert-run-tests + selector + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (message "Running %s tests (%s)" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats))))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (let ((unexpected (ert-stats-completed-unexpected stats)) + (expected-failures (ert--stats-failed-expected stats))) + (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)) + (ert--format-time-iso8601 (ert--stats-end-time stats)) + (if (zerop expected-failures) + "" + (format "\n%s expected failures" expected-failures))) + (unless (zerop unexpected) + (message "%s unexpected results:" unexpected) + (loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) + (message "%s" ""))))) + (test-started + ) + (test-ended + (destructuring-bind (stats test result) event-args + (unless (ert-test-result-expected-p test result) + (etypecase result + (ert-test-passed + (message "Test %S passed unexpectedly" (ert-test-name test))) + (ert-test-result-with-condition + (message "Test %S backtrace:" (ert-test-name test)) + (with-temp-buffer + (ert--print-backtrace (ert-test-result-with-condition-backtrace + result)) + (goto-char (point-min)) + (while (not (eobp)) + (let ((start (point)) + (end (progn (end-of-line) (point)))) + (setq end (min end + (+ start ert-batch-backtrace-right-margin))) + (message "%s" (buffer-substring-no-properties + start end))) + (forward-line 1))) + (with-temp-buffer + (ert--insert-infos result) + (insert " ") + (let ((print-escape-newlines t) + (print-level 5) + (print-length 10)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)))) + (goto-char (1- (point-max))) + (assert (looking-at "\n")) + (delete-char 1) + (message "Test %S condition:" (ert-test-name test)) + (message "%s" (buffer-string)))) + (ert-test-aborted-with-non-local-exit + (message "Test %S aborted with non-local exit" + (ert-test-name test))))) + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S"))) + (message format-string + (ert-string-for-test-result result + (ert-test-result-expected-p + test result)) + (1+ (ert--stats-test-pos stats test)) + (ert-test-name test))))))))) + +;;;###autoload +(defun ert-run-tests-batch-and-exit (&optional selector) + "Like `ert-run-tests-batch', but exits Emacs when done. + +The exit status will be 0 if all test results were as expected, 1 +on unexpected results, or 2 if the framework detected an error +outside of the tests (e.g. invalid SELECTOR or bug in the code +that runs the tests)." + (unwind-protect + (let ((stats (ert-run-tests-batch selector))) + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 2)))) + + +;;; Utility functions for load/unload actions. + +(defun ert--activate-font-lock-keywords () + "Activate font-lock keywords for some of ERT's symbols." + (font-lock-add-keywords + nil + '(("(\\(\\\\s *\\(\\sw+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t))))) + +(defun* ert--remove-from-list (list-var element &key key test) + "Remove ELEMENT from the value of LIST-VAR if present. + +This can be used as an inverse of `add-to-list'." + (unless key (setq key #'identity)) + (unless test (setq test #'equal)) + (setf (symbol-value list-var) + (ert--remove* element + (symbol-value list-var) + :key key + :test test))) + + +;;; Some basic interactive functions. + +(defun ert-read-test-name (prompt &optional default history + add-default-to-prompt) + "Read the name of a test and return it as a symbol. + +Prompt with PROMPT. If DEFAULT is a valid test name, use it as a +default. HISTORY is the history to use; see `completing-read'. +If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to +include the default, if any. + +Signals an error if no test name was read." + (etypecase default + (string (let ((symbol (intern-soft default))) + (unless (and symbol (ert-test-boundp symbol)) + (setq default nil)))) + (symbol (setq default + (if (ert-test-boundp default) + (symbol-name default) + nil))) + (ert-test (setq default (ert-test-name default)))) + (when add-default-to-prompt + (setq prompt (if (null default) + (format "%s: " prompt) + (format "%s (default %s): " prompt default)))) + (let ((input (completing-read prompt obarray #'ert-test-boundp + t nil history default nil))) + ;; completing-read returns an empty string if default was nil and + ;; the user just hit enter. + (let ((sym (intern-soft input))) + (if (ert-test-boundp sym) + sym + (error "Input does not name a test"))))) + +(defun ert-read-test-name-at-point (prompt) + "Read the name of a test and return it as a symbol. +As a default, use the symbol at point, or the test at point if in +the ERT results buffer. Prompt with PROMPT, augmented with the +default (if any)." + (ert-read-test-name prompt (ert-test-at-point) nil t)) + +(defun ert-find-test-other-window (test-name) + "Find, in another window, the definition of TEST-NAME." + (interactive (list (ert-read-test-name-at-point "Find test definition: "))) + (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) + +(defun ert-delete-test (test-name) + "Make the test TEST-NAME unbound. + +Nothing more than an interactive interface to `ert-make-test-unbound'." + (interactive (list (ert-read-test-name-at-point "Delete test"))) + (ert-make-test-unbound test-name)) + +(defun ert-delete-all-tests () + "Make all symbols in `obarray' name no test." + (interactive) + (when (interactive-p) + (unless (y-or-n-p "Delete all tests? ") + (error "Aborted"))) + ;; We can't use `ert-select-tests' here since that gives us only + ;; test objects, and going from them back to the test name symbols + ;; can fail if the `ert-test' defstruct has been redefined. + (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) + t) + + +;;; Display of test progress and results. + +;; An entry in the results buffer ewoc. There is one entry per test. +(defstruct ert--ewoc-entry + (test (assert nil)) + ;; If the result of this test was expected, its ewoc entry is hidden + ;; initially. + (hidden-p (assert nil)) + ;; An ewoc entry may be collapsed to hide details such as the error + ;; condition. + ;; + ;; I'm not sure the ability to expand and collapse entries is still + ;; a useful feature. + (expanded-p t) + ;; By default, the ewoc entry presents the error condition with + ;; certain limits on how much to print (`print-level', + ;; `print-length'). The user can interactively switch to a set of + ;; higher limits. + (extended-printer-limits-p nil)) + +;; Variables local to the results buffer. + +;; The ewoc. +(defvar ert--results-ewoc) +;; The stats object. +(defvar ert--results-stats) +;; A string with one character per test. Each character represents +;; the result of the corresponding test. The string is displayed near +;; the top of the buffer and serves as a progress bar. +(defvar ert--results-progress-bar-string) +;; The position where the progress bar button begins. +(defvar ert--results-progress-bar-button-begin) +;; The test result listener that updates the buffer when tests are run. +(defvar ert--results-listener) + +(defun ert-insert-test-name-button (test-name) + "Insert a button that links to TEST-NAME." + (insert-text-button (format "%S" test-name) + :type 'ert--test-name-button + 'ert-test-name test-name)) + +(defun ert--results-format-expected-unexpected (expected unexpected) + "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." + (if (zerop unexpected) + (format "%s" expected) + (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) + +(defun ert--results-update-ewoc-hf (ewoc stats) + "Update the header and footer of EWOC to show certain information from STATS. + +Also sets `ert--results-progress-bar-button-begin'." + (let ((run-count (ert-stats-completed stats)) + (results-buffer (current-buffer)) + ;; Need to save buffer-local value. + (font-lock font-lock-mode)) + (ewoc-set-hf + ewoc + ;; header + (with-temp-buffer + (insert "Selector: ") + (ert--insert-human-readable-selector (ert--stats-selector stats)) + (insert "\n") + (insert + (format (concat "Passed: %s\n" + "Failed: %s\n" + "Total: %s/%s\n\n") + (ert--results-format-expected-unexpected + (ert--stats-passed-expected stats) + (ert--stats-passed-unexpected stats)) + (ert--results-format-expected-unexpected + (ert--stats-failed-expected stats) + (ert--stats-failed-unexpected stats)) + run-count + (ert-stats-total stats))) + (insert + (format "Started at: %s\n" + (ert--format-time-iso8601 (ert--stats-start-time stats)))) + ;; FIXME: This is ugly. Need to properly define invariants of + ;; the `stats' data structure. + (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) + ((ert--stats-current-test stats) 'running) + ((ert--stats-end-time stats) 'finished) + (t 'preparing)))) + (ecase state + (preparing + (insert "")) + (aborted + (cond ((ert--stats-current-test stats) + (insert "Aborted during test: ") + (ert-insert-test-name-button + (ert-test-name (ert--stats-current-test stats)))) + (t + (insert "Aborted.")))) + (running + (assert (ert--stats-current-test stats)) + (insert "Running test: ") + (ert-insert-test-name-button (ert-test-name + (ert--stats-current-test stats)))) + (finished + (assert (not (ert--stats-current-test stats))) + (insert "Finished."))) + (insert "\n") + (if (ert--stats-end-time stats) + (insert + (format "%s%s\n" + (if (ert--stats-aborted-p stats) + "Aborted at: " + "Finished at: ") + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + (insert "\n")) + (insert "\n")) + (let ((progress-bar-string (with-current-buffer results-buffer + ert--results-progress-bar-string))) + (let ((progress-bar-button-begin + (insert-text-button progress-bar-string + :type 'ert--results-progress-bar-button + 'face (or (and font-lock + (ert-face-for-stats stats)) + 'button)))) + ;; The header gets copied verbatim to the results buffer, + ;; and all positions remain the same, so + ;; `progress-bar-button-begin' will be the right position + ;; even in the results buffer. + (with-current-buffer results-buffer + (set (make-local-variable 'ert--results-progress-bar-button-begin) + progress-bar-button-begin)))) + (insert "\n\n") + (buffer-string)) + ;; footer + ;; + ;; We actually want an empty footer, but that would trigger a bug + ;; in ewoc, sometimes clearing the entire buffer. (It's possible + ;; that this bug has been fixed since this has been tested; we + ;; should test it again.) + "\n"))) + + +(defvar ert-test-run-redisplay-interval-secs .1 + "How many seconds ERT should wait between redisplays while running tests. + +While running tests, ERT shows the current progress, and this variable +determines how frequently the progress display is updated.") + +(defun ert--results-update-stats-display (ewoc stats) + "Update EWOC and the mode line to show data from STATS." + ;; TODO(ohler): investigate using `make-progress-reporter'. + (ert--results-update-ewoc-hf ewoc stats) + (force-mode-line-update) + (redisplay t) + (setf (ert--stats-next-redisplay stats) + (+ (float-time) ert-test-run-redisplay-interval-secs))) + +(defun ert--results-update-stats-display-maybe (ewoc stats) + "Call `ert--results-update-stats-display' if not called recently. + +EWOC and STATS are arguments for `ert--results-update-stats-display'." + (when (>= (float-time) (ert--stats-next-redisplay stats)) + (ert--results-update-stats-display ewoc stats))) + +(defun ert--tests-running-mode-line-indicator () + "Return a string for the mode line that shows the test run progress." + (let* ((stats ert--current-run-stats) + (tests-total (ert-stats-total stats)) + (tests-completed (ert-stats-completed stats))) + (if (>= tests-completed tests-total) + (format " ERT(%s/%s,finished)" tests-completed tests-total) + (format " ERT(%s/%s):%s" + (1+ tests-completed) + tests-total + (if (null (ert--stats-current-test stats)) + "?" + (format "%S" + (ert-test-name (ert--stats-current-test stats)))))))) + +(defun ert--make-xrefs-region (begin end) + "Attach cross-references to function names between BEGIN and END. + +BEGIN and END specify a region in the current buffer." + (save-excursion + (save-restriction + (narrow-to-region begin (point)) + ;; Inhibit optimization in `debugger-make-xrefs' that would + ;; sometimes insert unrelated backtrace info into our buffer. + (let ((debugger-previous-backtrace nil)) + (debugger-make-xrefs))))) + +(defun ert--string-first-line (s) + "Return the first line of S, or S if it contains no newlines. + +The return value does not include the line terminator." + (substring s 0 (ert--string-position ?\n s))) + +(defun ert-face-for-test-result (expectedp) + "Return a face that shows whether a test result was expected or unexpected. + +If EXPECTEDP is nil, returns the face for unexpected results; if +non-nil, returns the face for expected results.." + (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) + +(defun ert-face-for-stats (stats) + "Return a face that represents STATS." + (cond ((ert--stats-aborted-p stats) 'nil) + ((plusp (ert-stats-completed-unexpected stats)) + (ert-face-for-test-result nil)) + ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) + (ert-face-for-test-result t)) + (t 'nil))) + +(defun ert--print-test-for-ewoc (entry) + "The ewoc print function for ewoc test entries. ENTRY is the entry to print." + (let* ((test (ert--ewoc-entry-test entry)) + (stats ert--results-stats) + (result (let ((pos (ert--stats-test-pos stats test))) + (assert pos) + (aref (ert--stats-test-results stats) pos))) + (hiddenp (ert--ewoc-entry-hidden-p entry)) + (expandedp (ert--ewoc-entry-expanded-p entry)) + (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p + entry))) + (cond (hiddenp) + (t + (let ((expectedp (ert-test-result-expected-p test result))) + (insert-text-button (format "%c" (ert-char-for-test-result + result expectedp)) + :type 'ert--results-expand-collapse-button + 'face (or (and font-lock-mode + (ert-face-for-test-result + expectedp)) + 'button))) + (insert " ") + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n") + (when (and expandedp (not (eql result 'nil))) + (when (ert-test-documentation test) + (insert " " + (propertize + (ert--string-first-line (ert-test-documentation test)) + 'font-lock-face 'font-lock-doc-face) + "\n")) + (etypecase result + (ert-test-passed + (if (ert-test-result-expected-p test result) + (insert " passed\n") + (insert " passed unexpectedly\n")) + (insert "")) + (ert-test-result-with-condition + (ert--insert-infos result) + (let ((print-escape-newlines t) + (print-level (if extended-printer-limits-p 12 6)) + (print-length (if extended-printer-limits-p 100 10))) + (insert " ") + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)) + (ert--make-xrefs-region begin (point))))) + (ert-test-aborted-with-non-local-exit + (insert " aborted\n"))) + (insert "\n"))))) + nil) + +(defun ert--results-font-lock-function (enabledp) + "Redraw the ERT results buffer after font-lock-mode was switched on or off. + +ENABLEDP is true if font-lock-mode is switched on, false +otherwise." + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (ewoc-refresh ert--results-ewoc) + (font-lock-default-function enabledp)) + +(defun ert--setup-results-buffer (stats listener buffer-name) + "Set up a test results buffer. + +STATS is the stats object; LISTENER is the results listener; +BUFFER-NAME, if non-nil, is the buffer name to use." + (unless buffer-name (setq buffer-name "*ert*")) + (let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-results-mode) + ;; Erase buffer again in case switching out of the previous + ;; mode inserted anything. (This happens e.g. when switching + ;; from ert-results-mode to ert-results-mode when + ;; font-lock-mode turns itself off in change-major-mode-hook.) + (erase-buffer) + (set (make-local-variable 'font-lock-function) + 'ert--results-font-lock-function) + (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) + (set (make-local-variable 'ert--results-ewoc) ewoc) + (set (make-local-variable 'ert--results-stats) stats) + (set (make-local-variable 'ert--results-progress-bar-string) + (make-string (ert-stats-total stats) + (ert-char-for-test-result nil t))) + (set (make-local-variable 'ert--results-listener) listener) + (loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test :hidden-p t))) + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (goto-char (1- (point-max))) + buffer))))) + + +(defvar ert--selector-history nil + "List of recent test selectors read from terminal.") + +;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? +;; They are needed only for our automated self-tests at the moment. +;; Or should there be some other mechanism? +;;;###autoload +(defun ert-run-tests-interactively (selector + &optional output-buffer-name message-fn) + "Run the tests specified by SELECTOR and display the results in a buffer. + +SELECTOR works as described in `ert-select-tests'. +OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they +are used for automated self-tests and specify which buffer to use +and how to display message." + (interactive + (list (let ((default (if ert--selector-history + ;; Can't use `first' here as this form is + ;; not compiled, and `first' is not + ;; defined without cl. + (car ert--selector-history) + "t"))) + (read-from-minibuffer (if (null default) + "Run tests: " + (format "Run tests (default %s): " default)) + nil nil t 'ert--selector-history + default nil)) + nil)) + (unless message-fn (setq message-fn 'message)) + (lexical-let ((output-buffer-name output-buffer-name) + buffer + listener + (message-fn message-fn)) + (setq listener + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (setq buffer (ert--setup-results-buffer stats + listener + output-buffer-name)) + (pop-to-buffer buffer))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (funcall message-fn + "%sRan %s tests, %s results were as expected%s" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (let ((unexpected + (ert-stats-completed-unexpected stats))) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)))) + (ert--results-update-stats-display (with-current-buffer buffer + ert--results-ewoc) + stats))) + (test-started + (destructuring-bind (stats test) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (assert node) + (setf (ert--ewoc-entry-test (ewoc-data node)) test) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result nil t)) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node))))) + (test-ended + (destructuring-bind (stats test result) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (when (ert--ewoc-entry-hidden-p (ewoc-data node)) + (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) + (ert-test-result-expected-p test result))) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result result + (ert-test-result-expected-p + test result))) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node)))))))) + (ert-run-tests + selector + listener))) +;;;###autoload +(defalias 'ert 'ert-run-tests-interactively) + + +;;; Simple view mode for auxiliary information like stack traces or +;;; messages. Mainly binds "q" for quit. + +(define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View" + "Major mode for viewing auxiliary information in ERT.") + +(loop for (key binding) in + '(("q" quit-window) + ) + do + (define-key ert-simple-view-mode-map key binding)) + + +;;; Commands and button actions for the results buffer. + +(define-derived-mode ert-results-mode fundamental-mode "ERT-Results" + "Major mode for viewing results of ERT test runs.") + +(loop for (key binding) in + '(;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("q" quit-window) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) + +(easy-menu-define ert-results-mode-menu ert-results-mode-map + "Menu for `ert-results-mode'." + '("ERT Results" + ["Re-run all tests" ert-results-rerun-all-tests] + "--" + ["Re-run test" ert-results-rerun-test-at-point] + ["Debug test" ert-results-rerun-test-at-point-debugging-errors] + ["Show test definition" ert-results-find-test-at-point-other-window] + "--" + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] + ["Show messages" ert-results-pop-to-messages-for-test-at-point] + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] + ["Describe test" ert-results-describe-test-at-point] + "--" + ["Delete test" ert-delete-test] + "--" + ["Show execution time of each test" ert-results-pop-to-timings] + )) + +(define-button-type 'ert--results-progress-bar-button + 'action #'ert--results-progress-bar-button-action + 'help-echo "mouse-2, RET: Reveal test result") + +(define-button-type 'ert--test-name-button + 'action #'ert--test-name-button-action + 'help-echo "mouse-2, RET: Find test definition") + +(define-button-type 'ert--results-expand-collapse-button + 'action #'ert--results-expand-collapse-button-action + 'help-echo "mouse-2, RET: Expand/collapse test result") + +(defun ert--results-test-node-or-null-at-point () + "If point is on a valid ewoc node, return it; return nil otherwise. + +To be used in the ERT results buffer." + (let* ((ewoc ert--results-ewoc) + (node (ewoc-locate ewoc))) + ;; `ewoc-locate' will return an arbitrary node when point is on + ;; header or footer, or when all nodes are invisible. So we need + ;; to validate its return value here. + ;; + ;; Update: I'm seeing nil being returned in some cases now, + ;; perhaps this has been changed? + (if (and node + (>= (point) (ewoc-location node)) + (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) + node + nil))) + +(defun ert--results-test-node-at-point () + "If point is on a valid ewoc node, return it; signal an error otherwise. + +To be used in the ERT results buffer." + (or (ert--results-test-node-or-null-at-point) + (error "No test at point"))) + +(defun ert-results-next-test () + "Move point to the next test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next + "No tests below")) + +(defun ert-results-previous-test () + "Move point to the previous test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev + "No tests above")) + +(defun ert--results-move (node ewoc-fn error-message) + "Move point from NODE to the previous or next node. + +EWOC-FN specifies the direction and should be either `ewoc-prev' +or `ewoc-next'. If there are no more nodes in that direction, an +error is signalled with the message ERROR-MESSAGE." + (loop + (setq node (funcall ewoc-fn ert--results-ewoc node)) + (when (null node) + (error "%s" error-message)) + (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) + (goto-char (ewoc-location node)) + (return)))) + +(defun ert--results-expand-collapse-button-action (button) + "Expand or collapse the test node BUTTON belongs to." + (let* ((ewoc ert--results-ewoc) + (node (save-excursion + (goto-char (ert--button-action-position)) + (ert--results-test-node-at-point))) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-expanded-p entry) + (not (ert--ewoc-entry-expanded-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-find-test-at-point-other-window () + "Find the definition of the test at point in another window. + +To be used in the ERT results buffer." + (interactive) + (let ((name (ert-test-at-point))) + (unless name + (error "No test at point")) + (ert-find-test-other-window name))) + +(defun ert--test-name-button-action (button) + "Find the definition of the test BUTTON belongs to, in another window." + (let ((name (button-get button 'ert-test-name))) + (ert-find-test-other-window name))) + +(defun ert--ewoc-position (ewoc node) + ;; checkdoc-order: nil + "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." + (loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (return i)) + finally (return nil))) + +(defun ert-results-jump-between-summary-and-result () + "Jump back and forth between the test run summary and individual test results. + +From an ewoc node, jumps to the character that represents the +same test in the progress bar, and vice versa. + +To be used in the ERT results buffer." + ;; Maybe this command isn't actually needed much, but if it is, it + ;; seems like an indication that the UI design is not optimal. If + ;; jumping back and forth between a summary at the top of the buffer + ;; and the error log in the remainder of the buffer is useful, then + ;; the summary apparently needs to be easily accessible from the + ;; error log, and perhaps it would be better to have it in a + ;; separate buffer to keep it visible. + (interactive) + (let ((ewoc ert--results-ewoc) + (progress-bar-begin ert--results-progress-bar-button-begin)) + (cond ((ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (pos (ert--ewoc-position ewoc node))) + (goto-char (+ progress-bar-begin pos)))) + ((and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) + (entry (ewoc-data node))) + (when (ert--ewoc-entry-hidden-p entry) + (setf (ert--ewoc-entry-hidden-p entry) nil) + (ewoc-invalidate ewoc node)) + (ewoc-goto-node ewoc node))) + (t + (goto-char progress-bar-begin))))) + +(defun ert-test-at-point () + "Return the name of the test at point as a symbol, or nil if none." + (or (and (eql major-mode 'ert-results-mode) + (let ((test (ert--results-test-at-point-no-redefinition))) + (and test (ert-test-name test)))) + (let* ((thing (thing-at-point 'symbol)) + (sym (intern-soft thing))) + (and (ert-test-boundp sym) + sym)))) + +(defun ert--results-test-at-point-no-redefinition () + "Return the test at point, or nil. + +To be used in the ERT results buffer." + (assert (eql major-mode 'ert-results-mode)) + (if (ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (test (ert--ewoc-entry-test (ewoc-data node)))) + test) + (let ((progress-bar-begin ert--results-progress-bar-button-begin)) + (when (and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((test-index (- (point) progress-bar-begin)) + (test (aref (ert--stats-tests ert--results-stats) + test-index))) + test))))) + +(defun ert--results-test-at-point-allow-redefinition () + "Look up the test at point, and check whether it has been redefined. + +To be used in the ERT results buffer. + +Returns a list of two elements: the test (or nil) and a symbol +specifying whether the test has been redefined. + +If a new test has been defined with the same name as the test at +point, replaces the test at point with the new test, and returns +the new test and the symbol `redefined'. + +If the test has been deleted, returns the old test and the symbol +`deleted'. + +If the test is still current, returns the test and the symbol nil. + +If there is no test at point, returns a list with two nils." + (let ((test (ert--results-test-at-point-no-redefinition))) + (cond ((null test) + `(nil nil)) + ((null (ert-test-name test)) + `(,test nil)) + (t + (let* ((name (ert-test-name test)) + (new-test (and (ert-test-boundp name) + (ert-get-test name)))) + (cond ((eql test new-test) + `(,test nil)) + ((null new-test) + `(,test deleted)) + (t + (ert--results-update-after-test-redefinition + (ert--stats-test-pos ert--results-stats test) + new-test) + `(,new-test redefined)))))))) + +(defun ert--results-update-after-test-redefinition (pos new-test) + "Update results buffer after the test at pos POS has been redefined. + +Also updates the stats object. NEW-TEST is the new test +definition." + (let* ((stats ert--results-stats) + (ewoc ert--results-ewoc) + (node (ewoc-nth ewoc pos)) + (entry (ewoc-data node))) + (ert--stats-set-test-and-result stats pos new-test nil) + (setf (ert--ewoc-entry-test entry) new-test + (aref ert--results-progress-bar-string pos) (ert-char-for-test-result + nil t)) + (ewoc-invalidate ewoc node)) + nil) + +(defun ert--button-action-position () + "The buffer position where the last button action was triggered." + (cond ((integerp last-command-event) + (point)) + ((eventp last-command-event) + (posn-point (event-start last-command-event))) + (t (assert nil)))) + +(defun ert--results-progress-bar-button-action (button) + "Jump to details for the test represented by the character clicked in BUTTON." + (goto-char (ert--button-action-position)) + (ert-results-jump-between-summary-and-result)) + +(defun ert-results-rerun-all-tests () + "Re-run all tests, using the same selector. + +To be used in the ERT results buffer." + (interactive) + (assert (eql major-mode 'ert-results-mode)) + (let ((selector (ert--stats-selector ert--results-stats))) + (ert-run-tests-interactively selector (buffer-name)))) + +(defun ert-results-rerun-test-at-point () + "Re-run the test at point. + +To be used in the ERT results buffer." + (interactive) + (destructuring-bind (test redefinition-state) + (ert--results-test-at-point-allow-redefinition) + (when (null test) + (error "No test at point")) + (let* ((stats ert--results-stats) + (progress-message (format "Running %stest %S" + (ecase redefinition-state + ((nil) "") + (redefined "new definition of ") + (deleted "deleted ")) + (ert-test-name test)))) + ;; Need to save and restore point manually here: When point is on + ;; the first visible ewoc entry while the header is updated, point + ;; moves to the top of the buffer. This is undesirable, and a + ;; simple `save-excursion' doesn't prevent it. + (let ((point (point))) + (unwind-protect + (unwind-protect + (progn + (message "%s..." progress-message) + (ert-run-or-rerun-test stats test + ert--results-listener)) + (ert--results-update-stats-display ert--results-ewoc stats) + (message "%s...%s" + progress-message + (let ((result (ert-test-most-recent-result test))) + (ert-string-for-test-result + result (ert-test-result-expected-p test result))))) + (goto-char point)))))) + +(defun ert-results-rerun-test-at-point-debugging-errors () + "Re-run the test at point with `ert-debug-on-error' bound to t. + +To be used in the ERT results buffer." + (interactive) + (let ((ert-debug-on-error t)) + (ert-results-rerun-test-at-point))) + +(defun ert-results-pop-to-backtrace-for-test-at-point () + "Display the backtrace for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (etypecase result + (ert-test-passed (error "Test passed, no backtrace available")) + (ert-test-result-with-condition + (let ((backtrace (ert-test-result-with-condition-backtrace result)) + (buffer (get-buffer-create "*ERT Backtrace*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + ;; Use unibyte because `debugger-setup-buffer' also does so. + (set-buffer-multibyte nil) + (setq truncate-lines t) + (ert--print-backtrace backtrace) + (debugger-make-xrefs) + (goto-char (point-min)) + (insert "Backtrace for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))))) + +(defun ert-results-pop-to-messages-for-test-at-point () + "Display the part of the *Messages* buffer generated during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT Messages*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (insert (ert-test-result-messages result)) + (goto-char (point-min)) + (insert "Messages for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))) + +(defun ert-results-pop-to-should-forms-for-test-at-point () + "Display the list of `should' forms executed during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT list of should forms*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null (ert-test-result-should-forms result)) + (insert "\n(No should forms during this test.)\n") + (loop for form-description in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) + (goto-char (point-min)) + (insert "`should' forms executed during test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n") + (insert "\n") + (insert (concat "(Values are shallow copies and may have " + "looked different during the test if they\n" + "have been modified destructively.)\n")) + (forward-line 1))))) + +(defun ert-results-toggle-printer-limits-for-test-at-point () + "Toggle how much of the condition to print for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((ewoc ert--results-ewoc) + (node (ert--results-test-node-at-point)) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-extended-printer-limits-p entry) + (not (ert--ewoc-entry-extended-printer-limits-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-pop-to-timings () + "Display test timings for the last run. + +To be used in the ERT results buffer." + (interactive) + (let* ((stats ert--results-stats) + (start-times (ert--stats-test-start-times stats)) + (end-times (ert--stats-test-end-times stats)) + (buffer (get-buffer-create "*ERT timings*")) + (data (loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (subtract-time end-time + start-time)))))) + (setq data (sort data (lambda (a b) + (> (second a) (second b))))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null data) + (insert "(No data)\n") + (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) + (loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (let ((begin (point))) + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) + (goto-char (point-min)) + (insert "Tests by run time (seconds):\n\n") + (forward-line 1)))) + +;;;###autoload +(defun ert-describe-test (test-or-test-name) + "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." + (interactive (list (ert-read-test-name-at-point "Describe test"))) + (when (< emacs-major-version 24) + (error "Requires Emacs 24")) + (let (test-name + test-definition) + (etypecase test-or-test-name + (symbol (setq test-name test-or-test-name + test-definition (ert-get-test test-or-test-name))) + (ert-test (setq test-name (ert-test-name test-or-test-name) + test-definition test-or-test-name))) + (help-setup-xref (list #'ert-describe-test test-or-test-name) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert (if test-name (format "%S" test-name) "")) + (insert " is a test") + (let ((file-name (and test-name + (symbol-file test-name 'ert-deftest)))) + (when file-name + (insert " defined in `" (file-name-nondirectory file-name) "'") + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-def test-name file-name))) + (insert ".") + (fill-region-as-paragraph (point-min) (point)) + (insert "\n\n") + (unless (and (ert-test-boundp test-name) + (eql (ert-get-test test-name) test-definition)) + (let ((begin (point))) + (insert "Note: This test has been redefined or deleted, " + "this documentation refers to an old definition.") + (fill-region-as-paragraph begin (point))) + (insert "\n\n")) + (insert (or (ert-test-documentation test-definition) + "It is not documented.") + "\n"))))))) + +(defun ert-results-describe-test-at-point () + "Display the documentation of the test at point. + +To be used in the ERT results buffer." + (interactive) + (ert-describe-test (ert--results-test-at-point-no-redefinition))) + + +;;; Actions on load/unload. + +(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) +(add-to-list 'minor-mode-alist '(ert--current-run-stats + (:eval + (ert--tests-running-mode-line-indicator)))) +(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) + +(defun ert--unload-function () + "Unload function to undo the side-effects of loading ert.el." + (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) + (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) + (ert--remove-from-list 'emacs-lisp-mode-hook + 'ert--activate-font-lock-keywords) + nil) + +(defvar ert-unload-hook '()) +(add-hook 'ert-unload-hook 'ert--unload-function) + + +(provide 'ert) + +;;; ert.el ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/hyperspec.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/hyperspec.el new file mode 100644 index 0000000..45c3328 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/hyperspec.el @@ -0,0 +1,2511 @@ +;;; hyperspec.el --- Browse documentation from the Common Lisp HyperSpec + +;; Copyright 1997 Naggum Software + +;; Author: Erik Naggum +;; Keywords: lisp + +;; This file is not part of GNU Emacs, but distributed under the same +;; conditions as GNU Emacs, and is useless without GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Kent Pitman and Xanalys Inc. have made the text of American National +;; Standard for Information Technology -- Programming Language -- Common +;; Lisp, ANSI X3.226-1994 available on the WWW, in the form of the Common +;; Lisp HyperSpec. This package makes it convenient to peruse this +;; documentation from within Emacs. + +;;; Code: + +(require 'cl-lib nil t) +(require 'cl-lib "lib/cl-lib") +(require 'browse-url) ;you need the Emacs 20 version +(require 'thingatpt) + +(defvar common-lisp-hyperspec-root + "http://www.lispworks.com/reference/HyperSpec/" + "The root of the Common Lisp HyperSpec URL. +If you copy the HyperSpec to your local system, set this variable to +something like \"file://usr/local/doc/HyperSpec/\".") + +;;; Added variable for CLHS symbol table. See details below. +;;; +;;; 20011201 Edi Weitz + +(defvar common-lisp-hyperspec-symbol-table nil + "The HyperSpec symbol table file. +If you copy the HyperSpec to your local system, set this variable to +the location of the symbol table which is usually \"Map_Sym.txt\" +or \"Symbol-Table.text\".") + +(defvar common-lisp-hyperspec-history nil + "History of symbols looked up in the Common Lisp HyperSpec.") + +(defvar common-lisp-hyperspec--symbols (make-hash-table :test 'equal) + "Map a symbol name to its list of relative URLs.") + +;; Lookup NAME in 'common-lisp-hyperspec--symbols´ +(defun common-lisp-hyperspec--find (name) + "Get the relative url of a Common Lisp symbol NAME." + (gethash name common-lisp-hyperspec--symbols)) + +(defun common-lisp-hyperspec--insert (name relative-url) + "Insert CL symbol NAME and RELATIVE-URL into master table." + (cl-pushnew relative-url + (gethash name common-lisp-hyperspec--symbols) + :test #'equal)) + +(defun common-lisp-hyperspec--strip-cl-package (name) + (if (string-match "^\\([^:]*\\)::?\\([^:]*\\)$" name) + (let ((package-name (match-string 1 name)) + (symbol-name (match-string 2 name))) + (if (member (downcase package-name) + '("cl" "common-lisp")) + symbol-name + name)) + name)) + +;; Choose the symbol at point or read symbol-name from the minibuffer. +(defun common-lisp-hyperspec-read-symbol-name (&optional symbol-at-point) + (let* ((symbol-at-point (or symbol-at-point (thing-at-point 'symbol))) + (stripped-symbol (and symbol-at-point + (common-lisp-hyperspec--strip-cl-package + (downcase symbol-at-point))))) + (cond ((and stripped-symbol + (common-lisp-hyperspec--find stripped-symbol)) + stripped-symbol) + (t + (completing-read "Look up symbol in Common Lisp HyperSpec: " + common-lisp-hyperspec--symbols nil t + stripped-symbol + 'common-lisp-hyperspec-history))))) + +;; FIXME: is the (sleep-for 1.5) a actually needed? +(defun common-lisp-hyperspec (symbol-name) + "View the documentation on SYMBOL-NAME from the Common Lisp HyperSpec. +If SYMBOL-NAME has more than one definition, all of them are displayed with +your favorite browser in sequence. The browser should have a \"back\" +function to view the separate definitions. + +The Common Lisp HyperSpec is the full ANSI Standard Common Lisp, provided +by Kent Pitman and Xanalys Inc. By default, the Xanalys Web site is +visited to retrieve the information. Xanalys Inc. allows you to transfer +the entire Common Lisp HyperSpec to your own site under certain conditions. +Visit http://www.lispworks.com/reference/HyperSpec/ for more information. +If you copy the HyperSpec to another location, customize the variable +`common-lisp-hyperspec-root' to point to that location." + (interactive (list (common-lisp-hyperspec-read-symbol-name))) + (let ((name (common-lisp-hyperspec--strip-cl-package + (downcase symbol-name)))) + (cl-maplist (lambda (entry) + (browse-url (concat common-lisp-hyperspec-root "Body/" + (car entry))) + (when (cdr entry) + (sleep-for 1.5))) + (or (common-lisp-hyperspec--find name) + (error "The symbol `%s' is not defined in Common Lisp" + symbol-name))))) + +;;; Added dynamic lookup of symbol in CLHS symbol table +;;; +;;; 20011202 Edi Weitz + +;;; Replaced symbol table for v 4.0 with the one for v 6.0 +;;; (which is now online at Xanalys' site) +;;; +;;; 20020213 Edi Weitz + +(defun common-lisp-hyperspec--get-one-line () + (prog1 + (cl-delete ?\n (thing-at-point 'line)) + (forward-line))) + +(defun common-lisp-hyperspec--parse-map-file (file) + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (let ((result '())) + (while (< (point) (point-max)) + (let* ((symbol-name (downcase (common-lisp-hyperspec--get-one-line))) + (relative-url (common-lisp-hyperspec--get-one-line)) + (file (file-name-nondirectory relative-url))) + (push (list symbol-name file) + result))) + (reverse result)))) + +(mapc (lambda (entry) + (common-lisp-hyperspec--insert (car entry) (cadr entry))) + (if common-lisp-hyperspec-symbol-table + (common-lisp-hyperspec--parse-map-file + common-lisp-hyperspec-symbol-table) + '(("&allow-other-keys" "03_da.htm") + ("&aux" "03_da.htm") + ("&body" "03_dd.htm") + ("&environment" "03_dd.htm") + ("&key" "03_da.htm") + ("&optional" "03_da.htm") + ("&rest" "03_da.htm") + ("&whole" "03_dd.htm") + ("*" "a_st.htm") + ("**" "v__stst_.htm") + ("***" "v__stst_.htm") + ("*break-on-signals*" "v_break_.htm") + ("*compile-file-pathname*" "v_cmp_fi.htm") + ("*compile-file-truename*" "v_cmp_fi.htm") + ("*compile-print*" "v_cmp_pr.htm") + ("*compile-verbose*" "v_cmp_pr.htm") + ("*debug-io*" "v_debug_.htm") + ("*debugger-hook*" "v_debugg.htm") + ("*default-pathname-defaults*" "v_defaul.htm") + ("*error-output*" "v_debug_.htm") + ("*features*" "v_featur.htm") + ("*gensym-counter*" "v_gensym.htm") + ("*load-pathname*" "v_ld_pns.htm") + ("*load-print*" "v_ld_prs.htm") + ("*load-truename*" "v_ld_pns.htm") + ("*load-verbose*" "v_ld_prs.htm") + ("*macroexpand-hook*" "v_mexp_h.htm") + ("*modules*" "v_module.htm") + ("*package*" "v_pkg.htm") + ("*print-array*" "v_pr_ar.htm") + ("*print-base*" "v_pr_bas.htm") + ("*print-case*" "v_pr_cas.htm") + ("*print-circle*" "v_pr_cir.htm") + ("*print-escape*" "v_pr_esc.htm") + ("*print-gensym*" "v_pr_gen.htm") + ("*print-length*" "v_pr_lev.htm") + ("*print-level*" "v_pr_lev.htm") + ("*print-lines*" "v_pr_lin.htm") + ("*print-miser-width*" "v_pr_mis.htm") + ("*print-pprint-dispatch*" "v_pr_ppr.htm") + ("*print-pretty*" "v_pr_pre.htm") + ("*print-radix*" "v_pr_bas.htm") + ("*print-readably*" "v_pr_rda.htm") + ("*print-right-margin*" "v_pr_rig.htm") + ("*query-io*" "v_debug_.htm") + ("*random-state*" "v_rnd_st.htm") + ("*read-base*" "v_rd_bas.htm") + ("*read-default-float-format*" "v_rd_def.htm") + ("*read-eval*" "v_rd_eva.htm") + ("*read-suppress*" "v_rd_sup.htm") + ("*readtable*" "v_rdtabl.htm") + ("*standard-input*" "v_debug_.htm") + ("*standard-output*" "v_debug_.htm") + ("*terminal-io*" "v_termin.htm") + ("*trace-output*" "v_debug_.htm") + ("+" "a_pl.htm") + ("++" "v_pl_plp.htm") + ("+++" "v_pl_plp.htm") + ("-" "a__.htm") + ("/" "a_sl.htm") + ("//" "v_sl_sls.htm") + ("///" "v_sl_sls.htm") + ("/=" "f_eq_sle.htm") + ("1+" "f_1pl_1_.htm") + ("1-" "f_1pl_1_.htm") + ("<" "f_eq_sle.htm") + ("<=" "f_eq_sle.htm") + ("=" "f_eq_sle.htm") + (">" "f_eq_sle.htm") + (">=" "f_eq_sle.htm") + ("abort" "a_abort.htm") + ("abs" "f_abs.htm") + ("acons" "f_acons.htm") + ("acos" "f_asin_.htm") + ("acosh" "f_sinh_.htm") + ("add-method" "f_add_me.htm") + ("adjoin" "f_adjoin.htm") + ("adjust-array" "f_adjust.htm") + ("adjustable-array-p" "f_adju_1.htm") + ("allocate-instance" "f_alloca.htm") + ("alpha-char-p" "f_alpha_.htm") + ("alphanumericp" "f_alphan.htm") + ("and" "a_and.htm") + ("append" "f_append.htm") + ("apply" "f_apply.htm") + ("apropos" "f_apropo.htm") + ("apropos-list" "f_apropo.htm") + ("aref" "f_aref.htm") + ("arithmetic-error" "e_arithm.htm") + ("arithmetic-error-operands" "f_arithm.htm") + ("arithmetic-error-operation" "f_arithm.htm") + ("array" "t_array.htm") + ("array-dimension" "f_ar_dim.htm") + ("array-dimension-limit" "v_ar_dim.htm") + ("array-dimensions" "f_ar_d_1.htm") + ("array-displacement" "f_ar_dis.htm") + ("array-element-type" "f_ar_ele.htm") + ("array-has-fill-pointer-p" "f_ar_has.htm") + ("array-in-bounds-p" "f_ar_in_.htm") + ("array-rank" "f_ar_ran.htm") + ("array-rank-limit" "v_ar_ran.htm") + ("array-row-major-index" "f_ar_row.htm") + ("array-total-size" "f_ar_tot.htm") + ("array-total-size-limit" "v_ar_tot.htm") + ("arrayp" "f_arrayp.htm") + ("ash" "f_ash.htm") + ("asin" "f_asin_.htm") + ("asinh" "f_sinh_.htm") + ("assert" "m_assert.htm") + ("assoc" "f_assocc.htm") + ("assoc-if" "f_assocc.htm") + ("assoc-if-not" "f_assocc.htm") + ("atan" "f_asin_.htm") + ("atanh" "f_sinh_.htm") + ("atom" "a_atom.htm") + ("base-char" "t_base_c.htm") + ("base-string" "t_base_s.htm") + ("bignum" "t_bignum.htm") + ("bit" "a_bit.htm") + ("bit-and" "f_bt_and.htm") + ("bit-andc1" "f_bt_and.htm") + ("bit-andc2" "f_bt_and.htm") + ("bit-eqv" "f_bt_and.htm") + ("bit-ior" "f_bt_and.htm") + ("bit-nand" "f_bt_and.htm") + ("bit-nor" "f_bt_and.htm") + ("bit-not" "f_bt_and.htm") + ("bit-orc1" "f_bt_and.htm") + ("bit-orc2" "f_bt_and.htm") + ("bit-vector" "t_bt_vec.htm") + ("bit-vector-p" "f_bt_vec.htm") + ("bit-xor" "f_bt_and.htm") + ("block" "s_block.htm") + ("boole" "f_boole.htm") + ("boole-1" "v_b_1_b.htm") + ("boole-2" "v_b_1_b.htm") + ("boole-and" "v_b_1_b.htm") + ("boole-andc1" "v_b_1_b.htm") + ("boole-andc2" "v_b_1_b.htm") + ("boole-c1" "v_b_1_b.htm") + ("boole-c2" "v_b_1_b.htm") + ("boole-clr" "v_b_1_b.htm") + ("boole-eqv" "v_b_1_b.htm") + ("boole-ior" "v_b_1_b.htm") + ("boole-nand" "v_b_1_b.htm") + ("boole-nor" "v_b_1_b.htm") + ("boole-orc1" "v_b_1_b.htm") + ("boole-orc2" "v_b_1_b.htm") + ("boole-set" "v_b_1_b.htm") + ("boole-xor" "v_b_1_b.htm") + ("boolean" "t_ban.htm") + ("both-case-p" "f_upper_.htm") + ("boundp" "f_boundp.htm") + ("break" "f_break.htm") + ("broadcast-stream" "t_broadc.htm") + ("broadcast-stream-streams" "f_broadc.htm") + ("built-in-class" "t_built_.htm") + ("butlast" "f_butlas.htm") + ("byte" "f_by_by.htm") + ("byte-position" "f_by_by.htm") + ("byte-size" "f_by_by.htm") + ("caaaar" "f_car_c.htm") + ("caaadr" "f_car_c.htm") + ("caaar" "f_car_c.htm") + ("caadar" "f_car_c.htm") + ("caaddr" "f_car_c.htm") + ("caadr" "f_car_c.htm") + ("caar" "f_car_c.htm") + ("cadaar" "f_car_c.htm") + ("cadadr" "f_car_c.htm") + ("cadar" "f_car_c.htm") + ("caddar" "f_car_c.htm") + ("cadddr" "f_car_c.htm") + ("caddr" "f_car_c.htm") + ("cadr" "f_car_c.htm") + ("call-arguments-limit" "v_call_a.htm") + ("call-method" "m_call_m.htm") + ("call-next-method" "f_call_n.htm") + ("car" "f_car_c.htm") + ("case" "m_case_.htm") + ("catch" "s_catch.htm") + ("ccase" "m_case_.htm") + ("cdaaar" "f_car_c.htm") + ("cdaadr" "f_car_c.htm") + ("cdaar" "f_car_c.htm") + ("cdadar" "f_car_c.htm") + ("cdaddr" "f_car_c.htm") + ("cdadr" "f_car_c.htm") + ("cdar" "f_car_c.htm") + ("cddaar" "f_car_c.htm") + ("cddadr" "f_car_c.htm") + ("cddar" "f_car_c.htm") + ("cdddar" "f_car_c.htm") + ("cddddr" "f_car_c.htm") + ("cdddr" "f_car_c.htm") + ("cddr" "f_car_c.htm") + ("cdr" "f_car_c.htm") + ("ceiling" "f_floorc.htm") + ("cell-error" "e_cell_e.htm") + ("cell-error-name" "f_cell_e.htm") + ("cerror" "f_cerror.htm") + ("change-class" "f_chg_cl.htm") + ("char" "f_char_.htm") + ("char-code" "f_char_c.htm") + ("char-code-limit" "v_char_c.htm") + ("char-downcase" "f_char_u.htm") + ("char-equal" "f_chareq.htm") + ("char-greaterp" "f_chareq.htm") + ("char-int" "f_char_i.htm") + ("char-lessp" "f_chareq.htm") + ("char-name" "f_char_n.htm") + ("char-not-equal" "f_chareq.htm") + ("char-not-greaterp" "f_chareq.htm") + ("char-not-lessp" "f_chareq.htm") + ("char-upcase" "f_char_u.htm") + ("char/=" "f_chareq.htm") + ("char<" "f_chareq.htm") + ("char<=" "f_chareq.htm") + ("char=" "f_chareq.htm") + ("char>" "f_chareq.htm") + ("char>=" "f_chareq.htm") + ("character" "a_ch.htm") + ("characterp" "f_chp.htm") + ("check-type" "m_check_.htm") + ("cis" "f_cis.htm") + ("class" "t_class.htm") + ("class-name" "f_class_.htm") + ("class-of" "f_clas_1.htm") + ("clear-input" "f_clear_.htm") + ("clear-output" "f_finish.htm") + ("close" "f_close.htm") + ("clrhash" "f_clrhas.htm") + ("code-char" "f_code_c.htm") + ("coerce" "f_coerce.htm") + ("compilation-speed" "d_optimi.htm") + ("compile" "f_cmp.htm") + ("compile-file" "f_cmp_fi.htm") + ("compile-file-pathname" "f_cmp__1.htm") + ("compiled-function" "t_cmpd_f.htm") + ("compiled-function-p" "f_cmpd_f.htm") + ("compiler-macro" "f_docume.htm") + ("compiler-macro-function" "f_cmp_ma.htm") + ("complement" "f_comple.htm") + ("complex" "a_comple.htm") + ("complexp" "f_comp_3.htm") + ("compute-applicable-methods" "f_comput.htm") + ("compute-restarts" "f_comp_1.htm") + ("concatenate" "f_concat.htm") + ("concatenated-stream" "t_concat.htm") + ("concatenated-stream-streams" "f_conc_1.htm") + ("cond" "m_cond.htm") + ("condition" "e_cnd.htm") + ("conjugate" "f_conjug.htm") + ("cons" "a_cons.htm") + ("consp" "f_consp.htm") + ("constantly" "f_cons_1.htm") + ("constantp" "f_consta.htm") + ("continue" "a_contin.htm") + ("control-error" "e_contro.htm") + ("copy-alist" "f_cp_ali.htm") + ("copy-list" "f_cp_lis.htm") + ("copy-pprint-dispatch" "f_cp_ppr.htm") + ("copy-readtable" "f_cp_rdt.htm") + ("copy-seq" "f_cp_seq.htm") + ("copy-structure" "f_cp_stu.htm") + ("copy-symbol" "f_cp_sym.htm") + ("copy-tree" "f_cp_tre.htm") + ("cos" "f_sin_c.htm") + ("cosh" "f_sinh_.htm") + ("count" "f_countc.htm") + ("count-if" "f_countc.htm") + ("count-if-not" "f_countc.htm") + ("ctypecase" "m_tpcase.htm") + ("debug" "d_optimi.htm") + ("decf" "m_incf_.htm") + ("declaim" "m_declai.htm") + ("declaration" "d_declar.htm") + ("declare" "s_declar.htm") + ("decode-float" "f_dec_fl.htm") + ("decode-universal-time" "f_dec_un.htm") + ("defclass" "m_defcla.htm") + ("defconstant" "m_defcon.htm") + ("defgeneric" "m_defgen.htm") + ("define-compiler-macro" "m_define.htm") + ("define-condition" "m_defi_5.htm") + ("define-method-combination" "m_defi_4.htm") + ("define-modify-macro" "m_defi_2.htm") + ("define-setf-expander" "m_defi_3.htm") + ("define-symbol-macro" "m_defi_1.htm") + ("defmacro" "m_defmac.htm") + ("defmethod" "m_defmet.htm") + ("defpackage" "m_defpkg.htm") + ("defparameter" "m_defpar.htm") + ("defsetf" "m_defset.htm") + ("defstruct" "m_defstr.htm") + ("deftype" "m_deftp.htm") + ("defun" "m_defun.htm") + ("defvar" "m_defpar.htm") + ("delete" "f_rm_rm.htm") + ("delete-duplicates" "f_rm_dup.htm") + ("delete-file" "f_del_fi.htm") + ("delete-if" "f_rm_rm.htm") + ("delete-if-not" "f_rm_rm.htm") + ("delete-package" "f_del_pk.htm") + ("denominator" "f_numera.htm") + ("deposit-field" "f_deposi.htm") + ("describe" "f_descri.htm") + ("describe-object" "f_desc_1.htm") + ("destructuring-bind" "m_destru.htm") + ("digit-char" "f_digit_.htm") + ("digit-char-p" "f_digi_1.htm") + ("directory" "f_dir.htm") + ("directory-namestring" "f_namest.htm") + ("disassemble" "f_disass.htm") + ("division-by-zero" "e_divisi.htm") + ("do" "m_do_do.htm") + ("do*" "m_do_do.htm") + ("do-all-symbols" "m_do_sym.htm") + ("do-external-symbols" "m_do_sym.htm") + ("do-symbols" "m_do_sym.htm") + ("documentation" "f_docume.htm") + ("dolist" "m_dolist.htm") + ("dotimes" "m_dotime.htm") + ("double-float" "t_short_.htm") + ("double-float-epsilon" "v_short_.htm") + ("double-float-negative-epsilon" "v_short_.htm") + ("dpb" "f_dpb.htm") + ("dribble" "f_dribbl.htm") + ("dynamic-extent" "d_dynami.htm") + ("ecase" "m_case_.htm") + ("echo-stream" "t_echo_s.htm") + ("echo-stream-input-stream" "f_echo_s.htm") + ("echo-stream-output-stream" "f_echo_s.htm") + ("ed" "f_ed.htm") + ("eighth" "f_firstc.htm") + ("elt" "f_elt.htm") + ("encode-universal-time" "f_encode.htm") + ("end-of-file" "e_end_of.htm") + ("endp" "f_endp.htm") + ("enough-namestring" "f_namest.htm") + ("ensure-directories-exist" "f_ensu_1.htm") + ("ensure-generic-function" "f_ensure.htm") + ("eq" "f_eq.htm") + ("eql" "a_eql.htm") + ("equal" "f_equal.htm") + ("equalp" "f_equalp.htm") + ("error" "a_error.htm") + ("etypecase" "m_tpcase.htm") + ("eval" "f_eval.htm") + ("eval-when" "s_eval_w.htm") + ("evenp" "f_evenpc.htm") + ("every" "f_everyc.htm") + ("exp" "f_exp_e.htm") + ("export" "f_export.htm") + ("expt" "f_exp_e.htm") + ("extended-char" "t_extend.htm") + ("fboundp" "f_fbound.htm") + ("fceiling" "f_floorc.htm") + ("fdefinition" "f_fdefin.htm") + ("ffloor" "f_floorc.htm") + ("fifth" "f_firstc.htm") + ("file-author" "f_file_a.htm") + ("file-error" "e_file_e.htm") + ("file-error-pathname" "f_file_e.htm") + ("file-length" "f_file_l.htm") + ("file-namestring" "f_namest.htm") + ("file-position" "f_file_p.htm") + ("file-stream" "t_file_s.htm") + ("file-string-length" "f_file_s.htm") + ("file-write-date" "f_file_w.htm") + ("fill" "f_fill.htm") + ("fill-pointer" "f_fill_p.htm") + ("find" "f_find_.htm") + ("find-all-symbols" "f_find_a.htm") + ("find-class" "f_find_c.htm") + ("find-if" "f_find_.htm") + ("find-if-not" "f_find_.htm") + ("find-method" "f_find_m.htm") + ("find-package" "f_find_p.htm") + ("find-restart" "f_find_r.htm") + ("find-symbol" "f_find_s.htm") + ("finish-output" "f_finish.htm") + ("first" "f_firstc.htm") + ("fixnum" "t_fixnum.htm") + ("flet" "s_flet_.htm") + ("float" "a_float.htm") + ("float-digits" "f_dec_fl.htm") + ("float-precision" "f_dec_fl.htm") + ("float-radix" "f_dec_fl.htm") + ("float-sign" "f_dec_fl.htm") + ("floating-point-inexact" "e_floa_1.htm") + ("floating-point-invalid-operation" "e_floati.htm") + ("floating-point-overflow" "e_floa_2.htm") + ("floating-point-underflow" "e_floa_3.htm") + ("floatp" "f_floatp.htm") + ("floor" "f_floorc.htm") + ("fmakunbound" "f_fmakun.htm") + ("force-output" "f_finish.htm") + ("format" "f_format.htm") + ("formatter" "m_format.htm") + ("fourth" "f_firstc.htm") + ("fresh-line" "f_terpri.htm") + ("fround" "f_floorc.htm") + ("ftruncate" "f_floorc.htm") + ("ftype" "d_ftype.htm") + ("funcall" "f_funcal.htm") + ("function" "a_fn.htm") + ("function-keywords" "f_fn_kwd.htm") + ("function-lambda-expression" "f_fn_lam.htm") + ("functionp" "f_fnp.htm") + ("gcd" "f_gcd.htm") + ("generic-function" "t_generi.htm") + ("gensym" "f_gensym.htm") + ("gentemp" "f_gentem.htm") + ("get" "f_get.htm") + ("get-decoded-time" "f_get_un.htm") + ("get-dispatch-macro-character" "f_set__1.htm") + ("get-internal-real-time" "f_get_in.htm") + ("get-internal-run-time" "f_get__1.htm") + ("get-macro-character" "f_set_ma.htm") + ("get-output-stream-string" "f_get_ou.htm") + ("get-properties" "f_get_pr.htm") + ("get-setf-expansion" "f_get_se.htm") + ("get-universal-time" "f_get_un.htm") + ("getf" "f_getf.htm") + ("gethash" "f_gethas.htm") + ("go" "s_go.htm") + ("graphic-char-p" "f_graphi.htm") + ("handler-bind" "m_handle.htm") + ("handler-case" "m_hand_1.htm") + ("hash-table" "t_hash_t.htm") + ("hash-table-count" "f_hash_1.htm") + ("hash-table-p" "f_hash_t.htm") + ("hash-table-rehash-size" "f_hash_2.htm") + ("hash-table-rehash-threshold" "f_hash_3.htm") + ("hash-table-size" "f_hash_4.htm") + ("hash-table-test" "f_hash_5.htm") + ("host-namestring" "f_namest.htm") + ("identity" "f_identi.htm") + ("if" "s_if.htm") + ("ignorable" "d_ignore.htm") + ("ignore" "d_ignore.htm") + ("ignore-errors" "m_ignore.htm") + ("imagpart" "f_realpa.htm") + ("import" "f_import.htm") + ("in-package" "m_in_pkg.htm") + ("incf" "m_incf_.htm") + ("initialize-instance" "f_init_i.htm") + ("inline" "d_inline.htm") + ("input-stream-p" "f_in_stm.htm") + ("inspect" "f_inspec.htm") + ("integer" "t_intege.htm") + ("integer-decode-float" "f_dec_fl.htm") + ("integer-length" "f_intege.htm") + ("integerp" "f_inte_1.htm") + ("interactive-stream-p" "f_intera.htm") + ("intern" "f_intern.htm") + ("internal-time-units-per-second" "v_intern.htm") + ("intersection" "f_isec_.htm") + ("invalid-method-error" "f_invali.htm") + ("invoke-debugger" "f_invoke.htm") + ("invoke-restart" "f_invo_1.htm") + ("invoke-restart-interactively" "f_invo_2.htm") + ("isqrt" "f_sqrt_.htm") + ("keyword" "t_kwd.htm") + ("keywordp" "f_kwdp.htm") + ("labels" "s_flet_.htm") + ("lambda" "a_lambda.htm") + ("lambda-list-keywords" "v_lambda.htm") + ("lambda-parameters-limit" "v_lamb_1.htm") + ("last" "f_last.htm") + ("lcm" "f_lcm.htm") + ("ldb" "f_ldb.htm") + ("ldb-test" "f_ldb_te.htm") + ("ldiff" "f_ldiffc.htm") + ("least-negative-double-float" "v_most_1.htm") + ("least-negative-long-float" "v_most_1.htm") + ("least-negative-normalized-double-float" "v_most_1.htm") + ("least-negative-normalized-long-float" "v_most_1.htm") + ("least-negative-normalized-short-float" "v_most_1.htm") + ("least-negative-normalized-single-float" "v_most_1.htm") + ("least-negative-short-float" "v_most_1.htm") + ("least-negative-single-float" "v_most_1.htm") + ("least-positive-double-float" "v_most_1.htm") + ("least-positive-long-float" "v_most_1.htm") + ("least-positive-normalized-double-float" "v_most_1.htm") + ("least-positive-normalized-long-float" "v_most_1.htm") + ("least-positive-normalized-short-float" "v_most_1.htm") + ("least-positive-normalized-single-float" "v_most_1.htm") + ("least-positive-short-float" "v_most_1.htm") + ("least-positive-single-float" "v_most_1.htm") + ("length" "f_length.htm") + ("let" "s_let_l.htm") + ("let*" "s_let_l.htm") + ("lisp-implementation-type" "f_lisp_i.htm") + ("lisp-implementation-version" "f_lisp_i.htm") + ("list" "a_list.htm") + ("list*" "f_list_.htm") + ("list-all-packages" "f_list_a.htm") + ("list-length" "f_list_l.htm") + ("listen" "f_listen.htm") + ("listp" "f_listp.htm") + ("load" "f_load.htm") + ("load-logical-pathname-translations" "f_ld_log.htm") + ("load-time-value" "s_ld_tim.htm") + ("locally" "s_locall.htm") + ("log" "f_log.htm") + ("logand" "f_logand.htm") + ("logandc1" "f_logand.htm") + ("logandc2" "f_logand.htm") + ("logbitp" "f_logbtp.htm") + ("logcount" "f_logcou.htm") + ("logeqv" "f_logand.htm") + ("logical-pathname" "a_logica.htm") + ("logical-pathname-translations" "f_logica.htm") + ("logior" "f_logand.htm") + ("lognand" "f_logand.htm") + ("lognor" "f_logand.htm") + ("lognot" "f_logand.htm") + ("logorc1" "f_logand.htm") + ("logorc2" "f_logand.htm") + ("logtest" "f_logtes.htm") + ("logxor" "f_logand.htm") + ("long-float" "t_short_.htm") + ("long-float-epsilon" "v_short_.htm") + ("long-float-negative-epsilon" "v_short_.htm") + ("long-site-name" "f_short_.htm") + ("loop" "m_loop.htm") + ("loop-finish" "m_loop_f.htm") + ("lower-case-p" "f_upper_.htm") + ("machine-instance" "f_mach_i.htm") + ("machine-type" "f_mach_t.htm") + ("machine-version" "f_mach_v.htm") + ("macro-function" "f_macro_.htm") + ("macroexpand" "f_mexp_.htm") + ("macroexpand-1" "f_mexp_.htm") + ("macrolet" "s_flet_.htm") + ("make-array" "f_mk_ar.htm") + ("make-broadcast-stream" "f_mk_bro.htm") + ("make-concatenated-stream" "f_mk_con.htm") + ("make-condition" "f_mk_cnd.htm") + ("make-dispatch-macro-character" "f_mk_dis.htm") + ("make-echo-stream" "f_mk_ech.htm") + ("make-hash-table" "f_mk_has.htm") + ("make-instance" "f_mk_ins.htm") + ("make-instances-obsolete" "f_mk_i_1.htm") + ("make-list" "f_mk_lis.htm") + ("make-load-form" "f_mk_ld_.htm") + ("make-load-form-saving-slots" "f_mk_l_1.htm") + ("make-method" "m_call_m.htm") + ("make-package" "f_mk_pkg.htm") + ("make-pathname" "f_mk_pn.htm") + ("make-random-state" "f_mk_rnd.htm") + ("make-sequence" "f_mk_seq.htm") + ("make-string" "f_mk_stg.htm") + ("make-string-input-stream" "f_mk_s_1.htm") + ("make-string-output-stream" "f_mk_s_2.htm") + ("make-symbol" "f_mk_sym.htm") + ("make-synonym-stream" "f_mk_syn.htm") + ("make-two-way-stream" "f_mk_two.htm") + ("makunbound" "f_makunb.htm") + ("map" "f_map.htm") + ("map-into" "f_map_in.htm") + ("mapc" "f_mapc_.htm") + ("mapcan" "f_mapc_.htm") + ("mapcar" "f_mapc_.htm") + ("mapcon" "f_mapc_.htm") + ("maphash" "f_maphas.htm") + ("mapl" "f_mapc_.htm") + ("maplist" "f_mapc_.htm") + ("mask-field" "f_mask_f.htm") + ("max" "f_max_m.htm") + ("member" "a_member.htm") + ("member-if" "f_mem_m.htm") + ("member-if-not" "f_mem_m.htm") + ("merge" "f_merge.htm") + ("merge-pathnames" "f_merge_.htm") + ("method" "t_method.htm") + ("method-combination" "a_method.htm") + ("method-combination-error" "f_meth_1.htm") + ("method-qualifiers" "f_method.htm") + ("min" "f_max_m.htm") + ("minusp" "f_minusp.htm") + ("mismatch" "f_mismat.htm") + ("mod" "a_mod.htm") + ("most-negative-double-float" "v_most_1.htm") + ("most-negative-fixnum" "v_most_p.htm") + ("most-negative-long-float" "v_most_1.htm") + ("most-negative-short-float" "v_most_1.htm") + ("most-negative-single-float" "v_most_1.htm") + ("most-positive-double-float" "v_most_1.htm") + ("most-positive-fixnum" "v_most_p.htm") + ("most-positive-long-float" "v_most_1.htm") + ("most-positive-short-float" "v_most_1.htm") + ("most-positive-single-float" "v_most_1.htm") + ("muffle-warning" "a_muffle.htm") + ("multiple-value-bind" "m_multip.htm") + ("multiple-value-call" "s_multip.htm") + ("multiple-value-list" "m_mult_1.htm") + ("multiple-value-prog1" "s_mult_1.htm") + ("multiple-value-setq" "m_mult_2.htm") + ("multiple-values-limit" "v_multip.htm") + ("name-char" "f_name_c.htm") + ("namestring" "f_namest.htm") + ("nbutlast" "f_butlas.htm") + ("nconc" "f_nconc.htm") + ("next-method-p" "f_next_m.htm") + ("nil" "a_nil.htm") + ("nintersection" "f_isec_.htm") + ("ninth" "f_firstc.htm") + ("no-applicable-method" "f_no_app.htm") + ("no-next-method" "f_no_nex.htm") + ("not" "a_not.htm") + ("notany" "f_everyc.htm") + ("notevery" "f_everyc.htm") + ("notinline" "d_inline.htm") + ("nreconc" "f_revapp.htm") + ("nreverse" "f_revers.htm") + ("nset-difference" "f_set_di.htm") + ("nset-exclusive-or" "f_set_ex.htm") + ("nstring-capitalize" "f_stg_up.htm") + ("nstring-downcase" "f_stg_up.htm") + ("nstring-upcase" "f_stg_up.htm") + ("nsublis" "f_sublis.htm") + ("nsubst" "f_substc.htm") + ("nsubst-if" "f_substc.htm") + ("nsubst-if-not" "f_substc.htm") + ("nsubstitute" "f_sbs_s.htm") + ("nsubstitute-if" "f_sbs_s.htm") + ("nsubstitute-if-not" "f_sbs_s.htm") + ("nth" "f_nth.htm") + ("nth-value" "m_nth_va.htm") + ("nthcdr" "f_nthcdr.htm") + ("null" "a_null.htm") + ("number" "t_number.htm") + ("numberp" "f_nump.htm") + ("numerator" "f_numera.htm") + ("nunion" "f_unionc.htm") + ("oddp" "f_evenpc.htm") + ("open" "f_open.htm") + ("open-stream-p" "f_open_s.htm") + ("optimize" "d_optimi.htm") + ("or" "a_or.htm") + ("otherwise" "m_case_.htm") + ("output-stream-p" "f_in_stm.htm") + ("package" "t_pkg.htm") + ("package-error" "e_pkg_er.htm") + ("package-error-package" "f_pkg_er.htm") + ("package-name" "f_pkg_na.htm") + ("package-nicknames" "f_pkg_ni.htm") + ("package-shadowing-symbols" "f_pkg_sh.htm") + ("package-use-list" "f_pkg_us.htm") + ("package-used-by-list" "f_pkg__1.htm") + ("packagep" "f_pkgp.htm") + ("pairlis" "f_pairli.htm") + ("parse-error" "e_parse_.htm") + ("parse-integer" "f_parse_.htm") + ("parse-namestring" "f_pars_1.htm") + ("pathname" "a_pn.htm") + ("pathname-device" "f_pn_hos.htm") + ("pathname-directory" "f_pn_hos.htm") + ("pathname-host" "f_pn_hos.htm") + ("pathname-match-p" "f_pn_mat.htm") + ("pathname-name" "f_pn_hos.htm") + ("pathname-type" "f_pn_hos.htm") + ("pathname-version" "f_pn_hos.htm") + ("pathnamep" "f_pnp.htm") + ("peek-char" "f_peek_c.htm") + ("phase" "f_phase.htm") + ("pi" "v_pi.htm") + ("plusp" "f_minusp.htm") + ("pop" "m_pop.htm") + ("position" "f_pos_p.htm") + ("position-if" "f_pos_p.htm") + ("position-if-not" "f_pos_p.htm") + ("pprint" "f_wr_pr.htm") + ("pprint-dispatch" "f_ppr_di.htm") + ("pprint-exit-if-list-exhausted" "m_ppr_ex.htm") + ("pprint-fill" "f_ppr_fi.htm") + ("pprint-indent" "f_ppr_in.htm") + ("pprint-linear" "f_ppr_fi.htm") + ("pprint-logical-block" "m_ppr_lo.htm") + ("pprint-newline" "f_ppr_nl.htm") + ("pprint-pop" "m_ppr_po.htm") + ("pprint-tab" "f_ppr_ta.htm") + ("pprint-tabular" "f_ppr_fi.htm") + ("prin1" "f_wr_pr.htm") + ("prin1-to-string" "f_wr_to_.htm") + ("princ" "f_wr_pr.htm") + ("princ-to-string" "f_wr_to_.htm") + ("print" "f_wr_pr.htm") + ("print-not-readable" "e_pr_not.htm") + ("print-not-readable-object" "f_pr_not.htm") + ("print-object" "f_pr_obj.htm") + ("print-unreadable-object" "m_pr_unr.htm") + ("probe-file" "f_probe_.htm") + ("proclaim" "f_procla.htm") + ("prog" "m_prog_.htm") + ("prog*" "m_prog_.htm") + ("prog1" "m_prog1c.htm") + ("prog2" "m_prog1c.htm") + ("progn" "s_progn.htm") + ("program-error" "e_progra.htm") + ("progv" "s_progv.htm") + ("provide" "f_provid.htm") + ("psetf" "m_setf_.htm") + ("psetq" "m_psetq.htm") + ("push" "m_push.htm") + ("pushnew" "m_pshnew.htm") + ("quote" "s_quote.htm") + ("random" "f_random.htm") + ("random-state" "t_rnd_st.htm") + ("random-state-p" "f_rnd_st.htm") + ("rassoc" "f_rassoc.htm") + ("rassoc-if" "f_rassoc.htm") + ("rassoc-if-not" "f_rassoc.htm") + ("ratio" "t_ratio.htm") + ("rational" "a_ration.htm") + ("rationalize" "f_ration.htm") + ("rationalp" "f_rati_1.htm") + ("read" "f_rd_rd.htm") + ("read-byte" "f_rd_by.htm") + ("read-char" "f_rd_cha.htm") + ("read-char-no-hang" "f_rd_c_1.htm") + ("read-delimited-list" "f_rd_del.htm") + ("read-from-string" "f_rd_fro.htm") + ("read-line" "f_rd_lin.htm") + ("read-preserving-whitespace" "f_rd_rd.htm") + ("read-sequence" "f_rd_seq.htm") + ("reader-error" "e_rder_e.htm") + ("readtable" "t_rdtabl.htm") + ("readtable-case" "f_rdtabl.htm") + ("readtablep" "f_rdta_1.htm") + ("real" "t_real.htm") + ("realp" "f_realp.htm") + ("realpart" "f_realpa.htm") + ("reduce" "f_reduce.htm") + ("reinitialize-instance" "f_reinit.htm") + ("rem" "f_mod_r.htm") + ("remf" "m_remf.htm") + ("remhash" "f_remhas.htm") + ("remove" "f_rm_rm.htm") + ("remove-duplicates" "f_rm_dup.htm") + ("remove-if" "f_rm_rm.htm") + ("remove-if-not" "f_rm_rm.htm") + ("remove-method" "f_rm_met.htm") + ("remprop" "f_rempro.htm") + ("rename-file" "f_rn_fil.htm") + ("rename-package" "f_rn_pkg.htm") + ("replace" "f_replac.htm") + ("require" "f_provid.htm") + ("rest" "f_rest.htm") + ("restart" "t_rst.htm") + ("restart-bind" "m_rst_bi.htm") + ("restart-case" "m_rst_ca.htm") + ("restart-name" "f_rst_na.htm") + ("return" "m_return.htm") + ("return-from" "s_ret_fr.htm") + ("revappend" "f_revapp.htm") + ("reverse" "f_revers.htm") + ("room" "f_room.htm") + ("rotatef" "m_rotate.htm") + ("round" "f_floorc.htm") + ("row-major-aref" "f_row_ma.htm") + ("rplaca" "f_rplaca.htm") + ("rplacd" "f_rplaca.htm") + ("safety" "d_optimi.htm") + ("satisfies" "t_satisf.htm") + ("sbit" "f_bt_sb.htm") + ("scale-float" "f_dec_fl.htm") + ("schar" "f_char_.htm") + ("search" "f_search.htm") + ("second" "f_firstc.htm") + ("sequence" "t_seq.htm") + ("serious-condition" "e_seriou.htm") + ("set" "f_set.htm") + ("set-difference" "f_set_di.htm") + ("set-dispatch-macro-character" "f_set__1.htm") + ("set-exclusive-or" "f_set_ex.htm") + ("set-macro-character" "f_set_ma.htm") + ("set-pprint-dispatch" "f_set_pp.htm") + ("set-syntax-from-char" "f_set_sy.htm") + ("setf" "a_setf.htm") + ("setq" "s_setq.htm") + ("seventh" "f_firstc.htm") + ("shadow" "f_shadow.htm") + ("shadowing-import" "f_shdw_i.htm") + ("shared-initialize" "f_shared.htm") + ("shiftf" "m_shiftf.htm") + ("short-float" "t_short_.htm") + ("short-float-epsilon" "v_short_.htm") + ("short-float-negative-epsilon" "v_short_.htm") + ("short-site-name" "f_short_.htm") + ("signal" "f_signal.htm") + ("signed-byte" "t_sgn_by.htm") + ("signum" "f_signum.htm") + ("simple-array" "t_smp_ar.htm") + ("simple-base-string" "t_smp_ba.htm") + ("simple-bit-vector" "t_smp_bt.htm") + ("simple-bit-vector-p" "f_smp_bt.htm") + ("simple-condition" "e_smp_cn.htm") + ("simple-condition-format-arguments" "f_smp_cn.htm") + ("simple-condition-format-control" "f_smp_cn.htm") + ("simple-error" "e_smp_er.htm") + ("simple-string" "t_smp_st.htm") + ("simple-string-p" "f_smp_st.htm") + ("simple-type-error" "e_smp_tp.htm") + ("simple-vector" "t_smp_ve.htm") + ("simple-vector-p" "f_smp_ve.htm") + ("simple-warning" "e_smp_wa.htm") + ("sin" "f_sin_c.htm") + ("single-float" "t_short_.htm") + ("single-float-epsilon" "v_short_.htm") + ("single-float-negative-epsilon" "v_short_.htm") + ("sinh" "f_sinh_.htm") + ("sixth" "f_firstc.htm") + ("sleep" "f_sleep.htm") + ("slot-boundp" "f_slt_bo.htm") + ("slot-exists-p" "f_slt_ex.htm") + ("slot-makunbound" "f_slt_ma.htm") + ("slot-missing" "f_slt_mi.htm") + ("slot-unbound" "f_slt_un.htm") + ("slot-value" "f_slt_va.htm") + ("software-type" "f_sw_tpc.htm") + ("software-version" "f_sw_tpc.htm") + ("some" "f_everyc.htm") + ("sort" "f_sort_.htm") + ("space" "d_optimi.htm") + ("special" "d_specia.htm") + ("special-operator-p" "f_specia.htm") + ("speed" "d_optimi.htm") + ("sqrt" "f_sqrt_.htm") + ("stable-sort" "f_sort_.htm") + ("standard" "07_ffb.htm") + ("standard-char" "t_std_ch.htm") + ("standard-char-p" "f_std_ch.htm") + ("standard-class" "t_std_cl.htm") + ("standard-generic-function" "t_std_ge.htm") + ("standard-method" "t_std_me.htm") + ("standard-object" "t_std_ob.htm") + ("step" "m_step.htm") + ("storage-condition" "e_storag.htm") + ("store-value" "a_store_.htm") + ("stream" "t_stream.htm") + ("stream-element-type" "f_stm_el.htm") + ("stream-error" "e_stm_er.htm") + ("stream-error-stream" "f_stm_er.htm") + ("stream-external-format" "f_stm_ex.htm") + ("streamp" "f_stmp.htm") + ("string" "a_string.htm") + ("string-capitalize" "f_stg_up.htm") + ("string-downcase" "f_stg_up.htm") + ("string-equal" "f_stgeq_.htm") + ("string-greaterp" "f_stgeq_.htm") + ("string-left-trim" "f_stg_tr.htm") + ("string-lessp" "f_stgeq_.htm") + ("string-not-equal" "f_stgeq_.htm") + ("string-not-greaterp" "f_stgeq_.htm") + ("string-not-lessp" "f_stgeq_.htm") + ("string-right-trim" "f_stg_tr.htm") + ("string-stream" "t_stg_st.htm") + ("string-trim" "f_stg_tr.htm") + ("string-upcase" "f_stg_up.htm") + ("string/=" "f_stgeq_.htm") + ("string<" "f_stgeq_.htm") + ("string<=" "f_stgeq_.htm") + ("string=" "f_stgeq_.htm") + ("string>" "f_stgeq_.htm") + ("string>=" "f_stgeq_.htm") + ("stringp" "f_stgp.htm") + ("structure" "f_docume.htm") + ("structure-class" "t_stu_cl.htm") + ("structure-object" "t_stu_ob.htm") + ("style-warning" "e_style_.htm") + ("sublis" "f_sublis.htm") + ("subseq" "f_subseq.htm") + ("subsetp" "f_subset.htm") + ("subst" "f_substc.htm") + ("subst-if" "f_substc.htm") + ("subst-if-not" "f_substc.htm") + ("substitute" "f_sbs_s.htm") + ("substitute-if" "f_sbs_s.htm") + ("substitute-if-not" "f_sbs_s.htm") + ("subtypep" "f_subtpp.htm") + ("svref" "f_svref.htm") + ("sxhash" "f_sxhash.htm") + ("symbol" "t_symbol.htm") + ("symbol-function" "f_symb_1.htm") + ("symbol-macrolet" "s_symbol.htm") + ("symbol-name" "f_symb_2.htm") + ("symbol-package" "f_symb_3.htm") + ("symbol-plist" "f_symb_4.htm") + ("symbol-value" "f_symb_5.htm") + ("symbolp" "f_symbol.htm") + ("synonym-stream" "t_syn_st.htm") + ("synonym-stream-symbol" "f_syn_st.htm") + ("t" "a_t.htm") + ("tagbody" "s_tagbod.htm") + ("tailp" "f_ldiffc.htm") + ("tan" "f_sin_c.htm") + ("tanh" "f_sinh_.htm") + ("tenth" "f_firstc.htm") + ("terpri" "f_terpri.htm") + ("the" "s_the.htm") + ("third" "f_firstc.htm") + ("throw" "s_throw.htm") + ("time" "m_time.htm") + ("trace" "m_tracec.htm") + ("translate-logical-pathname" "f_tr_log.htm") + ("translate-pathname" "f_tr_pn.htm") + ("tree-equal" "f_tree_e.htm") + ("truename" "f_tn.htm") + ("truncate" "f_floorc.htm") + ("two-way-stream" "t_two_wa.htm") + ("two-way-stream-input-stream" "f_two_wa.htm") + ("two-way-stream-output-stream" "f_two_wa.htm") + ("type" "a_type.htm") + ("type-error" "e_tp_err.htm") + ("type-error-datum" "f_tp_err.htm") + ("type-error-expected-type" "f_tp_err.htm") + ("type-of" "f_tp_of.htm") + ("typecase" "m_tpcase.htm") + ("typep" "f_typep.htm") + ("unbound-slot" "e_unboun.htm") + ("unbound-slot-instance" "f_unboun.htm") + ("unbound-variable" "e_unbo_1.htm") + ("undefined-function" "e_undefi.htm") + ("unexport" "f_unexpo.htm") + ("unintern" "f_uninte.htm") + ("union" "f_unionc.htm") + ("unless" "m_when_.htm") + ("unread-char" "f_unrd_c.htm") + ("unsigned-byte" "t_unsgn_.htm") + ("untrace" "m_tracec.htm") + ("unuse-package" "f_unuse_.htm") + ("unwind-protect" "s_unwind.htm") + ("update-instance-for-different-class" "f_update.htm") + ("update-instance-for-redefined-class" "f_upda_1.htm") + ("upgraded-array-element-type" "f_upgr_1.htm") + ("upgraded-complex-part-type" "f_upgrad.htm") + ("upper-case-p" "f_upper_.htm") + ("use-package" "f_use_pk.htm") + ("use-value" "a_use_va.htm") + ("user-homedir-pathname" "f_user_h.htm") + ("values" "a_values.htm") + ("values-list" "f_vals_l.htm") + ("variable" "f_docume.htm") + ("vector" "a_vector.htm") + ("vector-pop" "f_vec_po.htm") + ("vector-push" "f_vec_ps.htm") + ("vector-push-extend" "f_vec_ps.htm") + ("vectorp" "f_vecp.htm") + ("warn" "f_warn.htm") + ("warning" "e_warnin.htm") + ("when" "m_when_.htm") + ("wild-pathname-p" "f_wild_p.htm") + ("with-accessors" "m_w_acce.htm") + ("with-compilation-unit" "m_w_comp.htm") + ("with-condition-restarts" "m_w_cnd_.htm") + ("with-hash-table-iterator" "m_w_hash.htm") + ("with-input-from-string" "m_w_in_f.htm") + ("with-open-file" "m_w_open.htm") + ("with-open-stream" "m_w_op_1.htm") + ("with-output-to-string" "m_w_out_.htm") + ("with-package-iterator" "m_w_pkg_.htm") + ("with-simple-restart" "m_w_smp_.htm") + ("with-slots" "m_w_slts.htm") + ("with-standard-io-syntax" "m_w_std_.htm") + ("write" "f_wr_pr.htm") + ("write-byte" "f_wr_by.htm") + ("write-char" "f_wr_cha.htm") + ("write-line" "f_wr_stg.htm") + ("write-sequence" "f_wr_seq.htm") + ("write-string" "f_wr_stg.htm") + ("write-to-string" "f_wr_to_.htm") + ("y-or-n-p" "f_y_or_n.htm") + ("yes-or-no-p" "f_y_or_n.htm") + ("zerop" "f_zerop.htm")))) + +;;; Added entries for reader macros. +;;; +;;; 20090302 Tobias C Rittweiler, and Stas Boukarev + +(defvar common-lisp-hyperspec--reader-macros (make-hash-table :test #'equal)) + +;;; Data/Map_Sym.txt in does not contain entries for the reader +;;; macros. So we have to enumerate these explicitly. +(mapc (lambda (entry) + (puthash (car entry) (cadr entry) + common-lisp-hyperspec--reader-macros)) + '(("#" "02_dh.htm") + ("##" "02_dhp.htm") + ("#'" "02_dhb.htm") + ("#(" "02_dhc.htm") + ("#*" "02_dhd.htm") + ("#:" "02_dhe.htm") + ("#." "02_dhf.htm") + ("#=" "02_dho.htm") + ("#+" "02_dhq.htm") + ("#-" "02_dhr.htm") + ("#<" "02_dht.htm") + ("#A" "02_dhl.htm") + ("#B" "02_dhg.htm") + ("#C" "02_dhk.htm") + ("#O" "02_dhh.htm") + ("#P" "02_dhn.htm") + ("#R" "02_dhj.htm") + ("#S" "02_dhm.htm") + ("#X" "02_dhi.htm") + ("#\\" "02_dha.htm") + ("#|" "02_dhs.htm") + ("\"" "02_de.htm") + ("'" "02_dc.htm") + ("`" "02_df.htm") + ("," "02_dg.htm") + ("(" "02_da.htm") + (")" "02_db.htm") + (";" "02_dd.htm"))) + +(defun common-lisp-hyperspec-lookup-reader-macro (macro) + "Browse the CLHS entry for the reader-macro MACRO." + (interactive + (list + (let ((completion-ignore-case t)) + (completing-read "Look up reader-macro: " + common-lisp-hyperspec--reader-macros nil t + (common-lisp-hyperspec-reader-macro-at-point))))) + (browse-url + (concat common-lisp-hyperspec-root "Body/" + (gethash macro common-lisp-hyperspec--reader-macros)))) + +(defun common-lisp-hyperspec-reader-macro-at-point () + (let ((regexp "\\(#.?\\)\\|\\([\"',`';()]\\)")) + (when (looking-back regexp nil t) + (match-string-no-properties 0)))) + +;;; FORMAT character lookup by Frode Vatvedt Fjeld 20030902 +;;; +;;; adjusted for ILISP by Nikodemus Siivola 20030903 + +(defvar common-lisp-hyperspec-format-history nil + "History of format characters looked up in the Common Lisp HyperSpec.") + +(defun common-lisp-hyperspec-section-6.0 (indices) + (let ((string (format "%sBody/%s_" + common-lisp-hyperspec-root + (let ((base (pop indices))) + (if (< base 10) + (format "0%s" base) + base))))) + (concat string + (mapconcat (lambda (n) + (make-string 1 (+ ?a (- n 1)))) + indices + "") + ".htm"))) + +(defun common-lisp-hyperspec-section-4.0 (indices) + (let ((string (format "%sBody/sec_" + common-lisp-hyperspec-root))) + (concat string + (mapconcat (lambda (n) + (format "%d" n)) + indices + "-") + ".html"))) + +(defvar common-lisp-hyperspec-section-fun 'common-lisp-hyperspec-section-6.0) + +(defun common-lisp-hyperspec-section (indices) + (funcall common-lisp-hyperspec-section-fun indices)) + +(defvar common-lisp-hyperspec--format-characters + (make-hash-table :test 'equal)) + +(defun common-lisp-hyperspec--read-format-character () + (let ((char-at-point + (ignore-errors (char-to-string (char-after (point)))))) + (if (and char-at-point + (gethash (upcase char-at-point) + common-lisp-hyperspec--format-characters)) + char-at-point + (completing-read + "Look up format control character in Common Lisp HyperSpec: " + common-lisp-hyperspec--format-characters nil t nil + 'common-lisp-hyperspec-format-history)))) + +(defun common-lisp-hyperspec-format (character-name) + (interactive (list (common-lisp-hyperspec--read-format-character))) + (cl-maplist (lambda (entry) + (browse-url (common-lisp-hyperspec-section (car entry)))) + (or (gethash character-name + common-lisp-hyperspec--format-characters) + (error "The symbol `%s' is not defined in Common Lisp" + character-name)))) + +;;; Previously there were entries for "C" and "C: Character", +;;; which unpleasingly crowded the completion buffer, so I made +;;; it show one entry ("C - Character") only. +;;; +;;; 20100131 Tobias C Rittweiler + +(defun common-lisp-hyperspec--insert-format-directive (char section + &optional summary) + (let* ((designator (if summary (format "%s - %s" char summary) char))) + (cl-pushnew section (gethash designator + common-lisp-hyperspec--format-characters) + :test #'equal))) + +(mapc (lambda (entry) + (cl-destructuring-bind (char section &optional summary) entry + (common-lisp-hyperspec--insert-format-directive char section summary) + (when (and (= 1 (length char)) + (not (string-equal char (upcase char)))) + (common-lisp-hyperspec--insert-format-directive + (upcase char) section summary)))) + '(("c" (22 3 1 1) "Character") + ("%" (22 3 1 2) "Newline") + ("&" (22 3 1 3) "Fresh-line") + ("|" (22 3 1 4) "Page") + ("~" (22 3 1 5) "Tilde") + ("r" (22 3 2 1) "Radix") + ("d" (22 3 2 2) "Decimal") + ("b" (22 3 2 3) "Binary") + ("o" (22 3 2 4) "Octal") + ("x" (22 3 2 5) "Hexadecimal") + ("f" (22 3 3 1) "Fixed-Format Floating-Point") + ("e" (22 3 3 2) "Exponential Floating-Point") + ("g" (22 3 3 3) "General Floating-Point") + ("$" (22 3 3 4) "Monetary Floating-Point") + ("a" (22 3 4 1) "Aesthetic") + ("s" (22 3 4 2) "Standard") + ("w" (22 3 4 3) "Write") + ("_" (22 3 5 1) "Conditional Newline") + ("<" (22 3 5 2) "Logical Block") + ("i" (22 3 5 3) "Indent") + ("/" (22 3 5 4) "Call Function") + ("t" (22 3 6 1) "Tabulate") + ("<" (22 3 6 2) "Justification") + (">" (22 3 6 3) "End of Justification") + ("*" (22 3 7 1) "Go-To") + ("[" (22 3 7 2) "Conditional Expression") + ("]" (22 3 7 3) "End of Conditional Expression") + ("{" (22 3 7 4) "Iteration") + ("}" (22 3 7 5) "End of Iteration") + ("?" (22 3 7 6) "Recursive Processing") + ("(" (22 3 8 1) "Case Conversion") + (")" (22 3 8 2) "End of Case Conversion") + ("p" (22 3 8 3) "Plural") + (";" (22 3 9 1) "Clause Separator") + ("^" (22 3 9 2) "Escape Upward") + ("Newline: Ignored Newline" (22 3 9 3)) + ("Nesting of FORMAT Operations" (22 3 10 1)) + ("Missing and Additional FORMAT Arguments" (22 3 10 2)) + ("Additional FORMAT Parameters" (22 3 10 3)))) + + +;;;; Glossary + +(defvar common-lisp-hyperspec-glossary-function 'common-lisp-glossary-6.0 + "Function that creates a URL for a glossary term.") + +(define-obsolete-variable-alias 'common-lisp-glossary-fun + 'common-lisp-hyperspec-glossary-function) + +(defvar common-lisp-hyperspec--glossary-terms (make-hash-table :test #'equal) + "Collection of glossary terms and relative URLs.") + +;;; Functions + +;;; The functions below are used to collect glossary terms and page anchors +;;; from CLHS. They are commented out because they are not needed unless the +;;; list of terms/anchors need to be updated. + +;; (defun common-lisp-hyperspec-glossary-pages () +;; "List of CLHS glossary pages." +;; (mapcar (lambda (end) +;; (format "%sBody/26_glo_%s.htm" +;; common-lisp-hyperspec-root +;; end)) +;; (cons "9" (mapcar #'char-to-string +;; (number-sequence ?a ?z))))) + +;; (defun common-lisp-hyperspec-glossary-download () +;; "Download CLHS glossary pages to temporary files and return a +;; list of file names." +;; (mapcar (lambda (url) +;; (url-file-local-copy url)) +;; (common-lisp-hyperspec-glossary-pages))) + +;; (defun common-lisp-hyperspec-glossary-entries (file) +;; "Given a CLHS glossary file FILE, return a list of +;; term-anchor pairs. + +;; Term is the glossary term and anchor is the term's anchor on the +;; page." +;; (let (entries) +;; (save-excursion +;; (set-buffer (find-file-noselect file)) +;; (goto-char (point-min)) +;; (while (search-forward-regexp "\\(.*?\\)" nil t) +;; (setq entries (cons (list (match-string-no-properties 2) +;; (match-string-no-properties 1)) +;; entries)))) +;; (sort entries (lambda (a b) +;; (string< (car a) (car b)))))) + +;; ;; Add glossary terms by downloading and parsing glossary pages from CLHS +;; (mapc (lambda (entry) +;; (puthash (car entry) (cadr entry) +;; common-lisp-hyperspec--glossary-terms)) +;; (cl-reduce (lambda (a b) +;; (append a b)) +;; (mapcar #'common-lisp-hyperspec-glossary-entries +;; (common-lisp-hyperspec-glossary-download)))) + +;; Add glossary entries to the master hash table +(mapc (lambda (entry) + (puthash (car entry) (cadr entry) + common-lisp-hyperspec--glossary-terms)) + '(("()" "OPCP") + ("absolute" "absolute") + ("access" "access") + ("accessibility" "accessibility") + ("accessible" "accessible") + ("accessor" "accessor") + ("active" "active") + ("actual adjustability" "actual_adjustability") + ("actual argument" "actual_argument") + ("actual array element type" "actual_array_element_type") + ("actual complex part type" "actual_complex_part_type") + ("actual parameter" "actual_parameter") + ("actually adjustable" "actually_adjustable") + ("adjustability" "adjustability") + ("adjustable" "adjustable") + ("after method" "after_method") + ("alist" "alist") + ("alphabetic" "alphabetic") + ("alphanumeric" "alphanumeric") + ("ampersand" "ampersand") + ("anonymous" "anonymous") + ("apparently uninterned" "apparently_uninterned") + ("applicable" "applicable") + ("applicable handler" "applicable_handler") + ("applicable method" "applicable_method") + ("applicable restart" "applicable_restart") + ("apply" "apply") + ("argument" "argument") + ("argument evaluation order" "argument_evaluation_order") + ("argument precedence order" "argument_precedence_order") + ("around method" "around_method") + ("array" "array") + ("array element type" "array_element_type") + ("array total size" "array_total_size") + ("assign" "assign") + ("association list" "association_list") + ("asterisk" "asterisk") + ("at-sign" "at-sign") + ("atom" "atom") + ("atomic" "atomic") + ("atomic type specifier" "atomic_type_specifier") + ("attribute" "attribute") + ("aux variable" "aux_variable") + ("auxiliary method" "auxiliary_method") + ("backquote" "backquote") + ("backslash" "backslash") + ("base character" "base_character") + ("base string" "base_string") + ("before method" "before_method") + ("bidirectional" "bidirectional") + ("binary" "binary") + ("bind" "bind") + ("binding" "binding") + ("bit" "bit") + ("bit array" "bit_array") + ("bit vector" "bit_vector") + ("bit-wise logical operation specifier" "bit-wise_logical_operation_specifier") + ("block" "block") + ("block tag" "block_tag") + ("boa lambda list" "boa_lambda_list") + ("body parameter" "body_parameter") + ("boolean" "boolean") + ("boolean equivalent" "boolean_equivalent") + ("bound" "bound") + ("bound declaration" "bound_declaration") + ("bounded" "bounded") + ("bounding index" "bounding_index") + ("bounding index designator" "bounding_index_designator") + ("break loop" "break_loop") + ("broadcast stream" "broadcast_stream") + ("built-in class" "built-in_class") + ("built-in type" "built-in_type") + ("byte" "byte") + ("byte specifier" "byte_specifier") + ("cadr" "cadr") + ("call" "call") + ("captured initialization form" "captured_initialization_form") + ("car" "car") + ("case" "case") + ("case sensitivity mode" "case_sensitivity_mode") + ("catch" "catch") + ("catch tag" "catch_tag") + ("cddr" "cddr") + ("cdr" "cdr") + ("cell" "cell") + ("character" "character") + ("character code" "character_code") + ("character designator" "character_designator") + ("circular" "circular") + ("circular list" "circular_list") + ("class" "class") + ("class designator" "class_designator") + ("class precedence list" "class_precedence_list") + ("close" "close") + ("closed" "closed") + ("closure" "closure") + ("coalesce" "coalesce") + ("code" "code") + ("coerce" "coerce") + ("colon" "colon") + ("comma" "comma") + ("compilation" "compilation") + ("compilation environment" "compilation_environment") + ("compilation unit" "compilation_unit") + ("compile" "compile") + ("compile time" "compile_time") + ("compile-time definition" "compile-time_definition") + ("compiled code" "compiled_code") + ("compiled file" "compiled_file") + ("compiled function" "compiled_function") + ("compiler" "compiler") + ("compiler macro" "compiler_macro") + ("compiler macro expansion" "compiler_macro_expansion") + ("compiler macro form" "compiler_macro_form") + ("compiler macro function" "compiler_macro_function") + ("complex" "complex") + ("complex float" "complex_float") + ("complex part type" "complex_part_type") + ("complex rational" "complex_rational") + ("complex single float" "complex_single_float") + ("composite stream" "composite_stream") + ("compound form" "compound_form") + ("compound type specifier" "compound_type_specifier") + ("concatenated stream" "concatenated_stream") + ("condition" "condition") + ("condition designator" "condition_designator") + ("condition handler" "condition_handler") + ("condition reporter" "condition_reporter") + ("conditional newline" "conditional_newline") + ("conformance" "conformance") + ("conforming code" "conforming_code") + ("conforming implementation" "conforming_implementation") + ("conforming processor" "conforming_processor") + ("conforming program" "conforming_program") + ("congruent" "congruent") + ("cons" "cons") + ("constant" "constant") + ("constant form" "constant_form") + ("constant object" "constant_object") + ("constant variable" "constant_variable") + ("constituent" "constituent") + ("constituent trait" "constituent_trait") + ("constructed stream" "constructed_stream") + ("contagion" "contagion") + ("continuable" "continuable") + ("control form" "control_form") + ("copy" "copy") + ("correctable" "correctable") + ("current input base" "current_input_base") + ("current logical block" "current_logical_block") + ("current output base" "current_output_base") + ("current package" "current_package") + ("current pprint dispatch table" "current_pprint_dispatch_table") + ("current random state" "current_random_state") + ("current readtable" "current_readtable") + ("data type" "data_type") + ("debug I/O" "debug_iSLo") + ("debugger" "debugger") + ("declaration" "declaration") + ("declaration identifier" "declaration_identifier") + ("declaration specifier" "declaration_specifier") + ("declare" "declare") + ("decline" "decline") + ("decoded time" "decoded_time") + ("default method" "default_method") + ("defaulted initialization argument list" "defaulted_initialization_argument_list") + ("define-method-combination arguments lambda list" "define-method-combination_arguments_lambda_list") + ("define-modify-macro lambda list" "define-modify-macro_lambda_list") + ("defined name" "defined_name") + ("defining form" "defining_form") + ("defsetf lambda list" "defsetf_lambda_list") + ("deftype lambda list" "deftype_lambda_list") + ("denormalized" "denormalized") + ("derived type" "derived_type") + ("derived type specifier" "derived_type_specifier") + ("designator" "designator") + ("destructive" "destructive") + ("destructuring lambda list" "destructuring_lambda_list") + ("different" "different") + ("digit" "digit") + ("dimension" "dimension") + ("direct instance" "direct_instance") + ("direct subclass" "direct_subclass") + ("direct superclass" "direct_superclass") + ("disestablish" "disestablish") + ("disjoint" "disjoint") + ("dispatching macro character" "dispatching_macro_character") + ("displaced array" "displaced_array") + ("distinct" "distinct") + ("documentation string" "documentation_string") + ("dot" "dot") + ("dotted list" "dotted_list") + ("dotted pair" "dotted_pair") + ("double float" "double_float") + ("double-quote" "double-quote") + ("dynamic binding" "dynamic_binding") + ("dynamic environment" "dynamic_environment") + ("dynamic extent" "dynamic_extent") + ("dynamic scope" "dynamic_scope") + ("dynamic variable" "dynamic_variable") + ("echo stream" "echo_stream") + ("effective method" "effective_method") + ("element" "element") + ("element type" "element_type") + ("em" "em") + ("empty list" "empty_list") + ("empty type" "empty_type") + ("end of file" "end_of_file") + ("environment" "environment") + ("environment object" "environment_object") + ("environment parameter" "environment_parameter") + ("error" "error") + ("error output" "error_output") + ("escape" "escape") + ("establish" "establish") + ("evaluate" "evaluate") + ("evaluation" "evaluation") + ("evaluation environment" "evaluation_environment") + ("execute" "execute") + ("execution time" "execution_time") + ("exhaustive partition" "exhaustive_partition") + ("exhaustive union" "exhaustive_union") + ("exit point" "exit_point") + ("explicit return" "explicit_return") + ("explicit use" "explicit_use") + ("exponent marker" "exponent_marker") + ("export" "export") + ("exported" "exported") + ("expressed adjustability" "expressed_adjustability") + ("expressed array element type" "expressed_array_element_type") + ("expressed complex part type" "expressed_complex_part_type") + ("expression" "expression") + ("expressly adjustable" "expressly_adjustable") + ("extended character" "extended_character") + ("extended function designator" "extended_function_designator") + ("extended lambda list" "extended_lambda_list") + ("extension" "extension") + ("extent" "extent") + ("external file format" "external_file_format") + ("external file format designator" "external_file_format_designator") + ("external symbol" "external_symbol") + ("externalizable object" "externalizable_object") + ("false" "false") + ("fbound" "fbound") + ("feature" "feature") + ("feature expression" "feature_expression") + ("features list" "features_list") + ("file" "file") + ("file compiler" "file_compiler") + ("file position" "file_position") + ("file position designator" "file_position_designator") + ("file stream" "file_stream") + ("file system" "file_system") + ("filename" "filename") + ("fill pointer" "fill_pointer") + ("finite" "finite") + ("fixnum" "fixnum") + ("float" "float") + ("for-value" "for-value") + ("form" "form") + ("formal argument" "formal_argument") + ("formal parameter" "formal_parameter") + ("format" "format") + ("format argument" "format_argument") + ("format control" "format_control") + ("format directive" "format_directive") + ("format string" "format_string") + ("free declaration" "free_declaration") + ("fresh" "fresh") + ("freshline" "freshline") + ("funbound" "funbound") + ("function" "function") + ("function block name" "function_block_name") + ("function cell" "function_cell") + ("function designator" "function_designator") + ("function form" "function_form") + ("function name" "function_name") + ("functional evaluation" "functional_evaluation") + ("functional value" "functional_value") + ("further compilation" "further_compilation") + ("general" "general") + ("generalized boolean" "generalized_boolean") + ("generalized instance" "generalized_instance") + ("generalized reference" "generalized_reference") + ("generalized synonym stream" "generalized_synonym_stream") + ("generic function" "generic_function") + ("generic function lambda list" "generic_function_lambda_list") + ("gensym" "gensym") + ("global declaration" "global_declaration") + ("global environment" "global_environment") + ("global variable" "global_variable") + ("glyph" "glyph") + ("go" "go") + ("go point" "go_point") + ("go tag" "go_tag") + ("graphic" "graphic") + ("handle" "handle") + ("handler" "handler") + ("hash table" "hash_table") + ("home package" "home_package") + ("I/O customization variable" "iSLo_customization_variable") + ("identical" "identical") + ("identifier" "identifier") + ("immutable" "immutable") + ("implementation" "implementation") + ("implementation limit" "implementation_limit") + ("implementation-defined" "implementation-defined") + ("implementation-dependent" "implementation-dependent") + ("implementation-independent" "implementation-independent") + ("implicit block" "implicit_block") + ("implicit compilation" "implicit_compilation") + ("implicit progn" "implicit_progn") + ("implicit tagbody" "implicit_tagbody") + ("import" "import") + ("improper list" "improper_list") + ("inaccessible" "inaccessible") + ("indefinite extent" "indefinite_extent") + ("indefinite scope" "indefinite_scope") + ("indicator" "indicator") + ("indirect instance" "indirect_instance") + ("inherit" "inherit") + ("initial pprint dispatch table" "initial_pprint_dispatch_table") + ("initial readtable" "initial_readtable") + ("initialization argument list" "initialization_argument_list") + ("initialization form" "initialization_form") + ("input" "input") + ("instance" "instance") + ("integer" "integer") + ("interactive stream" "interactive_stream") + ("intern" "intern") + ("internal symbol" "internal_symbol") + ("internal time" "internal_time") + ("internal time unit" "internal_time_unit") + ("interned" "interned") + ("interpreted function" "interpreted_function") + ("interpreted implementation" "interpreted_implementation") + ("interval designator" "interval_designator") + ("invalid" "invalid") + ("iteration form" "iteration_form") + ("iteration variable" "iteration_variable") + ("key" "key") + ("keyword" "keyword") + ("keyword parameter" "keyword_parameter") + ("keyword/value pair" "keywordSLvalue_pair") + ("Lisp image" "lisp_image") + ("Lisp printer" "lisp_printer") + ("Lisp read-eval-print loop" "lisp_read-eval-print_loop") + ("Lisp reader" "lisp_reader") + ("lambda combination" "lambda_combination") + ("lambda expression" "lambda_expression") + ("lambda form" "lambda_form") + ("lambda list" "lambda_list") + ("lambda list keyword" "lambda_list_keyword") + ("lambda variable" "lambda_variable") + ("leaf" "leaf") + ("leap seconds" "leap_seconds") + ("left-parenthesis" "left-parenthesis") + ("length" "length") + ("lexical binding" "lexical_binding") + ("lexical closure" "lexical_closure") + ("lexical environment" "lexical_environment") + ("lexical scope" "lexical_scope") + ("lexical variable" "lexical_variable") + ("list" "list") + ("list designator" "list_designator") + ("list structure" "list_structure") + ("literal" "literal") + ("load" "load") + ("load time" "load_time") + ("load time value" "load_time_value") + ("loader" "loader") + ("local declaration" "local_declaration") + ("local precedence order" "local_precedence_order") + ("local slot" "local_slot") + ("logical block" "logical_block") + ("logical host" "logical_host") + ("logical host designator" "logical_host_designator") + ("logical pathname" "logical_pathname") + ("long float" "long_float") + ("loop keyword" "loop_keyword") + ("lowercase" "lowercase") + ("Metaobject Protocol" "metaobject_protocol") + ("macro" "macro") + ("macro character" "macro_character") + ("macro expansion" "macro_expansion") + ("macro form" "macro_form") + ("macro function" "macro_function") + ("macro lambda list" "macro_lambda_list") + ("macro name" "macro_name") + ("macroexpand hook" "macroexpand_hook") + ("mapping" "mapping") + ("metaclass" "metaclass") + ("method" "method") + ("method combination" "method_combination") + ("method-defining form" "method-defining_form") + ("method-defining operator" "method-defining_operator") + ("minimal compilation" "minimal_compilation") + ("modified lambda list" "modified_lambda_list") + ("most recent" "most_recent") + ("multiple escape" "multiple_escape") + ("multiple values" "multiple_values") + ("name" "name") + ("named constant" "named_constant") + ("namespace" "namespace") + ("namestring" "namestring") + ("newline" "newline") + ("next method" "next_method") + ("nickname" "nickname") + ("nil" "nil") + ("non-atomic" "non-atomic") + ("non-constant variable" "non-constant_variable") + ("non-correctable" "non-correctable") + ("non-empty" "non-empty") + ("non-generic function" "non-generic_function") + ("non-graphic" "non-graphic") + ("non-list" "non-list") + ("non-local exit" "non-local_exit") + ("non-nil" "non-nil") + ("non-null lexical environment" "non-null_lexical_environment") + ("non-simple" "non-simple") + ("non-terminating" "non-terminating") + ("non-top-level form" "non-top-level_form") + ("normal return" "normal_return") + ("normalized" "normalized") + ("null" "null") + ("null lexical environment" "null_lexical_environment") + ("number" "number") + ("numeric" "numeric") + ("object" "object") + ("object-traversing" "object-traversing") + ("open" "open") + ("operator" "operator") + ("optimize quality" "optimize_quality") + ("optional parameter" "optional_parameter") + ("ordinary function" "ordinary_function") + ("ordinary lambda list" "ordinary_lambda_list") + ("otherwise inaccessible part" "otherwise_inaccessible_part") + ("output" "output") + ("package" "package") + ("package cell" "package_cell") + ("package designator" "package_designator") + ("package marker" "package_marker") + ("package prefix" "package_prefix") + ("package registry" "package_registry") + ("pairwise" "pairwise") + ("parallel" "parallel") + ("parameter" "parameter") + ("parameter specializer" "parameter_specializer") + ("parameter specializer name" "parameter_specializer_name") + ("pathname" "pathname") + ("pathname designator" "pathname_designator") + ("physical pathname" "physical_pathname") + ("place" "place") + ("plist" "plist") + ("portable" "portable") + ("potential copy" "potential_copy") + ("potential number" "potential_number") + ("pprint dispatch table" "pprint_dispatch_table") + ("predicate" "predicate") + ("present" "present") + ("pretty print" "pretty_print") + ("pretty printer" "pretty_printer") + ("pretty printing stream" "pretty_printing_stream") + ("primary method" "primary_method") + ("primary value" "primary_value") + ("principal" "principal") + ("print name" "print_name") + ("printer control variable" "printer_control_variable") + ("printer escaping" "printer_escaping") + ("printing" "printing") + ("process" "process") + ("processor" "processor") + ("proclaim" "proclaim") + ("proclamation" "proclamation") + ("prog tag" "prog_tag") + ("program" "program") + ("programmer" "programmer") + ("programmer code" "programmer_code") + ("proper list" "proper_list") + ("proper name" "proper_name") + ("proper sequence" "proper_sequence") + ("proper subtype" "proper_subtype") + ("property" "property") + ("property indicator" "property_indicator") + ("property list" "property_list") + ("property value" "property_value") + ("purports to conform" "purports_to_conform") + ("qualified method" "qualified_method") + ("qualifier" "qualifier") + ("query I/O" "query_iSLo") + ("quoted object" "quoted_object") + ("radix" "radix") + ("random state" "random_state") + ("rank" "rank") + ("ratio" "ratio") + ("ratio marker" "ratio_marker") + ("rational" "rational") + ("read" "read") + ("readably" "readably") + ("reader" "reader") + ("reader macro" "reader_macro") + ("reader macro function" "reader_macro_function") + ("readtable" "readtable") + ("readtable case" "readtable_case") + ("readtable designator" "readtable_designator") + ("recognizable subtype" "recognizable_subtype") + ("reference" "reference") + ("registered package" "registered_package") + ("relative" "relative") + ("repertoire" "repertoire") + ("report" "report") + ("report message" "report_message") + ("required parameter" "required_parameter") + ("rest list" "rest_list") + ("rest parameter" "rest_parameter") + ("restart" "restart") + ("restart designator" "restart_designator") + ("restart function" "restart_function") + ("return" "return") + ("return value" "return_value") + ("right-parenthesis" "right-parenthesis") + ("run time" "run_time") + ("run-time compiler" "run-time_compiler") + ("run-time definition" "run-time_definition") + ("run-time environment" "run-time_environment") + ("safe" "safe") + ("safe call" "safe_call") + ("same" "same") + ("satisfy the test" "satisfy_the_test") + ("scope" "scope") + ("script" "script") + ("secondary value" "secondary_value") + ("section" "section") + ("self-evaluating object" "self-evaluating_object") + ("semi-standard" "semi-standard") + ("semicolon" "semicolon") + ("sequence" "sequence") + ("sequence function" "sequence_function") + ("sequential" "sequential") + ("sequentially" "sequentially") + ("serious condition" "serious_condition") + ("session" "session") + ("set" "set") + ("setf expander" "setf_expander") + ("setf expansion" "setf_expansion") + ("setf function" "setf_function") + ("setf function name" "setf_function_name") + ("shadow" "shadow") + ("shadowing symbol" "shadowing_symbol") + ("shadowing symbols list" "shadowing_symbols_list") + ("shared slot" "shared_slot") + ("sharpsign" "sharpsign") + ("short float" "short_float") + ("sign" "sign") + ("signal" "signal") + ("signature" "signature") + ("similar" "similar") + ("similarity" "similarity") + ("simple" "simple") + ("simple array" "simple_array") + ("simple bit array" "simple_bit_array") + ("simple bit vector" "simple_bit_vector") + ("simple condition" "simple_condition") + ("simple general vector" "simple_general_vector") + ("simple string" "simple_string") + ("simple vector" "simple_vector") + ("single escape" "single_escape") + ("single float" "single_float") + ("single-quote" "single-quote") + ("singleton" "singleton") + ("situation" "situation") + ("slash" "slash") + ("slot" "slot") + ("slot specifier" "slot_specifier") + ("source code" "source_code") + ("source file" "source_file") + ("space" "space") + ("special form" "special_form") + ("special operator" "special_operator") + ("special variable" "special_variable") + ("specialize" "specialize") + ("specialized" "specialized") + ("specialized lambda list" "specialized_lambda_list") + ("spreadable argument list designator" "spreadable_argument_list_designator") + ("stack allocate" "stack_allocate") + ("stack-allocated" "stack-allocated") + ("standard character" "standard_character") + ("standard class" "standard_class") + ("standard generic function" "standard_generic_function") + ("standard input" "standard_input") + ("standard method combination" "standard_method_combination") + ("standard object" "standard_object") + ("standard output" "standard_output") + ("standard pprint dispatch table" "standard_pprint_dispatch_table") + ("standard readtable" "standard_readtable") + ("standard syntax" "standard_syntax") + ("standardized" "standardized") + ("startup environment" "startup_environment") + ("step" "step") + ("stream" "stream") + ("stream associated with a file" "stream_associated_with_a_file") + ("stream designator" "stream_designator") + ("stream element type" "stream_element_type") + ("stream variable" "stream_variable") + ("stream variable designator" "stream_variable_designator") + ("string" "string") + ("string designator" "string_designator") + ("string equal" "string_equal") + ("string stream" "string_stream") + ("structure" "structure") + ("structure class" "structure_class") + ("structure name" "structure_name") + ("style warning" "style_warning") + ("subclass" "subclass") + ("subexpression" "subexpression") + ("subform" "subform") + ("subrepertoire" "subrepertoire") + ("subtype" "subtype") + ("superclass" "superclass") + ("supertype" "supertype") + ("supplied-p parameter" "supplied-p_parameter") + ("symbol" "symbol") + ("symbol macro" "symbol_macro") + ("synonym stream" "synonym_stream") + ("synonym stream symbol" "synonym_stream_symbol") + ("syntax type" "syntax_type") + ("system class" "system_class") + ("system code" "system_code") + ("t" "t") + ("tag" "tag") + ("tail" "tail") + ("target" "target") + ("terminal I/O" "terminal_iSLo") + ("terminating" "terminating") + ("tertiary value" "tertiary_value") + ("throw" "throw") + ("tilde" "tilde") + ("time" "time") + ("time zone" "time_zone") + ("token" "token") + ("top level form" "top_level_form") + ("trace output" "trace_output") + ("tree" "tree") + ("tree structure" "tree_structure") + ("true" "true") + ("truename" "truename") + ("two-way stream" "two-way_stream") + ("type" "type") + ("type declaration" "type_declaration") + ("type equivalent" "type_equivalent") + ("type expand" "type_expand") + ("type specifier" "type_specifier") + ("unbound" "unbound") + ("unbound variable" "unbound_variable") + ("undefined function" "undefined_function") + ("unintern" "unintern") + ("uninterned" "uninterned") + ("universal time" "universal_time") + ("unqualified method" "unqualified_method") + ("unregistered package" "unregistered_package") + ("unsafe" "unsafe") + ("unsafe call" "unsafe_call") + ("upgrade" "upgrade") + ("upgraded array element type" "upgraded_array_element_type") + ("upgraded complex part type" "upgraded_complex_part_type") + ("uppercase" "uppercase") + ("use" "use") + ("use list" "use_list") + ("user" "user") + ("valid array dimension" "valid_array_dimension") + ("valid array index" "valid_array_index") + ("valid array row-major index" "valid_array_row-major_index") + ("valid fill pointer" "valid_fill_pointer") + ("valid logical pathname host" "valid_logical_pathname_host") + ("valid pathname device" "valid_pathname_device") + ("valid pathname directory" "valid_pathname_directory") + ("valid pathname host" "valid_pathname_host") + ("valid pathname name" "valid_pathname_name") + ("valid pathname type" "valid_pathname_type") + ("valid pathname version" "valid_pathname_version") + ("valid physical pathname host" "valid_physical_pathname_host") + ("valid sequence index" "valid_sequence_index") + ("value" "value") + ("value cell" "value_cell") + ("variable" "variable") + ("vector" "vector") + ("vertical-bar" "vertical-bar") + ("whitespace" "whitespace") + ("wild" "wild") + ("write" "write") + ("writer" "writer") + ("yield" "yield"))) + +(defun common-lisp-hyperspec-glossary-term (term) + "View the definition of TERM on the Common Lisp Hyperspec." + (interactive + (list + (completing-read "Look up glossary term: " + common-lisp-hyperspec--glossary-terms nil t))) + (browse-url (funcall common-lisp-hyperspec-glossary-function term))) + +(defun common-lisp-glossary-6.0 (term) + "Get a URL for a glossary term TERM." + (let ((anchor (gethash term common-lisp-hyperspec--glossary-terms))) + (if (not anchor) + (message "Unknown glossary term: %s" term) + (format "%sBody/26_glo_%s.htm#%s" + common-lisp-hyperspec-root + (let ((char (string-to-char term))) + (if (and (<= ?a char) + (<= char ?z)) + (make-string 1 char) + "9")) + anchor)))) + +;; Tianxiang Xiong 20151229 +;; Is this function necessary? The link does created does not work. +(defun common-lisp-glossary-4.0 (string) + (format "%sBody/glo_%s.html#%s" + common-lisp-hyperspec-root + (let ((char (string-to-char string))) + (if (and (<= ?a char) + (<= char ?z)) + (make-string 1 char) + "9")) + (subst-char-in-string ?\ ?_ string))) + + +;;;; Issuex + +;; FIXME: the issuex stuff is not used +(defvar common-lisp-hyperspec-issuex-table nil + "The HyperSpec IssueX table file. If you copy the HyperSpec to your +local system, set this variable to the location of the Issue +cross-references table which is usually \"Map_IssX.txt\" or +\"Issue-Cross-Refs.text\".") + +(defvar common-lisp-hyperspec--issuex-symbols + (make-hash-table :test 'equal)) + +(mapc + (lambda (entry) + (puthash (car entry) (cadr entry) common-lisp-hyperspec--issuex-symbols)) + (if common-lisp-hyperspec-issuex-table + (common-lisp-hyperspec--parse-map-file + common-lisp-hyperspec-issuex-table) + '(("&environment-binding-order:first" "iss001.htm") + ("access-error-name" "iss002.htm") + ("adjust-array-displacement" "iss003.htm") + ("adjust-array-fill-pointer" "iss004.htm") + ("adjust-array-not-adjustable:implicit-copy" "iss005.htm") + ("allocate-instance:add" "iss006.htm") + ("allow-local-inline:inline-notinline" "iss007.htm") + ("allow-other-keys-nil:permit" "iss008.htm") + ("aref-1d" "iss009.htm") + ("argument-mismatch-error-again:consistent" "iss010.htm") + ("argument-mismatch-error-moon:fix" "iss011.htm") + ("argument-mismatch-error:more-clarifications" "iss012.htm") + ("arguments-underspecified:specify" "iss013.htm") + ("array-dimension-limit-implications:all-fixnum" "iss014.htm") + ("array-type-element-type-semantics:unify-upgrading" "iss015.htm") + ("assert-error-type:error" "iss016.htm") + ("assoc-rassoc-if-key" "iss017.htm") + ("assoc-rassoc-if-key:yes" "iss018.htm") + ("boa-aux-initialization:error-on-read" "iss019.htm") + ("break-on-warnings-obsolete:remove" "iss020.htm") + ("broadcast-stream-return-values:clarify-minimally" "iss021.htm") + ("butlast-negative:should-signal" "iss022.htm") + ("change-class-initargs:permit" "iss023.htm") + ("char-name-case:x3j13-mar-91" "iss024.htm") + ("character-loose-ends:fix" "iss025.htm") + ("character-proposal:2" "iss026.htm") + ("character-proposal:2-1-1" "iss027.htm") + ("character-proposal:2-1-2" "iss028.htm") + ("character-proposal:2-2-1" "iss029.htm") + ("character-proposal:2-3-1" "iss030.htm") + ("character-proposal:2-3-2" "iss031.htm") + ("character-proposal:2-3-3" "iss032.htm") + ("character-proposal:2-3-4" "iss033.htm") + ("character-proposal:2-3-5" "iss034.htm") + ("character-proposal:2-3-6" "iss035.htm") + ("character-proposal:2-4-1" "iss036.htm") + ("character-proposal:2-4-2" "iss037.htm") + ("character-proposal:2-4-3" "iss038.htm") + ("character-proposal:2-5-2" "iss039.htm") + ("character-proposal:2-5-6" "iss040.htm") + ("character-proposal:2-5-7" "iss041.htm") + ("character-proposal:2-6-1" "iss042.htm") + ("character-proposal:2-6-2" "iss043.htm") + ("character-proposal:2-6-3" "iss044.htm") + ("character-proposal:2-6-5" "iss045.htm") + ("character-vs-char:less-inconsistent-short" "iss046.htm") + ("class-object-specializer:affirm" "iss047.htm") + ("clos-conditions-again:allow-subset" "iss048.htm") + ("clos-conditions:integrate" "iss049.htm") + ("clos-error-checking-order:no-applicable-method-first" "iss050.htm") + ("clos-macro-compilation:minimal" "iss051.htm") + ("close-constructed-stream:argument-stream-only" "iss052.htm") + ("closed-stream-operations:allow-inquiry" "iss053.htm") + ("coercing-setf-name-to-function:all-function-names" "iss054.htm") + ("colon-number" "iss055.htm") + ("common-features:specify" "iss056.htm") + ("common-type:remove" "iss057.htm") + ("compile-argument-problems-again:fix" "iss058.htm") + ("compile-file-handling-of-top-level-forms:clarify" "iss059.htm") + ("compile-file-output-file-defaults:input-file" "iss060.htm") + ("compile-file-package" "iss061.htm") + ("compile-file-pathname-arguments:make-consistent" "iss062.htm") + ("compile-file-symbol-handling:new-require-consistency" "iss063.htm") + ("compiled-function-requirements:tighten" "iss064.htm") + ("compiler-diagnostics:use-handler" "iss065.htm") + ("compiler-let-confusion:eliminate" "iss066.htm") + ("compiler-verbosity:like-load" "iss067.htm") + ("compiler-warning-stream" "iss068.htm") + ("complex-atan-branch-cut:tweak" "iss069.htm") + ("complex-atanh-bogus-formula:tweak-more" "iss070.htm") + ("complex-rational-result:extend" "iss071.htm") + ("compute-applicable-methods:generic" "iss072.htm") + ("concatenate-sequence:signal-error" "iss073.htm") + ("condition-accessors-setfable:no" "iss074.htm") + ("condition-restarts:buggy" "iss075.htm") + ("condition-restarts:permit-association" "iss076.htm") + ("condition-slots:hidden" "iss077.htm") + ("cons-type-specifier:add" "iss078.htm") + ("constant-circular-compilation:yes" "iss079.htm") + ("constant-collapsing:generalize" "iss080.htm") + ("constant-compilable-types:specify" "iss081.htm") + ("constant-function-compilation:no" "iss082.htm") + ("constant-modification:disallow" "iss083.htm") + ("constantp-definition:intentional" "iss084.htm") + ("constantp-environment:add-arg" "iss085.htm") + ("contagion-on-numerical-comparisons:transitive" "iss086.htm") + ("copy-symbol-copy-plist:copy-list" "iss087.htm") + ("copy-symbol-print-name:equal" "iss088.htm") + ("data-io:add-support" "iss089.htm") + ("data-types-hierarchy-underspecified" "iss090.htm") + ("debugger-hook-vs-break:clarify" "iss091.htm") + ("declaration-scope:no-hoisting" "iss092.htm") + ("declare-array-type-element-references:restrictive" "iss093.htm") + ("declare-function-ambiguity:delete-ftype-abbreviation" "iss094.htm") + ("declare-macros:flush" "iss095.htm") + ("declare-type-free:lexical" "iss096.htm") + ("decls-and-doc" "iss097.htm") + ("decode-universal-time-daylight:like-encode" "iss098.htm") + ("defconstant-special:no" "iss099.htm") + ("defgeneric-declare:allow-multiple" "iss100.htm") + ("define-compiler-macro:x3j13-nov89" "iss101.htm") + ("define-condition-syntax:\ +incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm") + ("define-method-combination-behavior:clarify" "iss103.htm") + ("defining-macros-non-top-level:allow" "iss104.htm") + ("defmacro-block-scope:excludes-bindings" "iss105.htm") + ("defmacro-lambda-list:tighten-description" "iss106.htm") + ("defmethod-declaration-scope:corresponds-to-bindings" "iss107.htm") + ("defpackage:addition" "iss108.htm") + ("defstruct-constructor-key-mixture:allow-key" "iss109.htm") + ("defstruct-constructor-options:explicit" "iss110.htm") + ("defstruct-constructor-slot-variables:not-bound" "iss111.htm") + ("defstruct-copier-argument-type:restrict" "iss112.htm") + ("defstruct-copier:argument-type" "iss113.htm") + ("defstruct-default-value-evaluation:iff-needed" "iss114.htm") + ("defstruct-include-deftype:explicitly-undefined" "iss115.htm") + ("defstruct-print-function-again:x3j13-mar-93" "iss116.htm") + ("defstruct-print-function-inheritance:yes" "iss117.htm") + ("defstruct-redefinition:error" "iss118.htm") + ("defstruct-slots-constraints-name:duplicates-error" "iss119.htm") + ("defstruct-slots-constraints-number" "iss120.htm") + ("deftype-destructuring:yes" "iss121.htm") + ("deftype-key:allow" "iss122.htm") + ("defvar-documentation:unevaluated" "iss123.htm") + ("defvar-init-time:not-delayed" "iss124.htm") + ("defvar-initialization:conservative" "iss125.htm") + ("deprecation-position:limited" "iss126.htm") + ("describe-interactive:no" "iss127.htm") + ("describe-underspecified:describe-object" "iss128.htm") + ("destructive-operations:specify" "iss129.htm") + ("destructuring-bind:new-macro" "iss130.htm") + ("disassemble-side-effect:do-not-install" "iss131.htm") + ("displaced-array-predicate:add" "iss132.htm") + ("do-symbols-block-scope:entire-form" "iss133.htm") + ("do-symbols-duplicates" "iss134.htm") + ("documentation-function-bugs:fix" "iss135.htm") + ("documentation-function-tangled:require-argument" "iss136.htm") + ("dotimes-ignore:x3j13-mar91" "iss137.htm") + ("dotted-list-arguments:clarify" "iss138.htm") + ("dotted-macro-forms:allow" "iss139.htm") + ("dribble-technique" "iss140.htm") + ("dynamic-extent-function:extend" "iss141.htm") + ("dynamic-extent:new-declaration" "iss142.htm") + ("equal-structure:maybe-status-quo" "iss143.htm") + ("error-terminology-warning:might" "iss144.htm") + ("eval-other:self-evaluate" "iss145.htm") + ("eval-top-level:load-like-compile-file" "iss146.htm") + ("eval-when-non-top-level:generalize-eval-new-keywords" "iss147.htm") + ("eval-when-obsolete-keywords:x3j13-mar-1993" "iss148.htm") + ("evalhook-step-confusion:fix" "iss149.htm") + ("evalhook-step-confusion:x3j13-nov-89" "iss150.htm") + ("exit-extent-and-condition-system:like-dynamic-bindings" "iss151.htm") + ("exit-extent:minimal" "iss152.htm") + ("expt-ratio:p.211" "iss153.htm") + ("extensions-position:documentation" "iss154.htm") + ("external-format-for-every-file-connection:minimum" "iss155.htm") + ("extra-return-values:no" "iss156.htm") + ("file-open-error:signal-file-error" "iss157.htm") + ("fixnum-non-portable:tighten-definition" "iss158.htm") + ("flet-declarations" "iss159.htm") + ("flet-declarations:allow" "iss160.htm") + ("flet-implicit-block:yes" "iss161.htm") + ("float-underflow:add-variables" "iss162.htm") + ("floating-point-condition-names:x3j13-nov-89" "iss163.htm") + ("format-atsign-colon" "iss164.htm") + ("format-colon-uparrow-scope" "iss165.htm") + ("format-comma-interval" "iss166.htm") + ("format-e-exponent-sign:force-sign" "iss167.htm") + ("format-op-c" "iss168.htm") + ("format-pretty-print:yes" "iss169.htm") + ("format-string-arguments:specify" "iss170.htm") + ("function-call-evaluation-order:more-unspecified" "iss171.htm") + ("function-composition:jan89-x3j13" "iss172.htm") + ("function-definition:jan89-x3j13" "iss173.htm") + ("function-name:large" "iss174.htm") + ("function-type" "iss175.htm") + ("function-type-argument-type-semantics:restrictive" "iss176.htm") + ("function-type-key-name:specify-keyword" "iss177.htm") + ("function-type-rest-list-element:use-actual-argument-type" "iss178.htm") + ("function-type:x3j13-march-88" "iss179.htm") + ("generalize-pretty-printer:unify" "iss180.htm") + ("generic-flet-poorly-designed:delete" "iss181.htm") + ("gensym-name-stickiness:like-teflon" "iss182.htm") + ("gentemp-bad-idea:deprecate" "iss183.htm") + ("get-macro-character-readtable:nil-standard" "iss184.htm") + ("get-setf-method-environment:add-arg" "iss185.htm") + ("hash-table-access:x3j13-mar-89" "iss186.htm") + ("hash-table-key-modification:specify" "iss187.htm") + ("hash-table-package-generators:add-with-wrapper" "iss188.htm") + ("hash-table-rehash-size-integer" "iss189.htm") + ("hash-table-size:intended-entries" "iss190.htm") + ("hash-table-tests:add-equalp" "iss191.htm") + ("ieee-atan-branch-cut:split" "iss192.htm") + ("ignore-use-terminology:value-only" "iss193.htm") + ("import-setf-symbol-package" "iss194.htm") + ("in-package-functionality:mar89-x3j13" "iss195.htm") + ("in-syntax:minimal" "iss196.htm") + ("initialization-function-keyword-checking" "iss197.htm") + ("iso-compatibility:add-substrate" "iss198.htm") + ("jun90-trivial-issues:11" "iss199.htm") + ("jun90-trivial-issues:14" "iss200.htm") + ("jun90-trivial-issues:24" "iss201.htm") + ("jun90-trivial-issues:25" "iss202.htm") + ("jun90-trivial-issues:27" "iss203.htm") + ("jun90-trivial-issues:3" "iss204.htm") + ("jun90-trivial-issues:4" "iss205.htm") + ("jun90-trivial-issues:5" "iss206.htm") + ("jun90-trivial-issues:9" "iss207.htm") + ("keyword-argument-name-package:any" "iss208.htm") + ("last-n" "iss209.htm") + ("lcm-no-arguments:1" "iss210.htm") + ("lexical-construct-global-definition:undefined" "iss211.htm") + ("lisp-package-name:common-lisp" "iss212.htm") + ("lisp-symbol-redefinition-again:more-fixes" "iss213.htm") + ("lisp-symbol-redefinition:mar89-x3j13" "iss214.htm") + ("load-objects:make-load-form" "iss215.htm") + ("load-time-eval:r**2-new-special-form" "iss216.htm") + ("load-time-eval:r**3-new-special-form" "iss217.htm") + ("load-truename:new-pathname-variables" "iss218.htm") + ("locally-top-level:special-form" "iss219.htm") + ("loop-and-discrepancy:no-reiteration" "iss220.htm") + ("loop-for-as-on-typo:fix-typo" "iss221.htm") + ("loop-initform-environment:partial-interleaving-vague" "iss222.htm") + ("loop-miscellaneous-repairs:fix" "iss223.htm") + ("loop-named-block-nil:override" "iss224.htm") + ("loop-present-symbols-typo:flush-wrong-words" "iss225.htm") + ("loop-syntax-overhaul:repair" "iss226.htm") + ("macro-as-function:disallow" "iss227.htm") + ("macro-declarations:make-explicit" "iss228.htm") + ("macro-environment-extent:dynamic" "iss229.htm") + ("macro-function-environment" "iss230.htm") + ("macro-function-environment:yes" "iss231.htm") + ("macro-subforms-top-level-p:add-constraints" "iss232.htm") + ("macroexpand-hook-default:explicitly-vague" "iss233.htm") + ("macroexpand-hook-initial-value:implementation-dependent" "iss234.htm") + ("macroexpand-return-value:true" "iss235.htm") + ("make-load-form-confusion:rewrite" "iss236.htm") + ("make-load-form-saving-slots:no-initforms" "iss237.htm") + ("make-package-use-default:implementation-dependent" "iss238.htm") + ("map-into:add-function" "iss239.htm") + ("mapping-destructive-interaction:explicitly-vague" "iss240.htm") + ("metaclass-of-system-class:unspecified" "iss241.htm") + ("method-combination-arguments:clarify" "iss242.htm") + ("method-initform:forbid-call-next-method" "iss243.htm") + ("muffle-warning-condition-argument" "iss244.htm") + ("multiple-value-setq-order:like-setf-of-values" "iss245.htm") + ("multiple-values-limit-on-variables:undefined" "iss246.htm") + ("nintersection-destruction" "iss247.htm") + ("nintersection-destruction:revert" "iss248.htm") + ("not-and-null-return-value:x3j13-mar-93" "iss249.htm") + ("nth-value:add" "iss250.htm") + ("optimize-debug-info:new-quality" "iss251.htm") + ("package-clutter:reduce" "iss252.htm") + ("package-deletion:new-function" "iss253.htm") + ("package-function-consistency:more-permissive" "iss254.htm") + ("parse-error-stream:split-types" "iss255.htm") + ("pathname-component-case:keyword-argument" "iss256.htm") + ("pathname-component-value:specify" "iss257.htm") + ("pathname-host-parsing:recognize-logical-host-names" "iss258.htm") + ("pathname-logical:add" "iss259.htm") + ("pathname-print-read:sharpsign-p" "iss260.htm") + ("pathname-stream" "iss261.htm") + ("pathname-stream:files-or-synonym" "iss262.htm") + ("pathname-subdirectory-list:new-representation" "iss263.htm") + ("pathname-symbol" "iss264.htm") + ("pathname-syntax-error-time:explicitly-vague" "iss265.htm") + ("pathname-unspecific-component:new-token" "iss266.htm") + ("pathname-wild:new-functions" "iss267.htm") + ("peek-char-read-char-echo:first-read-char" "iss268.htm") + ("plist-duplicates:allow" "iss269.htm") + ("pretty-print-interface" "iss270.htm") + ("princ-readably:x3j13-dec-91" "iss271.htm") + ("print-case-behavior:clarify" "iss272.htm") + ("print-case-print-escape-interaction:vertical-bar-rule-no-upcase" + "iss273.htm") + ("print-circle-shared:respect-print-circle" "iss274.htm") + ("print-circle-structure:user-functions-work" "iss275.htm") + ("print-readably-behavior:clarify" "iss276.htm") + ("printer-whitespace:just-one-space" "iss277.htm") + ("proclaim-etc-in-compile-file:new-macro" "iss278.htm") + ("push-evaluation-order:first-item" "iss279.htm") + ("push-evaluation-order:item-first" "iss280.htm") + ("pushnew-store-required:unspecified" "iss281.htm") + ("quote-semantics:no-copying" "iss282.htm") + ("range-of-count-keyword:nil-or-integer" "iss283.htm") + ("range-of-start-and-end-parameters:integer-and-integer-nil" "iss284.htm") + ("read-and-write-bytes:new-functions" "iss285.htm") + ("read-case-sensitivity:readtable-keywords" "iss286.htm") + ("read-modify-write-evaluation-order:delayed-access-stores" "iss287.htm") + ("read-suppress-confusing:generalize" "iss288.htm") + ("reader-error:new-type" "iss289.htm") + ("real-number-type:x3j13-mar-89" "iss290.htm") + ("recursive-deftype:explicitly-vague" "iss291.htm") + ("reduce-argument-extraction" "iss292.htm") + ("remf-destruction-unspecified:x3j13-mar-89" "iss293.htm") + ("require-pathname-defaults-again:x3j13-dec-91" "iss294.htm") + ("require-pathname-defaults-yet-again:restore-argument" "iss295.htm") + ("require-pathname-defaults:eliminate" "iss296.htm") + ("rest-list-allocation:may-share" "iss297.htm") + ("result-lists-shared:specify" "iss298.htm") + ("return-values-unspecified:specify" "iss299.htm") + ("room-default-argument:new-value" "iss300.htm") + ("self-modifying-code:forbid" "iss301.htm") + ("sequence-type-length:must-match" "iss302.htm") + ("setf-apply-expansion:ignore-expander" "iss303.htm") + ("setf-find-class:allow-nil" "iss304.htm") + ("setf-functions-again:minimal-changes" "iss305.htm") + ("setf-get-default:evaluated-but-ignored" "iss306.htm") + ("setf-macro-expansion:last" "iss307.htm") + ("setf-method-vs-setf-method:rename-old-terms" "iss308.htm") + ("setf-multiple-store-variables:allow" "iss309.htm") + ("setf-of-apply:only-aref-and-friends" "iss310.htm") + ("setf-of-values:add" "iss311.htm") + ("setf-sub-methods:delayed-access-stores" "iss312.htm") + ("shadow-already-present" "iss313.htm") + ("shadow-already-present:works" "iss314.htm") + ("sharp-comma-confusion:remove" "iss315.htm") + ("sharp-o-foobar:consequences-undefined" "iss316.htm") + ("sharp-star-delimiter:normal-delimiter" "iss317.htm") + ("sharpsign-plus-minus-package:keyword" "iss318.htm") + ("slot-missing-values:specify" "iss319.htm") + ("slot-value-metaclasses:less-minimal" "iss320.htm") + ("special-form-p-misnomer:rename" "iss321.htm") + ("special-type-shadowing:clarify" "iss322.htm") + ("standard-input-initial-binding:defined-contracts" "iss323.htm") + ("standard-repertoire-gratuitous:rename" "iss324.htm") + ("step-environment:current" "iss325.htm") + ("step-minimal:permit-progn" "iss326.htm") + ("stream-access:add-types-accessors" "iss327.htm") + ("stream-capabilities:interactive-stream-p" "iss328.htm") + ("string-coercion:make-consistent" "iss329.htm") + ("string-output-stream-bashing:undefined" "iss330.htm") + ("structure-read-print-syntax:keywords" "iss331.htm") + ("subseq-out-of-bounds" "iss332.htm") + ("subseq-out-of-bounds:is-an-error" "iss333.htm") + ("subsetting-position:none" "iss334.htm") + ("subtypep-environment:add-arg" "iss335.htm") + ("subtypep-too-vague:clarify-more" "iss336.htm") + ("sxhash-definition:similar-for-sxhash" "iss337.htm") + ("symbol-macrolet-declare:allow" "iss338.htm") + ("symbol-macrolet-semantics:special-form" "iss339.htm") + ("symbol-macrolet-type-declaration:no" "iss340.htm") + ("symbol-macros-and-proclaimed-specials:signals-an-error" "iss341.htm") + ("symbol-print-escape-behavior:clarify" "iss342.htm") + ("syntactic-environment-access:retracted-mar91" "iss343.htm") + ("tagbody-tag-expansion:no" "iss344.htm") + ("tailp-nil:t" "iss345.htm") + ("test-not-if-not:flush-all" "iss346.htm") + ("the-ambiguity:for-declaration" "iss347.htm") + ("the-values:return-number-received" "iss348.htm") + ("time-zone-non-integer:allow" "iss349.htm") + ("type-declaration-abbreviation:allow-all" "iss350.htm") + ("type-of-and-predefined-classes:type-of-handles-floats" "iss351.htm") + ("type-of-and-predefined-classes:unify-and-extend" "iss352.htm") + ("type-of-underconstrained:add-constraints" "iss353.htm") + ("type-specifier-abbreviation:x3j13-jun90-guess" "iss354.htm") + ("undefined-variables-and-functions:compromise" "iss355.htm") + ("uninitialized-elements:consequences-undefined" "iss356.htm") + ("unread-char-after-peek-char:dont-allow" "iss357.htm") + ("unsolicited-messages:not-to-system-user-streams" "iss358.htm") + ("variable-list-asymmetry:symmetrize" "iss359.htm") + ("with-added-methods:delete" "iss360.htm") + ("with-compilation-unit:new-macro" "iss361.htm") + ("with-open-file-does-not-exist:stream-is-nil" "iss362.htm") + ("with-open-file-setq:explicitly-vague" "iss363.htm") + ("with-open-file-stream-extent:dynamic-extent" "iss364.htm") + ("with-output-to-string-append-style:vector-push-extend" "iss365.htm") + ("with-standard-io-syntax-readtable:x3j13-mar-91" "iss366.htm")))) + +(defun common-lisp-issuex (issue-name) + (let ((entry (gethash (downcase issue-name) + common-lisp-hyperspec--issuex-symbols))) + (concat common-lisp-hyperspec-root "Issues/" entry))) + +(defun common-lisp-special-operator (name) + (format "%sBody/s_%s.htm" common-lisp-hyperspec-root name)) + +;;; Added the following just to provide a common entry point according +;;; to the various 'hyperspec' implementations. +;;; +;;; 19990820 Marco Antoniotti + +(defalias 'hyperspec-lookup 'common-lisp-hyperspec) +(defalias 'hyperspec-lookup-reader-macro + 'common-lisp-hyperspec-lookup-reader-macro) +(defalias 'hyperspec-lookup-format 'common-lisp-hyperspec-format) + +(provide 'hyperspec) + +;;; hyperspec.el ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/macrostep.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/macrostep.el new file mode 100644 index 0000000..b301497 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/lib/macrostep.el @@ -0,0 +1,1122 @@ +;;; macrostep.el --- interactive macro expander + +;; Copyright (C) 2012-2015 Jon Oddie + +;; Author: joddie +;; Maintainer: joddie +;; Created: 16 January 2012 +;; Updated: 07 December 2015 +;; Version: 0.9 +;; Keywords: lisp, languages, macro, debugging +;; Url: https://github.com/joddie/macrostep +;; Package-Requires: ((cl-lib "0.5")) + +;; This file is NOT part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; `macrostep' is an Emacs minor mode for interactively stepping through +;; the expansion of macros in Emacs Lisp source code. It lets you see +;; exactly what happens at each step of the expansion process by +;; pretty-printing the expanded forms inline in the source buffer, which is +;; temporarily read-only while macro expansions are visible. You can +;; expand and collapse macro forms one step at a time, and evaluate or +;; instrument the expansions for debugging with Edebug as normal (but see +;; "Bugs and known limitations", below). Single-stepping through the +;; expansion is particularly useful for debugging macros that expand into +;; another macro form. These can be difficult to debug with Emacs' +;; built-in `macroexpand', which continues expansion until the top-level +;; form is no longer a macro call. + +;; Both globally-visible macros as defined by `defmacro' and local macros +;; bound by `(cl-)macrolet' or another macro-defining form can be expanded. +;; Within macro expansions, calls to macros and compiler macros are +;; fontified specially: macro forms using `macrostep-macro-face', and +;; functions with compiler macros using `macrostep-compiler-macro-face'. +;; Uninterned symbols (gensyms) are fontified based on which step in the +;; expansion created them, to distinguish them both from normal symbols and +;; from other gensyms with the same print name. + +;; As of version 0.9, it is also possible to extend `macrostep' to work +;; with other languages with macro systems in addition to Emacs Lisp. An +;; extension for Common Lisp (via SLIME) is in the works; contributions for +;; other languages are welcome. See "Extending macrostep" below for +;; details. + + +;; 1 Key-bindings and usage +;; ======================== + +;; The standard keybindings in `macrostep-mode' are the following: + +;; e, =, RET : expand the macro form following point one step +;; c, u, DEL : collapse the form following point +;; q, C-c C-c: collapse all expanded forms and exit macrostep-mode +;; n, TAB : jump to the next macro form in the expansion +;; p, M-TAB : jump to the previous macro form in the expansion + +;; It's not very useful to enable and disable macrostep-mode directly. +;; Instead, bind `macrostep-expand' to a key in `emacs-lisp-mode-map', +;; for example C-c e: + +;; ,---- +;; | (define-key emacs-lisp-mode-map (kbd "C-c e") 'macrostep-expand) +;; `---- + +;; You can then enter macrostep-mode and expand a macro form completely +;; by typing `C-c e e e ...' as many times as necessary. + +;; Exit macrostep-mode by typing `q' or `C-c C-c', or by successively +;; typing `c' to collapse all surrounding expansions. + + +;; 2 Customization options +;; ======================= + +;; Type `M-x customize-group RET macrostep RET' to customize options and +;; faces. + +;; To display macro expansions in a separate window, instead of inline in +;; the source buffer, customize `macrostep-expand-in-separate-buffer' to +;; `t'. The default is `nil'. Whichever default behavior is selected, +;; the alternative behavior can be obtained temporarily by giving a +;; prefix argument to `macrostep-expand'. + +;; To have `macrostep' ignore compiler macros, customize +;; `macrostep-expand-compiler-macros' to `nil'. The default is `t'. + +;; Customize the faces `macrostep-macro-face', +;; `macrostep-compiler-macro-face', and `macrostep-gensym-1' through +;; `macrostep-gensym-5' to alter the appearance of macro expansions. + + +;; 3 Locally-bound macros +;; ====================== + +;; As of version 0.9, `macrostep' can expand calls to a locally-bound +;; macro, whether defined by a surrounding `(cl-)macrolet' form, or by +;; another macro-defining macro. In other words, it is possible to +;; expand the inner `local-macro' forms in both the following examples, +;; whether `local-macro' is defined by an enclosing `cl-macrolet' -- + +;; ,---- +;; | (cl-macrolet ((local-macro (&rest args) +;; | `(expansion of ,args))) +;; | (local-macro (do-something))) +;; `---- + +;; -- or by a macro which expands into `cl-macrolet', provided that its +;; definition of macro is evaluated prior to calling `macrostep-expand': + +;; ,---- +;; | (defmacro with-local-macro (&rest body) +;; | `(cl-macrolet ((local-macro (&rest args) +;; | `(expansion of ,args))) +;; | ,@body)) +;; | +;; | (with-local-macro +;; | (local-macro (do something (else))) +;; `---- + +;; See the `with-js' macro in Emacs's `js.el' for a real example of the +;; latter kind of macro. + +;; Expansion of locally-bound macros is implemented by instrumenting +;; Emacs Lisp's macro-expander to capture the environment at point. A +;; similar trick is used to detect macro- and compiler-macro calls within +;; expanded text so that they can be fontified accurately. + + +;; 4 Expanding sub-forms +;; ===================== + +;; By moving point around in the macro expansion using +;; `macrostep-next-macro' and `macrostep-prev-macro' (bound to the `n' +;; and `p' keys), it is possible to expand other macro calls within the +;; expansion before expanding the outermost form. This can sometimes be +;; useful, although it does not correspond to the real order of macro +;; expansion in Emacs Lisp, which proceeds by fully expanding the outer +;; form to a non-macro form before expanding sub-forms. + +;; The main reason to expand sub-forms out of order is to help with +;; debugging macros which programmatically expand their arguments in +;; order to rewrite them. Expanding the arguments of such a macro lets +;; you visualise what the macro definition would compute via +;; `macroexpand-all'. + + +;; 5 Extending macrostep for other languages +;; ========================================= + +;; Since version 0.9, it is possible to extend macrostep to work with +;; other languages besides Emacs Lisp. In typical Emacs fashion, this is +;; implemented by setting buffer-local variables to different function +;; values. Six buffer-local variables define the language-specific part +;; of the implementation: + +;; - `macrostep-sexp-bounds-function' +;; - `macrostep-sexp-at-point-function' +;; - `macrostep-environment-at-point-function' +;; - `macrostep-expand-1-function' +;; - `macrostep-print-function' +;; - `macrostep-macro-form-p-function' + +;; Typically, an implementation for another language would set these +;; variables in a major-mode hook. See the docstrings of each variable +;; for details on how each one is called and what it should return. At a +;; minimum, another language implementation needs to provide +;; `macrostep-sexp-at-point-function', `macrostep-expand-1-function', and +;; `macrostep-print-function'. Lisp-like languages may be able to reuse +;; the default `macrostep-sexp-bounds-function' if they provide another +;; implementation of `macrostep-macro-form-p-function'. Languages which +;; do not implement locally-defined macros can set +;; `macrostep-environment-at-point-function' to `ignore'. + +;; Note that the core `macrostep' machinery only interprets the return +;; value of `macrostep-sexp-bounds-function', so implementations for +;; other languages can use any internal representations of code and +;; environments which is convenient. Although the terminology is +;; Lisp-specific, there is no reason that implementations could not be +;; provided for non-Lisp languages with macro systems, provided there is +;; some way of identifying macro calls and calling the compiler / +;; preprocessor to obtain their expansions. + + +;; 6 Bugs and known limitations +;; ============================ + +;; You can evaluate and edebug macro-expanded forms and step through the +;; macro-expanded version, but the form that `eval-defun' and friends +;; read from the buffer won't have the uninterned symbols of the real +;; macro expansion. This will probably work OK with CL-style gensyms, +;; but may cause problems with `make-symbol' symbols if they have the +;; same print name as another symbol in the expansion. It's possible that +;; using `print-circle' and `print-gensym' could get around this. + +;; Please send other bug reports and feature requests to the author. + + +;; 7 Acknowledgements +;; ================== + +;; Thanks to: +;; - John Wiegley for fixing a bug with the face definitions under Emacs +;; 24 & for plugging macrostep in his [EmacsConf presentation]! +;; - George Kettleborough for bug reports, and patches to highlight the +;; expanded region and properly handle backquotes. +;; - Nic Ferrier for suggesting support for local definitions within +;; macrolet forms +;; - Luís Oliveira for suggesting and implementing SLIME support + +;; `macrostep' was originally inspired by J. V. Toups's 'Deep Emacs Lisp' +;; articles ([part 1], [part 2], [screencast]). + +;; [EmacsConf presentation] http://youtu.be/RvPFZL6NJNQ + +;; [part 1] +;; http://dorophone.blogspot.co.uk/2011/04/deep-emacs-part-1.html + +;; [part 2] +;; http://dorophone.blogspot.co.uk/2011/04/deep-emacs-lisp-part-2.html + +;; [screencast] +;; http://dorophone.blogspot.co.uk/2011/05/monadic-parser-combinators-in-elisp.html + + +;; 8 Changelog +;; =========== + +;; - v0.9, 2015-10-01: +;; - separate into Elisp-specific and generic components +;; - highlight and expand compiler macros +;; - improve local macro expansion and macro form identification by +;; instrumenting `macroexpand(-all)' +;; - v0.8, 2014-05-29: fix a bug with printing the first element of lists +;; - v0.7, 2014-05-11: expand locally-defined macros within +;; `(cl-)macrolet' forms +;; - v0.6, 2013-05-04: better handling of quote and backquote +;; - v0.5, 2013-04-16: highlight region, maintain cleaner buffer state +;; - v0.4, 2013-04-07: only enter macrostep-mode on successful +;; macro-expansion +;; - v0.3, 2012-10-30: print dotted lists correctly. autoload +;; definitions. + +;;; Code: + +(require 'pp) +(require 'ring) +(eval-and-compile + (require 'cl-lib nil t) + (require 'cl-lib "lib/cl-lib")) + + +;;; Constants and dynamically bound variables +(defvar macrostep-overlays nil + "List of all macro stepper overlays in the current buffer.") +(make-variable-buffer-local 'macrostep-overlays) + +(defvar macrostep-gensym-depth nil + "Number of macro expansion levels that have introduced gensyms so far.") +(make-variable-buffer-local 'macrostep-gensym-depth) + +(defvar macrostep-gensyms-this-level nil + "t if gensyms have been encountered during current level of macro expansion.") +(make-variable-buffer-local 'macrostep-gensyms-this-level) + +(defvar macrostep-saved-undo-list nil + "Saved value of buffer-undo-list upon entering macrostep mode.") +(make-variable-buffer-local 'macrostep-saved-undo-list) + +(defvar macrostep-saved-read-only nil + "Saved value of buffer-read-only upon entering macrostep mode.") +(make-variable-buffer-local 'macrostep-saved-read-only) + +(defvar macrostep-expansion-buffer nil + "Non-nil if the current buffer is a macro-expansion buffer.") +(make-variable-buffer-local 'macrostep-expansion-buffer) + +(defvar macrostep-outer-environment nil + "Outermost macro-expansion environment to use in a dedicated macro-expansion buffers. + +This variable is used to save information about any enclosing +`cl-macrolet' context when a macro form is expanded in a separate +buffer.") +(make-variable-buffer-local 'macrostep-outer-environment) + +;;; Customization options and faces +(defgroup macrostep nil + "Interactive macro stepper for Emacs Lisp." + :group 'lisp + :link '(emacs-commentary-link :tag "commentary" "macrostep.el") + :link '(emacs-library-link :tag "lisp file" "macrostep.el") + :link '(url-link :tag "web page" "https://github.com/joddie/macrostep")) + +(defface macrostep-gensym-1 + '((((min-colors 16581375)) :foreground "#8080c0" :box t :bold t) + (((min-colors 8)) :background "cyan") + (t :inverse-video t)) + "Face for gensyms created in the first level of macro expansion." + :group 'macrostep) + +(defface macrostep-gensym-2 + '((((min-colors 16581375)) :foreground "#8fbc8f" :box t :bold t) + (((min-colors 8)) :background "#00cd00") + (t :inverse-video t)) + "Face for gensyms created in the second level of macro expansion." + :group 'macrostep) + +(defface macrostep-gensym-3 + '((((min-colors 16581375)) :foreground "#daa520" :box t :bold t) + (((min-colors 8)) :background "yellow") + (t :inverse-video t)) + "Face for gensyms created in the third level of macro expansion." + :group 'macrostep) + +(defface macrostep-gensym-4 + '((((min-colors 16581375)) :foreground "#cd5c5c" :box t :bold t) + (((min-colors 8)) :background "red") + (t :inverse-video t)) + "Face for gensyms created in the fourth level of macro expansion." + :group 'macrostep) + +(defface macrostep-gensym-5 + '((((min-colors 16581375)) :foreground "#da70d6" :box t :bold t) + (((min-colors 8)) :background "magenta") + (t :inverse-video t)) + "Face for gensyms created in the fifth level of macro expansion." + :group 'macrostep) + +(defface macrostep-expansion-highlight-face + '((((min-colors 16581375) (background light)) :background "#eee8d5") + (((min-colors 16581375) (background dark)) :background "#222222")) + "Face for macro-expansion highlight." + :group 'macrostep) + +(defface macrostep-macro-face + '((t :underline t)) + "Face for macros in macro-expanded code." + :group 'macrostep) + +(defface macrostep-compiler-macro-face + '((t :slant italic)) + "Face for compiler macros in macro-expanded code." + :group 'macrostep) + +(defcustom macrostep-expand-in-separate-buffer nil + "When non-nil, show expansions in a separate buffer instead of inline." + :group 'macrostep + :type 'boolean) + +(defcustom macrostep-expand-compiler-macros t + "When non-nil, expand compiler macros as well as `defmacro' and `macrolet' macros." + :group 'macrostep + :type 'boolean) + +;; Need the following for making the ring of faces +(defun macrostep-make-ring (&rest items) + "Make a ring containing all of ITEMS with no empty slots." + (let ((ring (make-ring (length items)))) + (mapc (lambda (item) (ring-insert ring item)) (reverse items)) + ring)) + +(defvar macrostep-gensym-faces + (macrostep-make-ring + 'macrostep-gensym-1 'macrostep-gensym-2 'macrostep-gensym-3 + 'macrostep-gensym-4 'macrostep-gensym-5) + "Ring of all macrostepper faces for fontifying gensyms.") + +;; Other modes can enable macrostep by redefining these functions to +;; language-specific versions. +(defvar macrostep-sexp-bounds-function + #'macrostep-sexp-bounds + "Function to return the bounds of the macro form nearest point. + +It will be called with no arguments and should return a cons of +buffer positions, (START . END). It should use `save-excursion' +to avoid changing the position of point. + +The default value, `macrostep-sexp-bounds', implements this for +Emacs Lisp, and may be suitable for other Lisp-like languages.") +(make-variable-buffer-local 'macrostep-sexp-bounds-function) + +(defvar macrostep-sexp-at-point-function + #'macrostep-sexp-at-point + "Function to return the macro form at point for expansion. + +It will be called with two arguments, the values of START and END +returned by `macrostep-sexp-bounds-function', and with point +positioned at START. It should return a value suitable for +passing as the first argument to `macrostep-expand-1-function'. + +The default value, `macrostep-sexp-at-point', implements this for +Emacs Lisp, and may be suitable for other Lisp-like languages.") +(make-variable-buffer-local 'macrostep-sexp-at-point-function) + +(defvar macrostep-environment-at-point-function + #'macrostep-environment-at-point + "Function to return the local macro-expansion environment at point. + +It will be called with no arguments, and should return a value +suitable for passing as the second argument to +`macrostep-expand-1-function'. + +The default value, `macrostep-environment-at-point', is specific +to Emacs Lisp. For languages which do not implement local +macro-expansion environments, this should be set to `ignore' +or `(lambda () nil)'.") +(make-variable-buffer-local 'macrostep-environment-at-point-function) + +(defvar macrostep-expand-1-function + #'macrostep-expand-1 + "Function to perform one step of macro-expansion. + +It will be called with two arguments, FORM and ENVIRONMENT, the +return values of `macrostep-sexp-at-point-function' and +`macrostep-environment-at-point-function' respectively. It +should return the result of expanding FORM by one step as a value +which is suitable for passing as the argument to +`macrostep-print-function'. + +The default value, `macrostep-expand-1', is specific to Emacs Lisp.") +(make-variable-buffer-local 'macrostep-expand-1-function) + +(defvar macrostep-print-function + #'macrostep-pp + "Function to pretty-print macro expansions. + +It will be called with two arguments, FORM and ENVIRONMENT, the +return values of `macrostep-sexp-at-point-function' and +`macrostep-environment-at-point-function' respectively. It +should insert a pretty-printed representation at point in the +current buffer, leaving point just after the inserted +representation, without altering any other text in the current +buffer. + +The default value, `macrostep-pp', is specific to Emacs Lisp.") +(make-variable-buffer-local 'macrostep-print-function) + +(defvar macrostep-macro-form-p-function + #'macrostep-macro-form-p + "Function to check whether a form is a macro call. + +It will be called with two arguments, FORM and ENVIRONMENT -- the +return values of `macrostep-sexp-at-point-function' and +`macrostep-environment-at-point-function' respectively -- and +should return non-nil if FORM would undergo macro-expansion in +ENVIRONMENT. + +This is called only from `macrostep-sexp-bounds', so it need not +be provided if a different value is used for +`macrostep-sexp-bounds-function'. + +The default value, `macrostep-macro-form-p', is specific to Emacs Lisp.") +(make-variable-buffer-local 'macrostep-macro-form-p-function) + + +;;; Define keymap and minor mode +(defvar macrostep-keymap + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'macrostep-expand) + (define-key map "=" 'macrostep-expand) + (define-key map "e" 'macrostep-expand) + + (define-key map (kbd "DEL") 'macrostep-collapse) + (define-key map "u" 'macrostep-collapse) + (define-key map "c" 'macrostep-collapse) + + (define-key map (kbd "TAB") 'macrostep-next-macro) + (define-key map "n" 'macrostep-next-macro) + (define-key map (kbd "M-TAB") 'macrostep-prev-macro) + (define-key map "p" 'macrostep-prev-macro) + + (define-key map "q" 'macrostep-collapse-all) + (define-key map (kbd "C-c C-c") 'macrostep-collapse-all) + map) + "Keymap for `macrostep-mode'.") + +;;;###autoload +(define-minor-mode macrostep-mode + "Minor mode for inline expansion of macros in Emacs Lisp source buffers. + +\\Progressively expand macro forms with \\[macrostep-expand], collapse them with \\[macrostep-collapse], +and move back and forth with \\[macrostep-next-macro] and \\[macrostep-prev-macro]. +Use \\[macrostep-collapse-all] or collapse all visible expansions to +quit and return to normal editing. + +\\{macrostep-keymap}" + nil " Macro-Stepper" + :keymap macrostep-keymap + :group macrostep + (if macrostep-mode + (progn + ;; Disable recording of undo information + (setq macrostep-saved-undo-list buffer-undo-list + buffer-undo-list t) + ;; Remember whether buffer was read-only + (setq macrostep-saved-read-only buffer-read-only + buffer-read-only t) + ;; Set up post-command hook to bail out on leaving read-only + (add-hook 'post-command-hook 'macrostep-command-hook nil t) + (message + (substitute-command-keys + "\\Entering macro stepper mode. Use \\[macrostep-expand] to expand, \\[macrostep-collapse] to collapse, \\[macrostep-collapse-all] to exit."))) + + ;; Exiting mode + (if macrostep-expansion-buffer + ;; Kill dedicated expansion buffers + (quit-window t) + ;; Collapse any remaining overlays + (when macrostep-overlays (macrostep-collapse-all)) + ;; Restore undo info & read-only state + (setq buffer-undo-list macrostep-saved-undo-list + buffer-read-only macrostep-saved-read-only + macrostep-saved-undo-list nil) + ;; Remove our post-command hook + (remove-hook 'post-command-hook 'macrostep-command-hook t)))) + +;; Post-command hook: bail out of macrostep-mode if the user types C-x +;; C-q to make the buffer writable again. +(defun macrostep-command-hook () + (if (not buffer-read-only) + (macrostep-mode 0))) + + +;;; Interactive functions +;;;###autoload +(defun macrostep-expand (&optional toggle-separate-buffer) + "Expand the macro form following point by one step. + +Enters `macrostep-mode' if it is not already active, making the +buffer temporarily read-only. If macrostep-mode is active and the +form following point is not a macro form, search forward in the +buffer and expand the next macro form found, if any. + +With a prefix argument, the expansion is displayed in a separate +buffer instead of inline in the current buffer. Setting +`macrostep-expand-in-separate-buffer' to non-nil swaps these two +behaviors." + (interactive "P") + (cl-destructuring-bind (start . end) + (funcall macrostep-sexp-bounds-function) + (goto-char start) + (let* ((sexp (funcall macrostep-sexp-at-point-function start end)) + (end (copy-marker end)) + (text (buffer-substring start end)) + (env (funcall macrostep-environment-at-point-function)) + (expansion (funcall macrostep-expand-1-function sexp env))) + + ;; Create a dedicated macro-expansion buffer and copy the text to + ;; be expanded into it, if required + (let ((separate-buffer-p + (if toggle-separate-buffer + (not macrostep-expand-in-separate-buffer) + macrostep-expand-in-separate-buffer))) + (when (and separate-buffer-p (not macrostep-expansion-buffer)) + (let ((mode major-mode) + (buffer + (get-buffer-create (generate-new-buffer-name "*macro expansion*")))) + (set-buffer buffer) + (funcall mode) + (setq macrostep-expansion-buffer t) + (setq macrostep-outer-environment env) + (save-excursion + (setq start (point)) + (insert text) + (setq end (point-marker))) + (pop-to-buffer buffer)))) + + (unless macrostep-mode (macrostep-mode t)) + (let ((existing-overlay (macrostep-overlay-at-point)) + (macrostep-gensym-depth macrostep-gensym-depth) + (macrostep-gensyms-this-level nil) + priority) + (if existing-overlay + (progn ; Expanding part of a previous macro-expansion + (setq priority (1+ (overlay-get existing-overlay 'priority))) + (setq macrostep-gensym-depth + (overlay-get existing-overlay 'macrostep-gensym-depth))) + ;; Expanding source buffer text + (setq priority 1) + (setq macrostep-gensym-depth -1)) + + (with-silent-modifications + (atomic-change-group + (let ((inhibit-read-only t)) + (save-excursion + ;; Insert expansion + (funcall macrostep-print-function expansion env) + ;; Delete the original form + (macrostep-collapse-overlays-in (point) end) + (delete-region (point) end) + ;; Create a new overlay + (let ((overlay + (make-overlay start + (if (looking-at "\n") + (1+ (point)) + (point))))) + (unless macrostep-expansion-buffer + ;; Highlight the overlay in original source buffers only + (overlay-put overlay 'face 'macrostep-expansion-highlight-face)) + (overlay-put overlay 'priority priority) + (overlay-put overlay 'macrostep-original-text text) + (overlay-put overlay 'macrostep-gensym-depth macrostep-gensym-depth) + (push overlay macrostep-overlays)))))))))) + +(defun macrostep-collapse () + "Collapse the innermost macro expansion near point to its source text. + +If no more macro expansions are visible after this, exit +`macrostep-mode'." + (interactive) + (let ((overlay (macrostep-overlay-at-point))) + (when (not overlay) (error "No macro expansion at point")) + (let ((inhibit-read-only t)) + (with-silent-modifications + (atomic-change-group + (macrostep-collapse-overlay overlay))))) + (if (not macrostep-overlays) + (macrostep-mode 0))) + +(defun macrostep-collapse-all () + "Collapse all visible macro expansions and exit `macrostep-mode'." + (interactive) + (let ((inhibit-read-only t)) + (with-silent-modifications + (dolist (overlay macrostep-overlays) + (let ((outermost (= (overlay-get overlay 'priority) 1))) + ;; We only need restore the original text for the outermost + ;; overlays + (macrostep-collapse-overlay overlay (not outermost)))))) + (setq macrostep-overlays nil) + (macrostep-mode 0)) + +(defun macrostep-next-macro () + "Move point forward to the next macro form in macro-expanded text." + (interactive) + (let* ((start + (if (get-text-property (point) 'macrostep-macro-start) + (1+ (point)) + (point))) + (next (next-single-property-change start 'macrostep-macro-start))) + (if next + (goto-char next) + (error "No more macro forms found")))) + +(defun macrostep-prev-macro () + "Move point back to the previous macro form in macro-expanded text." + (interactive) + (let (prev) + (save-excursion + (while + (progn + (setq prev + (previous-single-property-change (point) 'macrostep-macro-start)) + (if (or (not prev) + (get-text-property (1- prev) 'macrostep-macro-start)) + nil + (prog1 t (goto-char prev)))))) + (if prev + (goto-char (1- prev)) + (error "No previous macro form found")))) + + +;;; Utility functions (not language-specific) + +(defun macrostep-overlay-at-point () + "Return the innermost macro stepper overlay at point." + (let ((result + (get-char-property-and-overlay (point) 'macrostep-original-text))) + (cdr result))) + +(defun macrostep-collapse-overlay (overlay &optional no-restore-p) + "Collapse a macro-expansion overlay and restore the unexpanded source text. + +As a minor optimization, does not restore the original source +text if NO-RESTORE-P is non-nil. This is safe to do when +collapsing all the sub-expansions of an outer overlay, since the +outer overlay will restore the original source itself. + +Also removes the overlay from `macrostep-overlays'." + (with-current-buffer (overlay-buffer overlay) + ;; If we're cleaning up we don't need to bother restoring text + ;; or checking for inner overlays to delete + (unless no-restore-p + (let* ((start (overlay-start overlay)) + (end (overlay-end overlay)) + (text (overlay-get overlay 'macrostep-original-text)) + (sexp-end + (copy-marker + (if (equal (char-before end) ?\n) (1- end) end)))) + (macrostep-collapse-overlays-in start end) + (goto-char (overlay-start overlay)) + (save-excursion + (insert text) + (delete-region (point) sexp-end)))) + ;; Remove overlay from the list and delete it + (setq macrostep-overlays + (delq overlay macrostep-overlays)) + (delete-overlay overlay))) + +(defun macrostep-collapse-overlays-in (start end) + "Collapse all macrostepper overlays that are strictly between START and END. + +Will not collapse overlays that begin at START and end at END." + (dolist (ol (overlays-in start end)) + (if (and (> (overlay-start ol) start) + (< (overlay-end ol) end) + (overlay-get ol 'macrostep-original-text)) + (macrostep-collapse-overlay ol t)))) + + +;;; Emacs Lisp implementation + +(defun macrostep-sexp-bounds () + "Find the bounds of the macro form nearest point. + +If point is not before an open-paren, moves up to the nearest +enclosing list. If the form at point is not a macro call, +attempts to move forward to the next macro form as determined by +`macrostep-macro-form-p-function'. + +Returns a cons of buffer positions, (START . END)." + (save-excursion + (if (not (looking-at "[(`]")) + (backward-up-list 1)) + (if (equal (char-before) ?`) + (backward-char)) + (let ((sexp (funcall macrostep-sexp-at-point-function)) + (env (funcall macrostep-environment-at-point-function))) + ;; If this isn't a macro form, try to find the next one in the buffer + (unless (funcall macrostep-macro-form-p-function sexp env) + (condition-case nil + (macrostep-next-macro) + (error + (if (consp sexp) + (error "(%s ...) is not a macro form" (car sexp)) + (error "Text at point is not a macro form.")))))) + (cons (point) (scan-sexps (point) 1)))) + +(defun macrostep-sexp-at-point (&rest ignore) + "Return the sexp near point for purposes of macro-stepper expansion. + +If the sexp near point is part of a macro expansion, returns the +saved text of the macro expansion, and does not read from the +buffer. This preserves uninterned symbols in the macro +expansion, so that they can be fontified consistently. (See +`macrostep-print-sexp'.)" + (or (get-text-property (point) 'macrostep-expanded-text) + (sexp-at-point))) + +(defun macrostep-macro-form-p (form environment) + "Return non-nil if FORM would be evaluated via macro expansion. + +If FORM is an invocation of a macro defined by `defmacro' or an +enclosing `cl-macrolet' form, return the symbol `macro'. + +If `macrostep-expand-compiler-macros' is non-nil and FORM is a +call to a function with a compiler macro, return the symbol +`compiler-macro'. + +Otherwise, return nil." + (car (macrostep--macro-form-info form environment t))) + +(defun macrostep--macro-form-info (form environment &optional inhibit-autoload) + "Return information about macro definitions that apply to FORM. + +If no macros are involved in the evaluation of FORM within +ENVIRONMENT, returns nil. Otherwise, returns a cons (TYPE +. DEFINITION). + +If FORM would be evaluated by a macro defined by `defmacro', +`cl-macrolet', etc., TYPE is the symbol `macro' and DEFINITION is +the macro definition, as a function. + +If `macrostep-expand-compiler-macros' is non-nil and FORM would +be compiled using a compiler macro, TYPE is the symbol +`compmiler-macro' and DEFINITION is the function that implements +the compiler macro. + +If FORM is an invocation of an autoloaded macro, the behavior +depends on the value of INHIBIT-AUTOLOAD. If INHIBIT-AUTOLOAD is +nil, the file containing the macro definition will be loaded +using `load-library' and the macro definition returned as normal. +If INHIBIT-AUTOLOAD is non-nil, no files will be loaded, and the +value of DEFINITION in the result will be nil." + (if (not (and (consp form) + (symbolp (car form)))) + `(nil . nil) + (let* ((head (car form)) + (local-definition (assoc-default head environment #'eq))) + (if local-definition + `(macro . ,local-definition) + (let ((compiler-macro-definition + (and macrostep-expand-compiler-macros + (or (get head 'compiler-macro) + (get head 'cl-compiler-macro))))) + (if (and compiler-macro-definition + (not (eq form + (apply compiler-macro-definition form (cdr form))))) + `(compiler-macro . ,compiler-macro-definition) + (condition-case nil + (let ((fun (indirect-function head))) + (cl-case (car-safe fun) + ((macro) + `(macro . ,(cdr fun))) + ((autoload) + (when (eq (nth 4 fun) 'macro) + (if inhibit-autoload + `(macro . nil) + (load-library (nth 1 fun)) + (macrostep--macro-form-info form nil)))) + (t + `(nil . nil)))) + (void-function nil)))))))) + +(defun macrostep-expand-1 (form environment) + "Return result of macro-expanding the top level of FORM by exactly one step. +Unlike `macroexpand', this function does not continue macro +expansion until a non-macro-call results." + (cl-destructuring-bind (type . definition) + (macrostep--macro-form-info form environment) + (cl-ecase type + ((nil) + form) + ((macro) + (apply definition (cdr form))) + ((compiler-macro) + (let ((expansion + (apply definition form (cdr form)))) + (if (equal form expansion) + (error "Form left unchanged by compiler macro") + expansion)))))) + +(put 'macrostep-grab-environment-failed 'error-conditions + '(macrostep-grab-environment-failed error)) + +(defun macrostep-environment-at-point () + "Return the local macro-expansion environment at point, if any. + +The local environment includes macros declared by any `macrolet' +or `cl-macrolet' forms surrounding point, as well as by any macro +forms which expand into a `macrolet'. + +The return value is an alist of elements (NAME . FUNCTION), where +NAME is the symbol locally bound to the macro and FUNCTION is the +lambda expression that returns its expansion." + ;; If point is on a macro form within an expansion inserted by + ;; `macrostep-print-sexp', a local environment may have been + ;; previously saved as a text property. + (let ((saved-environment + (get-text-property (point) 'macrostep-environment))) + (if saved-environment + saved-environment + ;; Otherwise, we (ab)use the macro-expander to return the + ;; environment at point. If point is not at an evaluated + ;; position in the containing form, + ;; `macrostep-environment-at-point-1' will raise an error, and + ;; we back up progressively through the containing forms until + ;; it succeeds. + (save-excursion + (catch 'done + (while t + (condition-case nil + (throw 'done (macrostep-environment-at-point-1)) + (macrostep-grab-environment-failed + (condition-case nil + (backward-sexp) + (scan-error (backward-up-list))))))))))) + +(defun macrostep-environment-at-point-1 () + "Attempt to extract the macro environment that would be active at point. + +If point is not at an evaluated position within the containing +form, raise an error." + ;; Macro environments are extracted using Emacs Lisp's builtin + ;; macro-expansion machinery. The form containing point is copied + ;; to a temporary buffer, and a call to + ;; `--macrostep-grab-environment--' is inserted at point. This + ;; altered form is then fully macro-expanded, in an environment + ;; where `--macrostep-grab-environment--' is defined as a macro + ;; which throws the environment to a uniquely-generated tag. + (let* ((point-at-top-level + (save-excursion + (while (ignore-errors (backward-up-list) t)) + (point))) + (enclosing-form + (buffer-substring point-at-top-level + (scan-sexps point-at-top-level 1))) + (position (- (point) point-at-top-level)) + (tag (make-symbol "macrostep-grab-environment-tag")) + (grab-environment '--macrostep-grab-environment--)) + (if (= position 0) + nil + (with-temp-buffer + (emacs-lisp-mode) + (insert enclosing-form) + (goto-char (+ (point-min) position)) + (prin1 `(,grab-environment) (current-buffer)) + (let ((form (read (copy-marker (point-min))))) + (catch tag + (cl-letf (((symbol-function #'message) (symbol-function #'format))) + (with-no-warnings + (ignore-errors + (macroexpand-all + `(cl-macrolet ((,grab-environment (&environment env) + (throw ',tag env))) + ,form))))) + (signal 'macrostep-grab-environment-failed nil))))))) + +(defun macrostep-collect-macro-forms (form &optional environment) + "Identify sub-forms of FORM which undergo macro-expansion. + +FORM is an Emacs Lisp form. ENVIRONMENT is a local environment of +macro definitions. + +The return value is a list of two elements, (MACRO-FORM-ALIST +COMPILER-MACRO-FORMS). + +MACRO-FORM-ALIST is an alist of elements of the form (SUBFORM +. ENVIRONMENT), where SUBFORM is a form which undergoes +macro-expansion in the course of expanding FORM, and ENVIRONMENT +is the local macro environment in force when it is expanded. + +COMPILER-MACRO-FORMS is a list of subforms which would be +compiled using a compiler macro. Since there is no standard way +to provide a local compiler-macro definition in Emacs Lisp, no +corresponding local environments are collected for these. + +Forms and environments are extracted from FORM by instrumenting +Emacs's builtin `macroexpand' function and calling +`macroexpand-all'." + (let ((real-macroexpand (indirect-function #'macroexpand)) + (macro-form-alist '()) + (compiler-macro-forms '())) + (cl-letf + (((symbol-function #'macroexpand) + (lambda (form environment &rest args) + (let ((expansion + (apply real-macroexpand form environment args))) + (cond ((not (eq expansion form)) + (setq macro-form-alist + (cons (cons form environment) + macro-form-alist))) + ((and (consp form) + (symbolp (car form)) + macrostep-expand-compiler-macros + (not (eq form + (cl-compiler-macroexpand form)))) + (setq compiler-macro-forms + (cons form compiler-macro-forms)))) + expansion)))) + (ignore-errors + (macroexpand-all form environment))) + (list macro-form-alist compiler-macro-forms))) + +(defvar macrostep-collected-macro-form-alist nil + "An alist of macro forms and environments. +Controls the printing of sub-forms in `macrostep-print-sexp'.") + +(defvar macrostep-collected-compiler-macro-forms nil + "A list of compiler-macro forms to be highlighted in `macrostep-print-sexp'.") + +(defun macrostep-pp (sexp environment) + "Pretty-print SEXP, fontifying macro forms and uninterned symbols." + (cl-destructuring-bind + (macrostep-collected-macro-form-alist + macrostep-collected-compiler-macro-forms) + (macrostep-collect-macro-forms sexp environment) + (let ((print-quoted t)) + (macrostep-print-sexp sexp) + ;; Point is now after the expanded form; pretty-print it + (save-restriction + (narrow-to-region (scan-sexps (point) -1) (point)) + (save-excursion + (pp-buffer) + ;; Remove the extra newline inserted by pp-buffer + (goto-char (point-max)) + (delete-region + (point) + (save-excursion (skip-chars-backward " \t\n") (point)))) + ;; Indent the newly-inserted form in context + (widen) + (save-excursion + (backward-sexp) + (indent-sexp)))))) + +;; This must be defined before `macrostep-print-sexp': +(defmacro macrostep-propertize (form &rest plist) + "Evaluate FORM, applying syntax properties in PLIST to any inserted text." + (declare (indent 1) + (debug (&rest form))) + (let ((start (make-symbol "start"))) + `(let ((,start (point))) + (prog1 + ,form + ,@(cl-loop for (key value) on plist by #'cddr + collect `(put-text-property ,start (point) + ,key ,value)))))) + +(defun macrostep-print-sexp (sexp) + "Insert SEXP like `print', fontifying macro forms and uninterned symbols. + +Fontifies uninterned symbols and macro forms using +`font-lock-face' property, and saves the actual text of SEXP's +sub-forms as the `macrostep-expanded-text' text property so that +any uninterned symbols can be reused in macro expansions of the +sub-forms. See also `macrostep-sexp-at-point'. + +Macro and compiler-macro forms within SEXP are identified by +comparison with the `macrostep-collected-macro-form-alist' and +`macrostep-collected-compiler-macro-forms' variables, which +should be dynamically let-bound around calls to this function." + (cond + ((symbolp sexp) + ;; Fontify gensyms + (if (not (eq sexp (intern-soft (symbol-name sexp)))) + (macrostep-propertize + (prin1 sexp (current-buffer)) + 'font-lock-face (macrostep-get-gensym-face sexp)) + ;; Print other symbols as normal + (prin1 sexp (current-buffer)))) + + ((listp sexp) + ;; Print quoted and quasiquoted forms nicely. + (let ((head (car sexp))) + (cond ((and (eq head 'quote) ; quote + (= (length sexp) 2)) + (insert "'") + (macrostep-print-sexp (cadr sexp))) + + ((and (eq head '\`) ; backquote + (= (length sexp) 2)) + (if (assq sexp macrostep-collected-macro-form-alist) + (macrostep-propertize + (insert "`") + 'macrostep-expanded-text sexp + 'macrostep-macro-start t + 'font-lock-face 'macrostep-macro-face) + (insert "`")) + (macrostep-print-sexp (cadr sexp))) + + ((and (memq head '(\, \,@)) ; unquote + (= (length sexp) 2)) + (princ head (current-buffer)) + (macrostep-print-sexp (cadr sexp))) + + (t ; other list form + (cl-destructuring-bind (macro? . environment) + (or (assq sexp macrostep-collected-macro-form-alist) + '(nil . nil)) + (let + ((compiler-macro? + (memq sexp macrostep-collected-compiler-macro-forms))) + (if (or macro? compiler-macro?) + (progn + ;; Save the real expansion as a text property on the + ;; opening paren + (macrostep-propertize + (insert "(") + 'macrostep-macro-start t + 'macrostep-expanded-text sexp + 'macrostep-environment environment) + ;; Fontify the head of the macro + (macrostep-propertize + (macrostep-print-sexp head) + 'font-lock-face + (if macro? + 'macrostep-macro-face + 'macrostep-compiler-macro-face))) + ;; Not a macro form + (insert "(") + (macrostep-print-sexp head)))) + + ;; Print remaining list elements + (setq sexp (cdr sexp)) + (when sexp (insert " ")) + (while sexp + (if (listp sexp) + (progn + (macrostep-print-sexp (car sexp)) + (when (cdr sexp) (insert " ")) + (setq sexp (cdr sexp))) + ;; Print tail of dotted list + (insert ". ") + (macrostep-print-sexp sexp) + (setq sexp nil))) + (insert ")"))))) + + ;; Print everything except symbols and lists as normal + (t (prin1 sexp (current-buffer))))) + +(defun macrostep-get-gensym-face (symbol) + "Return the face to use in fontifying SYMBOL in printed macro expansions. + +All symbols introduced in the same level of macro expansion are +fontified using the same face (modulo the number of faces; see +`macrostep-gensym-faces')." + (or (get symbol 'macrostep-gensym-face) + (progn + (if (not macrostep-gensyms-this-level) + (setq macrostep-gensym-depth (1+ macrostep-gensym-depth) + macrostep-gensyms-this-level t)) + (let ((face (ring-ref macrostep-gensym-faces macrostep-gensym-depth))) + (put symbol 'macrostep-gensym-face face) + face)))) + + +(provide 'macrostep) + +;;; macrostep.el ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/metering.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/metering.lisp new file mode 100644 index 0000000..b87d280 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/metering.lisp @@ -0,0 +1,1213 @@ +;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.; -*- +;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz + +;;; **************************************************************** +;;; Metering System ************************************************ +;;; **************************************************************** +;;; +;;; The Metering System is a portable Common Lisp code profiling tool. +;;; It gathers timing and consing statistics for specified functions +;;; while a program is running. +;;; +;;; The Metering System is a combination of +;;; o the Monitor package written by Chris McConnell +;;; o the Profile package written by Skef Wholey and Rob MacLachlan +;;; The two systems were merged and extended by Mark Kantrowitz. +;;; +;;; Address: Carnegie Mellon University +;;; School of Computer Science +;;; Pittsburgh, PA 15213 +;;; +;;; This code is in the public domain and is distributed without warranty +;;; of any kind. +;;; +;;; This copy is from SLIME, http://www.common-lisp.net/project/slime/ +;;; +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages. +;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics +;;; with respect to nested calls. (Allows it to subtract +;;; total monitoring overhead for each function, not just +;;; the time spent monitoring the function itself.) +;;; 26-JUN-90 mk The table is now saved so that one may manipulate +;;; the data (sorting it, etc.) even after the original +;;; source of the data has been cleared. +;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2 +;;; required-arguments functions for Lucid 3.0, +;;; Franz Allegro CL, and MACL 1.3.2. +;;; 25-JAN-91 mk Now uses fdefinition if available. +;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl. +;;; Much better solution for the fact that both call +;;; themselves :allegro. +;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded +;;; uncompiled. +;;; 5-JUL-91 mk When many unmonitored functions, print out number +;;; instead of whole list. +;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring +;;; doesn't work in MCL, but fixed so that timing +;;; statistics do. +;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with +;;; (and :ccl (not :lispworks)). +;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0. +;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1, +;;; Lucid 4.0, ibcl +;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible. +;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL. +;;; Purely to cut down on stale code (e.g. #+cltl2) in this +;;; version that is bundled with SLIME. +;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL. +;;; 07-Aug-12 heller Break lines at 80 columns +;;; + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; - Need get-cons for Allegro, AKCL. +;;; - Speed up monitoring code. Replace use of hash tables with an embedded +;;; offset in an array so that it will be faster than using gethash. +;;; (i.e., svref/closure reference is usually faster than gethash). +;;; - Beware of (get-internal-run-time) overflowing. Yikes! +;;; - Check robustness with respect to profiled functions. +;;; - Check logic of computing inclusive and exclusive time and consing. +;;; Especially wrt incf/setf comment below. Should be incf, so we +;;; sum recursive calls. +;;; - Add option to record caller statistics -- this would list who +;;; called which functions and how often. +;;; - switches to turn timing/CONSING statistics collection on/off. + + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; METERING has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (16d, Python Compiler 1.0 ) :new-compiler +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; Macintosh Common Lisp (2.0) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 11/19/90) :allegro-v3.1 +;;; ExCL (Franz Allegro CL 4.0.1 [Sun4] 2/8/91) :allegro-v4.0 +;;; ExCL (Franz Allegro CL 4.1 [SPARC R1] 8/28/92 14:06) :allegro-v4.1 +;;; ExCL (Franz ACL 5.0.1 [Linux/X86] 6/29/99 16:11) :allegro-v5.0.1 +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; Lucid Common Lisp (3.0) +;;; Lucid Common Lisp (4.0.1 HP-700 12-Aug-91) +;;; AKCL (1.86, June 30, 1987 or later) +;;; Ibuki Common Lisp (Version 2, release 01.027) +;;; CLISP (January 1994) +;;; +;;; METERING needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; KCL (June 3, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; This system runs in any valid Common Lisp. Four small +;;; implementation-dependent changes can be made to improve performance +;;; and prettiness. In the section labelled "Implementation Dependent +;;; Changes" below, you should tailor the functions REQUIRED-ARGUMENTS, +;;; GET-CONS, GET-TIME, and TIME-UNITS-PER-SECOND to your implementation +;;; for the best results. If GET-CONS is not specified for your +;;; implementation, no consing information will be reported. The other +;;; functions will default to working forms, albeit inefficient, in +;;; non-CMU implementations. If you tailor these functions for a particular +;;; version of Common Lisp, we'd appreciate receiving the code. +;;; + +;;; **************************************************************** +;;; Usage Notes **************************************************** +;;; **************************************************************** +;;; +;;; SUGGESTED USAGE: +;;; +;;; Start by monitoring big pieces of the program, then carefully choose +;;; which functions close to, but not in, the inner loop are to be +;;; monitored next. Don't monitor functions that are called by other +;;; monitored functions: you will only confuse yourself. +;;; +;;; If the per-call time reported is less than 1/10th of a second, then +;;; consider the clock resolution and profiling overhead before you believe +;;; the time. It may be that you will need to run your program many times +;;; in order to average out to a higher resolution. +;;; +;;; The easiest way to use this package is to load it and execute either +;;; (swank-monitor:with-monitoring (names*) () +;;; your-forms*) +;;; or +;;; (swank-monitor:monitor-form your-form) +;;; The former allows you to specify which functions will be monitored; the +;;; latter monitors all functions in the current package. Both automatically +;;; produce a table of statistics. Other variants can be constructed from +;;; the monitoring primitives, which are described below, along with a +;;; fuller description of these two macros. +;;; +;;; For best results, compile this file before using. +;;; +;;; +;;; CLOCK RESOLUTION: +;;; +;;; Unless you are very lucky, the length of your machine's clock "tick" is +;;; probably much longer than the time it takes a simple function to run. +;;; For example, on the IBM RT, the clock resolution is 1/50th of a second. +;;; This means that if a function is only called a few times, then only the +;;; first couple of decimal places are really meaningful. +;;; +;;; +;;; MONITORING OVERHEAD: +;;; +;;; The added monitoring code takes time to run every time that the monitored +;;; function is called, which can disrupt the attempt to collect timing +;;; information. In order to avoid serious inflation of the times for functions +;;; that take little time to run, an estimate of the overhead due to monitoring +;;; is subtracted from the times reported for each function. +;;; +;;; Although this correction works fairly well, it is not totally accurate, +;;; resulting in times that become increasingly meaningless for functions +;;; with short runtimes. For example, subtracting the estimated overhead +;;; may result in negative times for some functions. This is only a concern +;;; when the estimated profiling overhead is many times larger than +;;; reported total CPU time. +;;; +;;; If you monitor functions that are called by monitored functions, in +;;; :inclusive mode the monitoring overhead for the inner function is +;;; subtracted from the CPU time for the outer function. [We do this by +;;; counting for each function not only the number of calls to *this* +;;; function, but also the number of monitored calls while it was running.] +;;; In :exclusive mode this is not necessary, since we subtract the +;;; monitoring time of inner functions, overhead & all. +;;; +;;; Otherwise, the estimated monitoring overhead is not represented in the +;;; reported total CPU time. The sum of total CPU time and the estimated +;;; monitoring overhead should be close to the total CPU time for the +;;; entire monitoring run (as determined by TIME). +;;; +;;; A timing overhead factor is computed at load time. This will be incorrect +;;; if the monitoring code is run in a different environment than this file +;;; was loaded in. For example, saving a core image on a high performance +;;; machine and running it on a low performance one will result in the use +;;; of an erroneously small overhead factor. +;;; +;;; +;;; If your times vary widely, possible causes are: +;;; - Garbage collection. Try turning it off, then running your code. +;;; Be warned that monitoring code will probably cons when it does +;;; (get-internal-run-time). +;;; - Swapping. If you have enough memory, execute your form once +;;; before monitoring so that it will be swapped into memory. Otherwise, +;;; get a bigger machine! +;;; - Resolution of internal-time-units-per-second. If this value is +;;; too low, then the timings become wild. You can try executing more +;;; of whatever your test is, but that will only work if some of your +;;; paths do not match the timer resolution. +;;; internal-time-units-per-second is so coarse -- on a Symbolics it is +;;; 977, in MACL it is 60. +;;; +;;; + +;;; **************************************************************** +;;; Interface ****************************************************** +;;; **************************************************************** +;;; +;;; WITH-MONITORING (&rest functions) [Macro] +;;; (&optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time)) +;;; &body body +;;; The named functions will be set up for monitoring, the body forms executed, +;;; a table of results printed, and the functions unmonitored. The nested, +;;; threshold, and key arguments are passed to report-monitoring below. +;;; +;;; MONITOR-FORM form [Macro] +;;; &optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; All functions in the current package are set up for monitoring while +;;; the form is executed, and automatically unmonitored after a table of +;;; results has been printed. The nested, threshold, and key arguments +;;; are passed to report-monitoring below. +;;; +;;; *MONITORED-FUNCTIONS* [Variable] +;;; This holds a list of all functions that are currently being monitored. +;;; +;;; MONITOR &rest names [Macro] +;;; The named functions will be set up for monitoring by augmenting +;;; their function definitions with code that gathers statistical information +;;; about code performance. As with the TRACE macro, the function names are +;;; not evaluated. Calls the function SWANK-MONITOR::MONITORING-ENCAPSULATE on each +;;; function name. If no names are specified, returns a list of all +;;; monitored functions. +;;; +;;; If name is not a symbol, it is evaled to return the appropriate +;;; closure. This allows you to monitor closures stored anywhere like +;;; in a variable, array or structure. Most other monitoring packages +;;; can't handle this. +;;; +;;; MONITOR-ALL &optional (package *package*) [Function] +;;; Monitors all functions in the specified package, which defaults to +;;; the current package. +;;; +;;; UNMONITOR &rest names [Macro] +;;; Removes monitoring code from the named functions. If no names are +;;; specified, all currently monitored functions are unmonitored. +;;; +;;; RESET-MONITORING-INFO name [Function] +;;; Resets the monitoring statistics for the specified function. +;;; +;;; RESET-ALL-MONITORING [Function] +;;; Resets the monitoring statistics for all monitored functions. +;;; +;;; MONITORED name [Function] +;;; Predicate to test whether a function is monitored. +;;; +;;; REPORT-MONITORING &optional names [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; Creates a table of monitoring information for the specified list +;;; of names, and displays the table using display-monitoring-results. +;;; If names is :all or nil, uses all currently monitored functions. +;;; Takes the following arguments: +;;; - NESTED specifies whether nested calls of monitored functions +;;; are included in the times for monitored functions. +;;; o If :inclusive, the per-function information is for the entire +;;; duration of the monitored function, including any calls to +;;; other monitored functions. If functions A and B are monitored, +;;; and A calls B, then the accumulated time and consing for A will +;;; include the time and consing of B. Note: if a function calls +;;; itself recursively, the time spent in the inner call(s) may +;;; be counted several times. +;;; o If :exclusive, the information excludes time attributed to +;;; calls to other monitored functions. This is the default. +;;; - THRESHOLD specifies that only functions which have been executed +;;; more than threshold percent of the time will be reported. Defaults +;;; to 1%. If a threshold of 0 is specified, all functions are listed, +;;; even those with 0 or negative running times (see note on overhead). +;;; - KEY specifies that the table be sorted by one of the following +;;; sort keys: +;;; :function alphabetically by function name +;;; :percent-time by percent of total execution time +;;; :percent-cons by percent of total consing +;;; :calls by number of times the function was called +;;; :time-per-call by average execution time per function +;;; :cons-per-call by average consing per function +;;; :time same as :percent-time +;;; :cons same as :percent-cons +;;; +;;; REPORT &key (names :all) [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (sort-key :percent-time) +;;; (ignore-no-calls nil) +;;; +;;; Same as REPORT-MONITORING but we use a nicer keyword interface. +;;; +;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function] +;;; (key :percent-time) +;;; Prints a table showing for each named function: +;;; - the total CPU time used in that function for all calls +;;; - the total number of bytes consed in that function for all calls +;;; - the total number of calls +;;; - the average amount of CPU time per call +;;; - the average amount of consing per call +;;; - the percent of total execution time spent executing that function +;;; - the percent of total consing spent consing in that function +;;; Summary totals of the CPU time, consing, and calls columns are printed. +;;; An estimate of the monitoring overhead is also printed. May be run +;;; even after unmonitoring all the functions, to play with the data. +;;; +;;; SAMPLE TABLE: +#| + Cons + % % Per Total Total +Function Time Cons Calls Sec/Call Call Time Cons +---------------------------------------------------------------------- +FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0 +GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0 +GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0 +FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0 +---------------------------------------------------------------------- +TOTAL: 1173 0.828950 0 +Estimated total monitoring overhead: 0.88 seconds +|# + +;;; **************************************************************** +;;; METERING ******************************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Warn people using the wrong Lisp +;;; ******************************** + +#-(or clisp openmcl) +(warn "metering.lisp does not support your Lisp implementation!") + +;;; ******************************** +;;; Packages *********************** +;;; ******************************** + +;;; For CLtL2 compatible lisps + +(defpackage "SWANK-MONITOR" (:use "COMMON-LISP") + (:export "*MONITORED-FUNCTIONS*" + "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM" + "WITH-MONITORING" + "RESET-MONITORING-INFO" "RESET-ALL-MONITORING" + "MONITORED" + "REPORT-MONITORING" + "DISPLAY-MONITORING-RESULTS" + "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE" + "REPORT")) +(in-package "SWANK-MONITOR") + +;;; Warn user if they're loading the source instead of compiling it first. +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + +;;; ******************************** +;;; Version ************************ +;;; ******************************** + +(defparameter *metering-version* "v2.1 25-JAN-94" + "Current version number/date for Metering.") + + +;;; **************************************************************** +;;; Implementation Dependent Definitions *************************** +;;; **************************************************************** + +;;; ******************************** +;;; Timing Functions *************** +;;; ******************************** +;;; The get-time function is called to find the total number of ticks since +;;; the beginning of time. time-units-per-second allows us to convert units +;;; to seconds. + +#-(or clisp openmcl) +(eval-when (compile eval) + (warn + "You may want to supply implementation-specific get-time functions.")) + +(defconstant time-units-per-second internal-time-units-per-second) + +#+openmcl +(progn + (deftype time-type () 'unsigned-byte) + (deftype consing-type () 'unsigned-byte)) + +(defmacro get-time () + `(the time-type (get-internal-run-time))) + +;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of +;;; milliseconds spent during GC. We could subtract this from +;;; the value returned by get-internal-run-time to eliminate +;;; the effect of GC on the timing values, but we prefer to let +;;; the user run without GC on. If the application is so big that +;;; it requires GC to complete, then the GC times are part of the +;;; cost of doing business, and will average out in the long run. +;;; If it seems really important to a user that GC times not be +;;; counted, then uncomment the following three lines and read-time +;;; conditionalize the definition of get-time above with #-:openmcl. +;#+openmcl +;(defmacro get-time () +; `(the time-type (- (get-internal-run-time) (ccl:gctime)))) + +;;; ******************************** +;;; Consing Functions ************** +;;; ******************************** +;;; The get-cons macro is called to find the total number of bytes +;;; consed since the beginning of time. + +#+clisp +(defun get-cons () + (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount) + (sys::%%time) + (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount)) + (dpb space1 (byte 24 24) space2))) + +;;; Macintosh Common Lisp 2.0 +;;; Note that this includes bytes that were allocated during GC. +;;; We could subtract this out by advising GC like we did under +;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't +;;; run without GC, then the bytes consed during GC are a cost of +;;; running their program. Metering the code a few times will +;;; avoid the consing values being too lopsided. If a user really really +;;; wants to subtract out the consing during GC, replace the following +;;; two lines with the commented out code. +#+openmcl +(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated))) + +#-(or clisp openmcl) +(progn + (eval-when (compile eval) + (warn "No consing will be reported unless a get-cons function is ~ + defined.")) + + (defmacro get-cons () '(the consing-type 0))) + +;; actually, neither `get-cons' nor `get-time' are used as is, +;; but only in the following macro `with-time/cons' +#-:clisp +(defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((start-cons (gensym "START-CONS-")) + (start-time (gensym "START-TIME-"))) + `(let ((,start-time (get-time)) (,start-cons (get-cons))) + (declare (type time-type ,start-time) + (type consing-type ,start-cons)) + (multiple-value-prog1 ,form + (let ((,delta-time (- (get-time) ,start-time)) + (,delta-cons (- (get-cons) ,start-cons))) + ,@post-process))))) + +#+clisp +(progn + (defmacro delta4 (nv1 nv2 ov1 ov2 by) + `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2)) + + (let ((del (find-symbol "DELTA4" "SYS"))) + (when del (setf (fdefinition 'delta4) (fdefinition del)))) + + (if (< internal-time-units-per-second 1000000) + ;; TIME_1: AMIGA, OS/2, UNIX_TIMES + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16)) + ;; TIME_2: other UNIX, WIN32 + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second) + (- ,new-time2 ,old-time2)))) + + (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2) + `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24)) + + ;; avoid consing: when the application conses a lot, + ;; get-cons may return a bignum, so we really should not use it. + (defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-")) + (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-")) + (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-")) + (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-")) + (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym))) + `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2 + ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) + (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (multiple-value-prog1 ,form + (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2 + ,gc1 ,gc2 ,end-cons1 ,end-cons2) + (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (let ((,delta-time (delta4-time ,end-time1 ,end-time2 + ,beg-time1 ,beg-time2)) + (,delta-cons (delta4-cons ,end-cons1 ,end-cons2 + ,beg-cons1 ,beg-cons2))) + ,@post-process))))))) + +;;; ******************************** +;;; Required Arguments ************* +;;; ******************************** +;;; +;;; Required (Fixed) vs Optional Args +;;; +;;; To avoid unnecessary consing in the "encapsulation" code, we find out the +;;; number of required arguments, and use &rest to capture only non-required +;;; arguments. The function Required-Arguments returns two values: the first +;;; is the number of required arguments, and the second is T iff there are any +;;; non-required arguments (e.g. &optional, &rest, &key). + +;;; Lucid, Allegro, and Macintosh Common Lisp +#+openmcl +(defun required-arguments (name) + (let* ((function (symbol-function name)) + (args (ccl:arglist function)) + (pos (position-if #'(lambda (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 1) + (char= (schar name 0) + #\&))))) + args))) + (if pos + (values pos t) + (values (length args) nil)))) + +#+clisp +(defun required-arguments (name) + (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p) + (sys::function-signature name t) + (if name ; no error + (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p)) + (values 0 t)))) + +#-(or clisp openmcl) +(progn + (eval-when (compile eval) + (warn + "You may want to add an implementation-specific ~ +Required-Arguments function.")) + (eval-when (load eval) + (defun required-arguments (name) + (declare (ignore name)) + (values 0 t)))) + +#| +;;;Examples +(defun square (x) (* x x)) +(defun square2 (x &optional y) (* x x y)) +(defun test (x y &optional (z 3)) 3) +(defun test2 (x y &optional (z 3) &rest fred) 3) + +(required-arguments 'square) => 1 nil +(required-arguments 'square2) => 1 t +(required-arguments 'test) => 2 t +(required-arguments 'test2) => 2 t +|# + + +;;; **************************************************************** +;;; Main METERING Code ********************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Global Variables *************** +;;; ******************************** +(defvar *MONITOR-TIME-OVERHEAD* nil + "The amount of time an empty monitored function costs.") +(defvar *MONITOR-CONS-OVERHEAD* nil + "The amount of cons an empty monitored function costs.") + +(defvar *TOTAL-TIME* 0 + "Total amount of time monitored so far.") +(defvar *TOTAL-CONS* 0 + "Total amount of consing monitored so far.") +(defvar *TOTAL-CALLS* 0 + "Total number of calls monitored so far.") +(proclaim '(type time-type *total-time*)) +(proclaim '(type consing-type *total-cons*)) +(proclaim '(fixnum *total-calls*)) + +;;; ******************************** +;;; Accessor Functions ************* +;;; ******************************** +;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables +;;; containing closures. +(defmacro PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + ;; Note that (fboundp 'fdefinition) returns T even if fdefinition + ;; is a macro, which is what we want. + (if (fboundp 'fdefinition) + `(if (fboundp ,function-place) + (fdefinition ,function-place) + (eval ,function-place)) + `(if (symbolp ,function-place) + (symbol-function ,function-place) + (eval ,function-place)))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + (if (fboundp 'fdefinition) + ;; If we're conforming to CLtL2, use fdefinition here. + `(if (fboundp ,function-place) + (setf (fdefinition ,function-place) ,function) + (eval '(setf ,function-place ',function))) + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function))))) + +#| +;;; before using fdefinition +(defun PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + (if (symbolp function-place) + (symbol-function function-place) + (eval function-place))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function)))) +|# + +(defun PLACE-FBOUNDP (function-place) + "Test to see if FUNCTION-PLACE is a function." + ;; probably should be + #|(or (and (symbolp function-place)(fboundp function-place)) + (functionp (place-function function-place)))|# + (if (symbolp function-place) + (fboundp function-place) + (functionp (place-function function-place)))) + +(defun PLACE-MACROP (function-place) + "Test to see if FUNCTION-PLACE is a macro." + (when (symbolp function-place) + (macro-function function-place))) + +;;; ******************************** +;;; Measurement Tables ************* +;;; ******************************** +(defvar *monitored-functions* nil + "List of monitored symbols.") + +;;; We associate a METERING-FUNCTIONS structure with each monitored function +;;; name or other closure. This holds the functions that we call to manipulate +;;; the closure which implements the encapsulation. +;;; +(defstruct metering-functions + (name nil) + (old-definition nil :type function) + (new-definition nil :type function) + (read-metering nil :type function) + (reset-metering nil :type function)) + +;;; In general using hash tables in time-critical programs is a bad idea, +;;; because when one has to grow the table and rehash everything, the +;;; timing becomes grossly inaccurate. In this case it is not an issue +;;; because all inserting of entries in the hash table occurs before the +;;; timing commences. The only circumstance in which this could be a +;;; problem is if the lisp rehashes on the next reference to the table, +;;; instead of when the entry which forces a rehash was inserted. +;;; +;;; Note that a similar kind of problem can occur with GC, which is why +;;; one should turn off GC when monitoring code. +;;; +(defvar *monitor* (make-hash-table :test #'equal) + "Hash table in which METERING-FUNCTIONS structures are stored.") +(defun get-monitor-info (name) + (gethash name *monitor*)) +(defsetf get-monitor-info (name) (info) + `(setf (gethash ,name *monitor*) ,info)) + +(defun MONITORED (function-place) + "Test to see if a FUNCTION-PLACE is monitored." + (and (place-fboundp function-place) ; this line necessary? + (get-monitor-info function-place))) + +(defun reset-monitoring-info (name) + "Reset the monitoring info for the specified function." + (let ((finfo (get-monitor-info name))) + (when finfo + (funcall (metering-functions-reset-metering finfo))))) +(defun reset-all-monitoring () + "Reset monitoring info for all functions." + (setq *total-time* 0 + *total-cons* 0 + *total-calls* 0) + (dolist (symbol *monitored-functions*) + (when (monitored symbol) + (reset-monitoring-info symbol)))) + +(defun monitor-info-values (name &optional (nested :exclusive) warn) + "Returns monitoring information values for the named function, +adjusted for overhead." + (let ((finfo (get-monitor-info name))) + (if finfo + (multiple-value-bind (inclusive-time inclusive-cons + exclusive-time exclusive-cons + calls nested-calls) + (funcall (metering-functions-read-metering finfo)) + (unless (or (null warn) + (eq (place-function name) + (metering-functions-new-definition finfo))) + (warn "Funtion ~S has been redefined, so times may be inaccurate.~@ + MONITOR it again to record calls to the new definition." + name)) + (case nested + (:exclusive (values calls + nested-calls + (- exclusive-time + (* calls *monitor-time-overhead*)) + (- exclusive-cons + (* calls *monitor-cons-overhead*)))) + ;; In :inclusive mode, subtract overhead for all the + ;; called functions as well. Nested-calls includes the + ;; calls of the function as well. [Necessary 'cause of + ;; functions which call themselves recursively.] + (:inclusive (values calls + nested-calls + (- inclusive-time + (* nested-calls ;(+ calls) + *monitor-time-overhead*)) + (- inclusive-cons + (* nested-calls ;(+ calls) + *monitor-cons-overhead*)))))) + (values 0 0 0 0)))) + +;;; ******************************** +;;; Encapsulate ******************** +;;; ******************************** +(eval-when (compile load eval) +;; Returns a lambda expression for a function that, when called with the +;; function name, will set up that function for metering. +;; +;; A function is monitored by replacing its definition with a closure +;; created by the following function. The closure records the monitoring +;; data, and updates the data with each call of the function. +;; +;; Other closures are used to read and reset the data. +(defun make-monitoring-encapsulation (min-args optionals-p) + (let (required-args) + (dotimes (i min-args) (push (gensym) required-args)) + `(lambda (name) + (let ((inclusive-time 0) + (inclusive-cons 0) + (exclusive-time 0) + (exclusive-cons 0) + (calls 0) + (nested-calls 0) + (old-definition (place-function name))) + (declare (type time-type inclusive-time) + (type time-type exclusive-time) + (type consing-type inclusive-cons) + (type consing-type exclusive-cons) + (fixnum calls) + (fixnum nested-calls)) + (pushnew name *monitored-functions*) + + (setf (place-function name) + #'(lambda (,@required-args + ,@(when optionals-p + `(&rest optional-args))) + (let ((prev-total-time *total-time*) + (prev-total-cons *total-cons*) + (prev-total-calls *total-calls*) + ;; (old-time inclusive-time) + ;; (old-cons inclusive-cons) + ;; (old-nested-calls nested-calls) + ) + (declare (type time-type prev-total-time) + (type consing-type prev-total-cons) + (fixnum prev-total-calls)) + (with-time/cons (delta-time delta-cons) + ;; form + ,(if optionals-p + `(apply old-definition + ,@required-args optional-args) + `(funcall old-definition ,@required-args)) + ;; post-processing: + ;; Calls + (incf calls) + (incf *total-calls*) + ;; nested-calls includes this call + (incf nested-calls (the fixnum + (- *total-calls* + prev-total-calls))) + ;; (setf nested-calls (+ old-nested-calls + ;; (- *total-calls* + ;; prev-total-calls))) + ;; Time + ;; Problem with inclusive time is that it + ;; currently doesn't add values from recursive + ;; calls to the same function. Change the + ;; setf to an incf to fix this? + (incf inclusive-time (the time-type delta-time)) + ;; (setf inclusive-time (+ delta-time old-time)) + (incf exclusive-time (the time-type + (+ delta-time + (- prev-total-time + *total-time*)))) + (setf *total-time* (the time-type + (+ delta-time + prev-total-time))) + ;; Consing + (incf inclusive-cons (the consing-type delta-cons)) + ;; (setf inclusive-cons (+ delta-cons old-cons)) + (incf exclusive-cons (the consing-type + (+ delta-cons + (- prev-total-cons + *total-cons*)))) + (setf *total-cons* + (the consing-type + (+ delta-cons prev-total-cons))))))) + (setf (get-monitor-info name) + (make-metering-functions + :name name + :old-definition old-definition + :new-definition (place-function name) + :read-metering #'(lambda () + (values inclusive-time + inclusive-cons + exclusive-time + exclusive-cons + calls + nested-calls)) + :reset-metering #'(lambda () + (setq inclusive-time 0 + inclusive-cons 0 + exclusive-time 0 + exclusive-cons 0 + calls 0 + nested-calls 0) + t))))))) +);; End of EVAL-WHEN + +;;; For efficiency reasons, we precompute the encapsulation functions +;;; for a variety of combinations of argument structures +;;; (min-args . optional-p). These are stored in the following hash table +;;; along with any new ones we encounter. Since we're now precomputing +;;; closure functions for common argument signatures, this eliminates +;;; the former need to call COMPILE for each monitored function. +(eval-when (compile eval) + (defconstant precomputed-encapsulations 8)) + +(defvar *existing-encapsulations* (make-hash-table :test #'equal)) +(defun find-encapsulation (min-args optionals-p) + (or (gethash (cons min-args optionals-p) *existing-encapsulations*) + (setf (gethash (cons min-args optionals-p) *existing-encapsulations*) + (compile nil + (make-monitoring-encapsulation min-args optionals-p))))) + +(macrolet ((frob () + (let ((res ())) + (dotimes (i precomputed-encapsulations) + (push `(setf (gethash '(,i . nil) *existing-encapsulations*) + #',(make-monitoring-encapsulation i nil)) + res) + (push `(setf (gethash '(,i . t) *existing-encapsulations*) + #',(make-monitoring-encapsulation i t)) + res)) + `(progn ,@res)))) + (frob)) + +(defun monitoring-encapsulate (name &optional warn) + "Monitor the function Name. If already monitored, unmonitor first." + ;; Saves the current definition of name and inserts a new function which + ;; returns the result of evaluating body. + (cond ((not (place-fboundp name)) ; not a function + (when warn + (warn "Ignoring undefined function ~S." name))) + ((place-macrop name) ; a macro + (when warn + (warn "Ignoring macro ~S." name))) + (t ; tis a function + (when (get-monitor-info name) ; monitored + (when warn + (warn "~S already monitored, so unmonitoring it first." name)) + (monitoring-unencapsulate name)) + (multiple-value-bind (min-args optionals-p) + (required-arguments name) + (funcall (find-encapsulation min-args optionals-p) name))))) + +(defun monitoring-unencapsulate (name &optional warn) + "Removes monitoring encapsulation code from around Name." + (let ((finfo (get-monitor-info name))) + (when finfo ; monitored + (remprop name 'metering-functions) + (setq *monitored-functions* + (remove name *monitored-functions* :test #'equal)) + (if (eq (place-function name) + (metering-functions-new-definition finfo)) + (setf (place-function name) + (metering-functions-old-definition finfo)) + (when warn + (warn "Preserving current definition of redefined function ~S." + name)))))) + +;;; ******************************** +;;; Main Monitoring Functions ****** +;;; ******************************** +(defmacro MONITOR (&rest names) + "Monitor the named functions. As in TRACE, the names are not evaluated. + If a function is already monitored, then unmonitor and remonitor (useful + to notice function redefinition). If a name is undefined, give a warning + and ignore it. See also unmonitor, report-monitoring, + display-monitoring-results and reset-time." + `(progn + ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names) + *monitored-functions*)) + +(defmacro UNMONITOR (&rest names) + "Remove the monitoring on the named functions. + Names defaults to the list of all currently monitored functions." + `(dolist (name ,(if names `',names '*monitored-functions*) (values)) + (monitoring-unencapsulate name))) + +(defun MONITOR-ALL (&optional (package *package*)) + "Monitor all functions in the specified package." + (let ((package (if (packagep package) + package + (find-package package)))) + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (monitoring-encapsulate symbol))))) + +(defmacro MONITOR-FORM (form + &optional (nested :exclusive) (threshold 0.01) + (key :percent-time)) + "Monitor the execution of all functions in the current package +during the execution of FORM. All functions that are executed above +THRESHOLD % will be reported." + `(unwind-protect + (progn + (monitor-all) + (reset-all-monitoring) + (prog1 + (time ,form) + (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls))) + (unmonitor))) + +(defmacro WITH-MONITORING ((&rest functions) + (&optional (nested :exclusive) + (threshold 0.01) + (key :percent-time)) + &body body) + "Monitor the specified functions during the execution of the body." + `(unwind-protect + (progn + (dolist (fun ',functions) + (monitoring-encapsulate fun)) + (reset-all-monitoring) + ,@body + (report-monitoring :all ,nested ,threshold ,key)) + (unmonitor))) + +;;; ******************************** +;;; Overhead Calculations ********** +;;; ******************************** +(defconstant overhead-iterations 5000 + "Number of iterations over which the timing overhead is averaged.") + +;;; Perhaps this should return something to frustrate clever compilers. +(defun STUB-FUNCTION (x) + (declare (ignore x)) + nil) +(proclaim '(notinline stub-function)) + +(defun SET-MONITOR-OVERHEAD () + "Determines the average overhead of monitoring by monitoring the execution +of an empty function many times." + (setq *monitor-time-overhead* 0 + *monitor-cons-overhead* 0) + (stub-function nil) + (monitor stub-function) + (reset-all-monitoring) + (let ((overhead-function (symbol-function 'stub-function))) + (dotimes (x overhead-iterations) + (funcall overhead-function overhead-function))) +; (dotimes (x overhead-iterations) +; (stub-function nil)) + (let ((fiter (float overhead-iterations))) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values 'stub-function) + (declare (ignore calls nested-calls)) + (setq *monitor-time-overhead* (/ time fiter) + *monitor-cons-overhead* (/ cons fiter)))) + (unmonitor stub-function)) +(set-monitor-overhead) + +;;; ******************************** +;;; Report Data ******************** +;;; ******************************** +(defvar *monitor-results* nil + "A table of monitoring statistics is stored here.") +(defvar *no-calls* nil + "A list of monitored functions which weren't called.") +(defvar *estimated-total-overhead* 0) +;; (proclaim '(type time-type *estimated-total-overhead*)) + +(defstruct (monitoring-info + (:conc-name m-info-) + (:constructor make-monitoring-info + (name calls time cons + percent-time percent-cons + time-per-call cons-per-call))) + name + calls + time + cons + percent-time + percent-cons + time-per-call + cons-per-call) + +(defun REPORT (&key (names :all) + (nested :exclusive) + (threshold 0.01) + (sort-key :percent-time) + (ignore-no-calls nil)) + "Same as REPORT-MONITORING but with a nicer keyword interface" + (declare (type (member :function :percent-time :time :percent-cons + :cons :calls :time-per-call :cons-per-call) + sort-key) + (type (member :inclusive :exclusive) nested)) + (report-monitoring names nested threshold sort-key ignore-no-calls)) + +(defun REPORT-MONITORING (&optional names + (nested :exclusive) + (threshold 0.01) + (key :percent-time) + ignore-no-calls) + "Report the current monitoring state. +The percentage of the total time spent executing unmonitored code +in each function (:exclusive mode), or total time (:inclusive mode) +will be printed together with the number of calls and +the unmonitored time per call. Functions that have been executed +below THRESHOLD % of the time will not be reported. To report on all +functions set NAMES to be either NIL or :ALL." + (when (or (null names) (eq names :all)) (setq names *monitored-functions*)) + + (let ((total-time 0) + (total-cons 0) + (total-calls 0)) + ;; Compute overall time and consing. + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested :warn) + (declare (ignore nested-calls)) + (incf total-calls calls) + (incf total-time time) + (incf total-cons cons))) + ;; Total overhead. + (setq *estimated-total-overhead* + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second)) + ;; Assemble data for only the specified names (all monitored functions) + (if (zerop total-time) + (format *trace-output* "Not enough execution time to monitor.") + (progn + (setq *monitor-results* nil *no-calls* nil) + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested) + (declare (ignore nested-calls)) + (when (minusp time) (setq time 0.0)) + (when (minusp cons) (setq cons 0.0)) + (if (zerop calls) + (push (if (symbolp name) + (symbol-name name) + (format nil "~S" name)) + *no-calls*) + (push (make-monitoring-info + (format nil "~S" name) ; name + calls ; calls + (/ time (float time-units-per-second)) ; time in secs + (round cons) ; consing + (/ time (float total-time)) ; percent-time + (if (zerop total-cons) 0 + (/ cons (float total-cons))) ; percent-cons + (/ (/ time (float calls)) ; time-per-call + time-units-per-second) ; sec/call + (round (/ cons (float calls)))) ; cons-per-call + *monitor-results*)))) + (display-monitoring-results threshold key ignore-no-calls))))) + +(defun display-monitoring-results (&optional (threshold 0.01) + (key :percent-time) + (ignore-no-calls t)) + (let ((max-length 8) ; Function header size + (max-cons-length 8) + (total-time 0.0) + (total-consed 0) + (total-calls 0) + (total-percent-time 0) + (total-percent-cons 0)) + (sort-results key) + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (setq max-length + (max max-length + (length (m-info-name result)))) + (setq max-cons-length + (max max-cons-length + (m-info-cons-per-call result))))) + (incf max-length 2) + (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10)))) + (format *trace-output* + "~%~%~ + ~VT ~VA~ + ~% ~VT % % ~VA ~ +Total Total~ + ~%Function~VT Time Cons Calls Sec/Call ~VA ~ +Time Cons~ + ~%~V,,,'-A" + max-length + max-cons-length "Cons" + max-length + max-cons-length "Per" + max-length + max-cons-length "Call" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-") + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (format *trace-output* + "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D" + (m-info-name result) + max-length + (* 100 (m-info-percent-time result)) + (* 100 (m-info-percent-cons result)) + (m-info-calls result) + (m-info-time-per-call result) + max-cons-length + (m-info-cons-per-call result) + (m-info-time result) + (m-info-cons result)) + (incf total-time (m-info-time result)) + (incf total-consed (m-info-cons result)) + (incf total-calls (m-info-calls result)) + (incf total-percent-time (m-info-percent-time result)) + (incf total-percent-cons (m-info-percent-cons result)))) + (format *trace-output* + "~%~V,,,'-A~ + ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~ + ~%Estimated monitoring overhead: ~5,2F seconds~ + ~%Estimated total monitoring overhead: ~5,2F seconds" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-" + max-length + (* 100 total-percent-time) + (* 100 total-percent-cons) + total-calls + max-cons-length " " + total-time total-consed + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second) + *estimated-total-overhead*) + (when (and (not ignore-no-calls) *no-calls*) + (setq *no-calls* (sort *no-calls* #'string<)) + (let ((num-no-calls (length *no-calls*))) + (if (> num-no-calls 20) + (format *trace-output* + "~%~@(~r~) monitored functions were not called. ~ + ~%See the variable swank-monitor::*no-calls* for a list." + num-no-calls) + (format *trace-output* + "~%The following monitored functions were not called:~ + ~%~{~<~%~:; ~A~>~}~%" + *no-calls*)))) + (values))) + +(defun sort-results (&optional (key :percent-time)) + (setq *monitor-results* + (case key + (:function (sort *monitor-results* #'string> + :key #'m-info-name)) + ((:percent-time :time) (sort *monitor-results* #'> + :key #'m-info-time)) + ((:percent-cons :cons) (sort *monitor-results* #'> + :key #'m-info-cons)) + (:calls (sort *monitor-results* #'> + :key #'m-info-calls)) + (:time-per-call (sort *monitor-results* #'> + :key #'m-info-time-per-call)) + (:cons-per-call (sort *monitor-results* #'> + :key #'m-info-cons-per-call))))) + +;;; *END OF FILE* + + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/nregex.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/nregex.lisp new file mode 100644 index 0000000..43586ef --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/nregex.lisp @@ -0,0 +1,523 @@ +;;; +;;; This code was written by: +;;; +;;; Lawrence E. Freil +;;; National Science Center Foundation +;;; Augusta, Georgia 30909 +;;; +;;; This program was released into the public domain on 2005-08-31. +;;; (See the slime-devel mailing list archive for details.) +;;; +;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression +;;; parser. +;;; +;;; This regular expression parser operates by taking a +;;; regular expression and breaking it down into a list +;;; consisting of lisp expressions and flags. The list +;;; of lisp expressions is then taken in turned into a +;;; lambda expression that can be later applied to a +;;; string argument for parsing. +;;;; +;;;; Modifications made 6 March 2001 By Chris Double (chris@double.co.nz) +;;;; to get working with Corman Lisp 1.42, add package statement and export +;;;; relevant functions. +;;;; + +(in-package :cl-user) + +;; Renamed to slime-nregex avoid name clashes with other versions of +;; this file. -- he + +;;;; CND - 6/3/2001 +(defpackage slime-nregex + (:use #:common-lisp) + (:export + #:regex + #:regex-compile + )) + +;;;; CND - 6/3/2001 +(in-package :slime-nregex) + +;;; +;;; First we create a copy of macros to help debug the beast +(eval-when (:compile-toplevel :load-toplevel :execute) +(defvar *regex-debug* nil) ; Set to nil for no debugging code +) + +(defmacro info (message &rest args) + (if *regex-debug* + `(format *standard-output* ,message ,@args))) + +;;; +;;; Declare the global variables for storing the paren index list. +;;; +(defvar *regex-groups* (make-array 10)) +(defvar *regex-groupings* 0) + +;;; +;;; Declare a simple interface for testing. You probably wouldn't want +;;; to use this interface unless you were just calling this once. +;;; +(defun regex (expression string) + "Usage: (regex &optional invert) + Returns either the quoted character or a simple bit vector of bits set for + the matching values" + (let ((first (char char-string 0)) + (result (char char-string 0)) + (used-length 1)) + (cond ((eql first #\n) + (setf result #\NewLine)) + ((eql first #\c) + (setf result #\Return)) + ((eql first #\t) + (setf result #\Tab)) + ((eql first #\d) + (setf result #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\D) + (setf result #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\w) + (setf result #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\W) + (setf result #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\b) + (setf result #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\B) + (setf result #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\s) + (setf result #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\S) + (setf result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((and (>= (char-code first) (char-code #\0)) + (<= (char-code first) (char-code #\9))) + (if (and (> (length char-string) 2) + (and (>= (char-code (char char-string 1)) (char-code #\0)) + (<= (char-code (char char-string 1)) (char-code #\9)) + (>= (char-code (char char-string 2)) (char-code #\0)) + (<= (char-code (char char-string 2)) (char-code #\9)))) + ;; + ;; It is a single character specified in octal + ;; + (progn + (setf result (do ((x 0 (1+ x)) + (return 0)) + ((= x 2) return) + (setf return (+ (* return 8) + (- (char-code (char char-string x)) + (char-code #\0)))))) + (setf used-length 3)) + ;; + ;; We have a group number replacement. + ;; + (let ((group (- (char-code first) (char-code #\0)))) + (setf result `((let ((nstring (subseq string (car (aref *regex-groups* ,group)) + (cadr (aref *regex-groups* ,group))))) + (if (< length (+ index (length nstring))) + (return-from compare nil)) + (if (not (string= string nstring + :start1 index + :end1 (+ index (length nstring)))) + (return-from compare nil) + (incf index (length nstring))))))))) + (t + (setf result first))) + (if (and (vectorp result) invert) + (bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t)) + (values result used-length))) + +;;; +;;; Now for the main regex compiler routine. +;;; +(defun regex-compile (source &key (anchored nil)) + "Usage: (regex-compile [ :anchored (t/nil) ]) + This function take a regular expression (supplied as source) and + compiles this into a lambda list that a string argument can then + be applied to. It is also possible to compile this lambda list + for better performance or to save it as a named function for later + use" + (info "Now entering regex-compile with \"~A\"~%" source) + ;; + ;; This routine works in two parts. + ;; The first pass take the regular expression and produces a list of + ;; operators and lisp expressions for the entire regular expression. + ;; The second pass takes this list and produces the lambda expression. + (let ((expression '()) ; holder for expressions + (group 1) ; Current group index + (group-stack nil) ; Stack of current group endings + (result nil) ; holder for built expression. + (fast-first nil)) ; holder for quick unanchored scan + ;; + ;; If the expression was an empty string then it alway + ;; matches (so lets leave early) + ;; + (if (= (length source) 0) + (return-from regex-compile + '(lambda (&rest args) + (declare (ignore args)) + t))) + ;; + ;; If the first character is a caret then set the anchored + ;; flags and remove if from the expression string. + ;; + (cond ((eql (char source 0) #\^) + (setf source (subseq source 1)) + (setf anchored t))) + ;; + ;; If the first sequence is .* then also set the anchored flags. + ;; (This is purely for optimization, it will work without this). + ;; + (if (>= (length source) 2) + (if (string= source ".*" :start1 0 :end1 2) + (setf anchored t))) + ;; + ;; Also, If this is not an anchored search and the first character is + ;; a literal, then do a quick scan to see if it is even in the string. + ;; If not then we can issue a quick nil, + ;; otherwise we can start the search at the matching character to skip + ;; the checks of the non-matching characters anyway. + ;; + ;; If I really wanted to speed up this section of code it would be + ;; easy to recognize the case of a fairly long multi-character literal + ;; and generate a Boyer-Moore search for the entire literal. + ;; + ;; I generate the code to do a loop because on CMU Lisp this is about + ;; twice as fast a calling position. + ;; + (if (and (not anchored) + (not (position (char source 0) *regex-special-chars*)) + (not (and (> (length source) 1) + (position (char source 1) *regex-special-chars*)))) + (setf fast-first `((if (not (dotimes (i length nil) + (if (eql (char string i) + ,(char source 0)) + (return (setf start i))))) + (return-from final-return nil))))) + ;; + ;; Generate the very first expression to save the starting index + ;; so that group 0 will be the entire string matched always + ;; + (add-exp '((setf (aref *regex-groups* 0) + (list index nil)))) + ;; + ;; Loop over each character in the regular expression building the + ;; expression list as we go. + ;; + (do ((eindex 0 (1+ eindex))) + ((= eindex (length source))) + (let ((current (char source eindex))) + (info "Now processing character ~A index = ~A~%" current eindex) + (case current + ((#\.) + ;; + ;; Generate code for a single wild character + ;; + (add-exp '((if (>= index length) + (return-from compare nil) + (incf index))))) + ((#\$) + ;; + ;; If this is the last character of the expression then + ;; anchor the end of the expression, otherwise let it slide + ;; as a standard character (even though it should be quoted). + ;; + (if (= eindex (1- (length source))) + (add-exp '((if (not (= index length)) + (return-from compare nil)))) + (add-exp '((if (not (and (< index length) + (eql (char string index) #\$))) + (return-from compare nil) + (incf index)))))) + ((#\*) + (add-exp '(ASTRISK))) + + ((#\+) + (add-exp '(PLUS))) + + ((#\?) + (add-exp '(QUESTION))) + + ((#\() + ;; + ;; Start a grouping. + ;; + (incf group) + (push group group-stack) + (add-exp `((setf (aref *regex-groups* ,(1- group)) + (list index nil)))) + (add-exp `(,group))) + ((#\)) + ;; + ;; End a grouping + ;; + (let ((group (pop group-stack))) + (add-exp `((setf (cadr (aref *regex-groups* ,(1- group))) + index))) + (add-exp `(,(- group))))) + ((#\[) + ;; + ;; Start of a range operation. + ;; Generate a bit-vector that has one bit per possible character + ;; and then on each character or range, set the possible bits. + ;; + ;; If the first character is carat then invert the set. + (let* ((invert (eql (char source (1+ eindex)) #\^)) + (bitstring (make-array 256 :element-type 'bit + :initial-element + (if invert 1 0))) + (set-char (if invert 0 1))) + (if invert (incf eindex)) + (do ((x (1+ eindex) (1+ x))) + ((eql (char source x) #\]) (setf eindex x)) + (info "Building range with character ~A~%" (char source x)) + (cond ((and (eql (char source (1+ x)) #\-) + (not (eql (char source (+ x 2)) #\]))) + (if (>= (char-code (char source x)) + (char-code (char source (+ 2 x)))) + (error "Invalid range \"~A-~A\". Ranges must be in acending order" + (char source x) (char source (+ 2 x)))) + (do ((j (char-code (char source x)) (1+ j))) + ((> j (char-code (char source (+ 2 x)))) + (incf x 2)) + (info "Setting bit for char ~A code ~A~%" (code-char j) j) + (setf (sbit bitstring j) set-char))) + (t + (cond ((not (eql (char source x) #\])) + (let ((char (char source x))) + ;; + ;; If the character is quoted then find out what + ;; it should have been + ;; + (if (eql (char source x) #\\ ) + (let ((length)) + (multiple-value-setq (char length) + (regex-quoted (subseq source x) invert)) + (incf x length))) + (info "Setting bit for char ~A code ~A~%" char (char-code char)) + (if (not (vectorp char)) + (setf (sbit bitstring (char-code (char source x))) set-char) + (bit-ior bitstring char t)))))))) + (add-exp `((let ((range ,bitstring)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil))))))) + ((#\\ ) + ;; + ;; Intreprete the next character as a special, range, octal, group or + ;; just the character itself. + ;; + (let ((length) + (value)) + (multiple-value-setq (value length) + (regex-quoted (subseq source (1+ eindex)) nil)) + (cond ((listp value) + (add-exp value)) + ((characterp value) + (add-exp `((if (not (and (< index length) + (eql (char string index) + ,value))) + (return-from compare nil) + (incf index))))) + ((vectorp value) + (add-exp `((let ((range ,value)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil))))))) + (incf eindex length))) + (t + ;; + ;; We have a literal character. + ;; Scan to see how many we have and if it is more than one + ;; generate a string= verses as single eql. + ;; + (let* ((lit "") + (term (dotimes (litindex (- (length source) eindex) nil) + (let ((litchar (char source (+ eindex litindex)))) + (if (position litchar *regex-special-chars*) + (return litchar) + (progn + (info "Now adding ~A index ~A to lit~%" litchar + litindex) + (setf lit (concatenate 'string lit + (string litchar))))))))) + (if (= (length lit) 1) + (add-exp `((if (not (and (< index length) + (eql (char string index) ,current))) + (return-from compare nil) + (incf index)))) + ;; + ;; If we have a multi-character literal then we must + ;; check to see if the next character (if there is one) + ;; is an astrisk or a plus or a question mark. If so then we must not use this + ;; character in the big literal. + (progn + (if (or (eql term #\*) + (eql term #\+) + (eql term #\?)) + (setf lit (subseq lit 0 (1- (length lit))))) + (add-exp `((if (< length (+ index ,(length lit))) + (return-from compare nil)) + (if (not (string= string ,lit :start1 index + :end1 (+ index ,(length lit)))) + (return-from compare nil) + (incf index ,(length lit))))))) + (incf eindex (1- (length lit)))))))) + ;; + ;; Plug end of list to return t. If we made it this far then + ;; We have matched! + (add-exp '((setf (cadr (aref *regex-groups* 0)) + index))) + (add-exp '((return-from final-return t))) + ;; +;;; (print expression) + ;; + ;; Now take the expression list and turn it into a lambda expression + ;; replacing the special flags with lisp code. + ;; For example: A BEGIN needs to be replace by an expression that + ;; saves the current index, then evaluates everything till it gets to + ;; the END then save the new index if it didn't fail. + ;; On an ASTRISK I need to take the previous expression and wrap + ;; it in a do that will evaluate the expression till an error + ;; occurs and then another do that encompases the remainder of the + ;; regular expression and iterates decrementing the index by one + ;; of the matched expression sizes and then returns nil. After + ;; the last expression insert a form that does a return t so that + ;; if the entire nested sub-expression succeeds then the loop + ;; is broken manually. + ;; + (setf result (copy-tree nil)) + ;; + ;; Reversing the current expression makes building up the + ;; lambda list easier due to the nexting of expressions when + ;; and astrisk has been encountered. + (setf expression (reverse expression)) + (do ((elt 0 (1+ elt))) + ((>= elt (length expression))) + (let ((piece (nth elt expression))) + ;; + ;; Now check for PLUS, if so then ditto the expression and then let the + ;; ASTRISK below handle the rest. + ;; + (cond ((eql piece 'PLUS) + (cond ((listp (nth (1+ elt) expression)) + (setf result (append (list (nth (1+ elt) expression)) + result))) + ;; + ;; duplicate the entire group + ;; NOTE: This hasn't been implemented yet!! + (t + (error "GROUP repeat hasn't been implemented yet~%"))))) + (cond ((listp piece) ;Just append the list + (setf result (append (list piece) result))) + ((eql piece 'QUESTION) ; Wrap it in a block that won't fail + (cond ((listp (nth (1+ elt) expression)) + (setf result + (append `((progn (block compare + ,(nth (1+ elt) + expression)) + t)) + result)) + (incf elt)) + ;; + ;; This is a QUESTION on an entire group which + ;; hasn't been implemented yet!!! + ;; + (t + (error "Optional groups not implemented yet~%")))) + ((or (eql piece 'ASTRISK) ; Do the wild thing! + (eql piece 'PLUS)) + (cond ((listp (nth (1+ elt) expression)) + ;; + ;; This is a single character wild card so + ;; do the simple form. + ;; + (setf result + `((let ((oindex index)) + (block compare + (do () + (nil) + ,(nth (1+ elt) expression))) + (do ((start index (1- start))) + ((< start oindex) nil) + (let ((index start)) + (block compare + ,@result)))))) + (incf elt)) + (t + ;; + ;; This is a subgroup repeated so I must build + ;; the loop using several values. + ;; + )) + ) + (t t)))) ; Just ignore everything else. + ;; + ;; Now wrap the result in a lambda list that can then be + ;; invoked or compiled, however the user wishes. + ;; + (if anchored + (setf result + `(lambda (string &key (start 0) (end (length string))) + (setf *regex-groupings* ,group) + (block final-return + (block compare + (let ((index start) + (length end)) + ,@result))))) + (setf result + `(lambda (string &key (start 0) (end (length string))) + (setf *regex-groupings* ,group) + (block final-return + (let ((length end)) + ,@fast-first + (do ((marker start (1+ marker))) + ((> marker end) nil) + (let ((index marker)) + (if (block compare + ,@result) + (return t))))))))))) + +;; (provide 'nregex) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/packages.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/packages.lisp new file mode 100644 index 0000000..b4b159f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/packages.lisp @@ -0,0 +1,202 @@ +(defpackage swank/backend + (:use cl) + (:nicknames swank-backend) + (:export *debug-swank-backend* + *log-output* + sldb-condition + compiler-condition + original-condition + message + source-context + condition + severity + with-compilation-hooks + make-location + location + location-p + location-buffer + location-position + location-hints + position-p + position-pos + print-output-to-string + quit-lisp + references + unbound-slot-filler + declaration-arglist + type-specifier-arglist + with-struct + when-let + defimplementation + converting-errors-to-error-location + make-error-location + deinit-log-output + ;; interrupt macro for the backend + *pending-slime-interrupts* + check-slime-interrupts + *interrupt-queued-handler* + ;; inspector related symbols + emacs-inspect + label-value-line + label-value-line* + boolean-to-feature-expression + with-symbol + choose-symbol + ;; package helper for backend + import-to-swank-mop + import-swank-mop-symbols + ;; + default-directory + set-default-directory + frame-source-location + restart-frame + gdb-initial-commands + sldb-break-on-return + buffer-first-change + + profiled-functions + unprofile-all + profile-report + profile-reset + profile-package + + with-collected-macro-forms + auto-flush-loop + *auto-flush-interval*)) + +(defpackage swank/rpc + (:use :cl) + (:export + read-message + read-packet + swank-reader-error + swank-reader-error.packet + swank-reader-error.cause + write-message)) + +(defpackage swank/match + (:use cl) + (:export match)) + +;; FIXME: rename to sawnk/mop +(defpackage swank-mop + (:use) + (:export + ;; classes + standard-generic-function + standard-slot-definition + standard-method + standard-class + eql-specializer + eql-specializer-object + ;; standard-class readers + class-default-initargs + class-direct-default-initargs + class-direct-slots + class-direct-subclasses + class-direct-superclasses + class-finalized-p + class-name + class-precedence-list + class-prototype + class-slots + specializer-direct-methods + ;; generic function readers + generic-function-argument-precedence-order + generic-function-declarations + generic-function-lambda-list + generic-function-methods + generic-function-method-class + generic-function-method-combination + generic-function-name + ;; method readers + method-generic-function + method-function + method-lambda-list + method-specializers + method-qualifiers + ;; slot readers + slot-definition-allocation + slot-definition-documentation + slot-definition-initargs + slot-definition-initform + slot-definition-initfunction + slot-definition-name + slot-definition-type + slot-definition-readers + slot-definition-writers + slot-boundp-using-class + slot-value-using-class + slot-makunbound-using-class + ;; generic function protocol + compute-applicable-methods-using-classes + finalize-inheritance)) + +(defpackage swank + (:use cl swank/backend swank/match swank/rpc) + (:export #:startup-multiprocessing + #:start-server + #:create-server + #:stop-server + #:restart-server + #:ed-in-emacs + #:inspect-in-emacs + #:print-indentation-lossage + #:invoke-slime-debugger + #:swank-debugger-hook + #:emacs-inspect + ;;#:inspect-slot-for-emacs + ;; These are user-configurable variables: + #:*communication-style* + #:*dont-close* + #:*fasl-pathname-function* + #:*log-events* + #:*use-dedicated-output-stream* + #:*dedicated-output-stream-port* + #:*configure-emacs-indentation* + #:*readtable-alist* + #:*globally-redirect-io* + #:*global-debugger* + #:*sldb-quit-restart* + #:*backtrace-printer-bindings* + #:*default-worker-thread-bindings* + #:*macroexpand-printer-bindings* + #:*swank-pprint-bindings* + #:*record-repl-results* + #:*inspector-verbose* + ;; This is SETFable. + #:debug-on-swank-error + ;; These are re-exported directly from the backend: + #:buffer-first-change + #:frame-source-location + #:gdb-initial-commands + #:restart-frame + #:sldb-step + #:sldb-break + #:sldb-break-on-return + #:profiled-functions + #:profile-report + #:profile-reset + #:unprofile-all + #:profile-package + #:default-directory + #:set-default-directory + #:quit-lisp + #:eval-for-emacs + #:eval-in-emacs + #:ed-rpc + #:ed-rpc-no-wait + #:y-or-n-p-in-emacs + #:*find-definitions-right-trim* + #:*find-definitions-left-trim* + #:*after-toggle-trace-hook* + #:unreadable-result + #:unreadable-result-p + #:unreadable-result-string + #:parse-string + #:from-string + #:to-string + #:*swank-debugger-condition* + #:run-hook-with-args-until-success + #:make-output-function-for-target + #:make-output-stream-for-target)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/sbcl-pprint-patch.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/sbcl-pprint-patch.lisp new file mode 100644 index 0000000..dfdc0bb --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/sbcl-pprint-patch.lisp @@ -0,0 +1,332 @@ +;; Pretty printer patch for SBCL, which adds the "annotations" feature +;; required for sending presentations through pretty-printing streams. +;; +;; The section marked "Changed functions" and the DEFSTRUCT +;; PRETTY-STREAM are based on SBCL's pprint.lisp. +;; +;; Public domain. + +(in-package "SB!PRETTY") + +(defstruct (annotation (:include queued-op)) + (handler (constantly nil) :type function) + (record)) + + +(defstruct (pretty-stream (:include sb!kernel:ansi-stream + (out #'pretty-out) + (sout #'pretty-sout) + (misc #'pretty-misc)) + (:constructor make-pretty-stream (target)) + (:copier nil)) + ;; Where the output is going to finally go. + (target (missing-arg) :type stream) + ;; Line length we should format to. Cached here so we don't have to keep + ;; extracting it from the target stream. + (line-length (or *print-right-margin* + (sb!impl::line-length target) + default-line-length) + :type column) + ;; A simple string holding all the text that has been output but not yet + ;; printed. + (buffer (make-string initial-buffer-size) :type (simple-array character (*))) + ;; The index into BUFFER where more text should be put. + (buffer-fill-pointer 0 :type index) + ;; Whenever we output stuff from the buffer, we shift the remaining noise + ;; over. This makes it difficult to keep references to locations in + ;; the buffer. Therefore, we have to keep track of the total amount of + ;; stuff that has been shifted out of the buffer. + (buffer-offset 0 :type posn) + ;; The column the first character in the buffer will appear in. Normally + ;; zero, but if we end up with a very long line with no breaks in it we + ;; might have to output part of it. Then this will no longer be zero. + (buffer-start-column (or (sb!impl::charpos target) 0) :type column) + ;; The line number we are currently on. Used for *PRINT-LINES* + ;; abbreviations and to tell when sections have been split across + ;; multiple lines. + (line-number 0 :type index) + ;; the value of *PRINT-LINES* captured at object creation time. We + ;; use this, instead of the dynamic *PRINT-LINES*, to avoid + ;; weirdness like + ;; (let ((*print-lines* 50)) + ;; (pprint-logical-block .. + ;; (dotimes (i 10) + ;; (let ((*print-lines* 8)) + ;; (print (aref possiblybigthings i) prettystream))))) + ;; terminating the output of the entire logical blockafter 8 lines. + (print-lines *print-lines* :type (or index null) :read-only t) + ;; Stack of logical blocks in effect at the buffer start. + (blocks (list (make-logical-block)) :type list) + ;; Buffer holding the per-line prefix active at the buffer start. + ;; Indentation is included in this. The length of this is stored + ;; in the logical block stack. + (prefix (make-string initial-buffer-size) :type (simple-array character (*))) + ;; Buffer holding the total remaining suffix active at the buffer start. + ;; The characters are right-justified in the buffer to make it easier + ;; to output the buffer. The length is stored in the logical block + ;; stack. + (suffix (make-string initial-buffer-size) :type (simple-array character (*))) + ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, + ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) + ;; cons. Adding things to the queue is basically (setf (cdr head) (list + ;; new)) and removing them is basically (pop tail) [except that care must + ;; be taken to handle the empty queue case correctly.] + (queue-tail nil :type list) + (queue-head nil :type list) + ;; Block-start queue entries in effect at the queue head. + (pending-blocks nil :type list) + ;; Queue of annotations to the buffer + (annotations-tail nil :type list) + (annotations-head nil :type list)) + + +(defmacro enqueue (stream type &rest args) + (let ((constructor (intern (concatenate 'string + "MAKE-" + (symbol-name type)) + "SB-PRETTY"))) + (once-only ((stream stream) + (entry `(,constructor :posn + (index-posn + (pretty-stream-buffer-fill-pointer + ,stream) + ,stream) + ,@args)) + (op `(list ,entry)) + (head `(pretty-stream-queue-head ,stream))) + `(progn + (if ,head + (setf (cdr ,head) ,op) + (setf (pretty-stream-queue-tail ,stream) ,op)) + (setf (pretty-stream-queue-head ,stream) ,op) + ,entry)))) + +;;; +;;; New helper functions +;;; + +(defun enqueue-annotation (stream handler record) + (enqueue stream annotation :handler handler + :record record)) + +(defun re-enqueue-annotation (stream annotation) + (let* ((annotation-cons (list annotation)) + (head (pretty-stream-annotations-head stream))) + (if head + (setf (cdr head) annotation-cons) + (setf (pretty-stream-annotations-tail stream) annotation-cons)) + (setf (pretty-stream-annotations-head stream) annotation-cons) + nil)) + +(defun re-enqueue-annotations (stream end) + (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail) + while (and tail (not (eql (car tail) end))) + when (annotation-p (car tail)) + do (re-enqueue-annotation stream (car tail)))) + +(defun dequeue-annotation (stream &key end-posn) + (let ((next-annotation (car (pretty-stream-annotations-tail stream)))) + (when next-annotation + (when (or (not end-posn) + (<= (annotation-posn next-annotation) end-posn)) + (pop (pretty-stream-annotations-tail stream)) + (unless (pretty-stream-annotations-tail stream) + (setf (pretty-stream-annotations-head stream) nil)) + next-annotation)))) + +(defun invoke-annotation (stream annotation truncatep) + (let ((target (pretty-stream-target stream))) + (funcall (annotation-handler annotation) + (annotation-record annotation) + target + truncatep))) + +(defun output-buffer-with-annotations (stream end) + (let ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (end-posn (index-posn end stream)) + (start 0)) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do + (let ((annotation-index (posn-index (annotation-posn annotation) + stream))) + (when (> annotation-index start) + (write-string buffer target :start start + :end annotation-index) + (setf start annotation-index)) + (invoke-annotation stream annotation nil))) + (when (> end start) + (write-string buffer target :start start :end end)))) + +(defun flush-annotations (stream end truncatep) + (let ((end-posn (index-posn end stream))) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do (invoke-annotation stream annotation truncatep)))) + +;;; +;;; Changed functions +;;; + +(defun maybe-output (stream force-newlines-p) + (declare (type pretty-stream stream)) + (let ((tail (pretty-stream-queue-tail stream)) + (output-anything nil)) + (loop + (unless tail + (setf (pretty-stream-queue-head stream) nil) + (return)) + (let ((next (pop tail))) + (etypecase next + (newline + (when (ecase (newline-kind next) + ((:literal :mandatory :linear) t) + (:miser (misering-p stream)) + (:fill + (or (misering-p stream) + (> (pretty-stream-line-number stream) + (logical-block-section-start-line + (first (pretty-stream-blocks stream)))) + (ecase (fits-on-line-p stream + (newline-section-end next) + force-newlines-p) + ((t) nil) + ((nil) t) + (:dont-know + (return)))))) + (setf output-anything t) + (output-line stream next))) + (indentation + (unless (misering-p stream) + (set-indentation stream + (+ (ecase (indentation-kind next) + (:block + (logical-block-start-column + (car (pretty-stream-blocks stream)))) + (:current + (posn-column + (indentation-posn next) + stream))) + (indentation-amount next))))) + (block-start + (ecase (fits-on-line-p stream (block-start-section-end next) + force-newlines-p) + ((t) + ;; Just nuke the whole logical block and make it look like one + ;; nice long literal. (But don't nuke annotations.) + (let ((end (block-start-block-end next))) + (expand-tabs stream end) + (re-enqueue-annotations stream end) + (setf tail (cdr (member end tail))))) + ((nil) + (really-start-logical-block + stream + (posn-column (block-start-posn next) stream) + (block-start-prefix next) + (block-start-suffix next))) + (:dont-know + (return)))) + (block-end + (really-end-logical-block stream)) + (tab + (expand-tabs stream next)) + (annotation + (re-enqueue-annotation stream next)))) + (setf (pretty-stream-queue-tail stream) tail)) + output-anything)) + +(defun output-line (stream until) + (declare (type pretty-stream stream) + (type newline until)) + (let* ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (kind (newline-kind until)) + (literal-p (eq kind :literal)) + (amount-to-consume (posn-index (newline-posn until) stream)) + (amount-to-print + (if literal-p + amount-to-consume + (let ((last-non-blank + (position #\space buffer :end amount-to-consume + :from-end t :test #'char/=))) + (if last-non-blank + (1+ last-non-blank) + 0))))) + (output-buffer-with-annotations stream amount-to-print) + (flush-annotations stream amount-to-consume nil) + (let ((line-number (pretty-stream-line-number stream))) + (incf line-number) + (when (and (not *print-readably*) + (pretty-stream-print-lines stream) + (>= line-number (pretty-stream-print-lines stream))) + (write-string " .." target) + (flush-annotations stream + (pretty-stream-buffer-fill-pointer stream) + t) + (let ((suffix-length (logical-block-suffix-length + (car (pretty-stream-blocks stream))))) + (unless (zerop suffix-length) + (let* ((suffix (pretty-stream-suffix stream)) + (len (length suffix))) + (write-string suffix target + :start (- len suffix-length) + :end len)))) + (throw 'line-limit-abbreviation-happened t)) + (setf (pretty-stream-line-number stream) line-number) + (write-char #\newline target) + (setf (pretty-stream-buffer-start-column stream) 0) + (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) + (block (first (pretty-stream-blocks stream))) + (prefix-len + (if literal-p + (logical-block-per-line-prefix-end block) + (logical-block-prefix-length block))) + (shift (- amount-to-consume prefix-len)) + (new-fill-ptr (- fill-ptr shift)) + (new-buffer buffer) + (buffer-length (length buffer))) + (when (> new-fill-ptr buffer-length) + (setf new-buffer + (make-string (max (* buffer-length 2) + (+ buffer-length + (floor (* (- new-fill-ptr buffer-length) + 5) + 4))))) + (setf (pretty-stream-buffer stream) new-buffer)) + (replace new-buffer buffer + :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr) + (replace new-buffer (pretty-stream-prefix stream) + :end1 prefix-len) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (incf (pretty-stream-buffer-offset stream) shift) + (unless literal-p + (setf (logical-block-section-column block) prefix-len) + (setf (logical-block-section-start-line block) line-number)))))) + +(defun output-partial-line (stream) + (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) + (tail (pretty-stream-queue-tail stream)) + (count + (if tail + (posn-index (queued-op-posn (car tail)) stream) + fill-ptr)) + (new-fill-ptr (- fill-ptr count)) + (buffer (pretty-stream-buffer stream))) + (when (zerop count) + (error "Output-partial-line called when nothing can be output.")) + (output-buffer-with-annotations stream count) + (incf (pretty-stream-buffer-start-column stream) count) + (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (incf (pretty-stream-buffer-offset stream) count))) + +(defun force-pretty-output (stream) + (maybe-output stream nil) + (expand-tabs stream nil) + (re-enqueue-annotations stream nil) + (output-buffer-with-annotations stream + (pretty-stream-buffer-fill-pointer stream))) + \ No newline at end of file diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/slime-autoloads.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/slime-autoloads.el new file mode 100644 index 0000000..0666f37 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/slime-autoloads.el @@ -0,0 +1,51 @@ +;;; slime-autoloads.el --- autoload definitions for SLIME -*- no-byte-compile: t -*- + +;; Copyright (C) 2007 Helmut Eller + +;; This file is protected by the GNU GPLv2 (or later), as distributed +;; with GNU Emacs. + +;;; Commentary: + +;; This code defines the necessary autoloads, so that we don't need to +;; load everything from .emacs. +;; +;; JT@14/01/09: FIXME: This file should be auto-generated with autoload cookies. + +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + +(autoload 'slime "slime" + "Start a Lisp subprocess and connect to its Swank server." t) + +(autoload 'slime-mode "slime" + "SLIME: The Superior Lisp Interaction (Minor) Mode for Emacs." t) + +(autoload 'slime-connect "slime" + "Connect to a running Swank server." t) + +(autoload 'slime-selector "slime" + "Select a new by type, indicated by a single character." t) + +(autoload 'hyperspec-lookup "lib/hyperspec" nil t) + +(autoload 'slime-lisp-mode-hook "slime") + +(autoload 'slime-scheme-mode-hook "slime") + +(defvar slime-contribs nil + "A list of contrib packages to load with SLIME.") + +(autoload 'slime-setup "slime" + "Setup some SLIME contribs.") + +(define-obsolete-variable-alias 'slime-setup-contribs + 'slime-contribs "2.3.2") + +(add-hook 'lisp-mode-hook 'slime-lisp-mode-hook) + +(provide 'slime-autoloads) + +;;; slime-autoloads.el ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/slime-tests.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/slime-tests.el new file mode 100644 index 0000000..87f81f1 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/slime-tests.el @@ -0,0 +1,1459 @@ +;;; slime-tests.el --- Automated tests for slime.el +;; +;;;; License +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler +;; Copyright (C) 2013 +;; +;; For a detailed list of contributors, see the manual. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + + +;;;; Tests +(require 'slime) +(require 'ert nil t) +(require 'ert "lib/ert" t) ;; look for bundled version for Emacs 23 +(require 'cl-lib) +(require 'bytecomp) ; byte-compile-current-file +(eval-when-compile + (require 'cl)) ; lexical-let + +(defun slime-shuffle-list (list) + (let* ((len (length list)) + (taken (make-vector len nil)) + (result (make-vector len nil))) + (dolist (e list) + (while (let ((i (random len))) + (cond ((aref taken i)) + (t (aset taken i t) + (aset result i e) + nil))))) + (append result '()))) + +(defun slime-batch-test (&optional test-name randomize) + "Run the test suite in batch-mode. +Exits Emacs when finished. The exit code is the number of failed tests." + (interactive) + (let ((ert-debug-on-error nil) + (timeout 30) + (slime-background-message-function #'ignore)) + (slime) + ;; Block until we are up and running. + (lexical-let (timed-out) + (run-with-timer timeout nil + (lambda () (setq timed-out t))) + (while (not (slime-connected-p)) + (sit-for 1) + (when timed-out + (when noninteractive + (kill-emacs 252))))) + (slime-sync-to-top-level 5) + (let* ((selector (if randomize + `(member ,@(slime-shuffle-list + (ert-select-tests (or test-name t) t))) + (or test-name t))) + (ert-fun (if noninteractive + 'ert-run-tests-batch + 'ert))) + (let ((stats (funcall ert-fun selector))) + (if noninteractive + (kill-emacs (ert-stats-completed-unexpected stats))))))) + +(defun slime-skip-test (message) + ;; ERT for Emacs 23 and earlier doesn't have `ert-skip' + (if (fboundp 'ert-skip) + (ert-skip message) + (message (concat "SKIPPING: " message)) + (ert-pass))) + +(defun slime-tests--undefine-all () + (dolist (test (ert-select-tests t t)) + (let* ((sym (ert-test-name test))) + (cl-assert (eq (get sym 'ert--test) test)) + (cl-remprop sym 'ert--test)))) + +(slime-tests--undefine-all) + +(eval-and-compile + (defun slime-tests-auto-tags () + (append '(slime) + (let ((file-name (or load-file-name + byte-compile-current-file))) + (if (and file-name + (string-match "contrib/test/slime-\\(.*\\)\.elc?$" + file-name)) + (list 'contrib (intern (match-string 1 file-name))) + '(core))))) + + (defmacro define-slime-ert-test (name &rest args) + "Like `ert-deftest', but set tags automatically. +Also don't error if `ert.el' is missing." + (if (not (featurep 'ert)) + (warn "No ert.el found: not defining test %s" + name) + (let* ((docstring (and (stringp (second args)) + (second args))) + (args (if docstring + (cddr args) + (cdr args))) + (tags (slime-tests-auto-tags))) + `(ert-deftest ,name () ,(or docstring "No docstring for this test.") + :tags ',tags + ,@args)))) + + (defun slime-test-ert-test-for (name input i doc body fails-for style fname) + `(define-slime-ert-test + ,(intern (format "%s-%d" name i)) () + ,(format "For input %s, %s" (truncate-string-to-width + (format "%s" input) + 15 nil nil 'ellipsis) + (replace-regexp-in-string "^.??\\(\\w+\\)" + (lambda (s) (downcase s)) + doc + t)) + ,@(if fails-for + `(:expected-result '(satisfies + (lambda (result) + (ert-test-result-type-p + result + (if (member + (slime-lisp-implementation-name) + ',fails-for) + :failed + :passed)))))) + + ,@(when style + `((let ((style (slime-communication-style))) + (when (not (member style ',style)) + (slime-skip-test (format "test not applicable for style %s" + style)))))) + (apply #',fname ',input)))) + +(defmacro def-slime-test (name args doc inputs &rest body) + "Define a test case. +NAME ::= SYMBOL | (SYMBOL OPTION*) is a symbol naming the test. +OPTION ::= (:fails-for IMPLEMENTATION*) | (:style COMMUNICATION-STYLE*) +ARGS is a lambda-list. +DOC is a docstring. +INPUTS is a list of argument lists, each tested separately. +BODY is the test case. The body can use `slime-check' to test +conditions (assertions)." + (declare (debug (&define name sexp sexp sexp &rest def-form))) + (if (not (featurep 'ert)) + (warn "No ert.el found: not defining test %s" + name) + `(progn + ,@(cl-destructuring-bind (name &rest options) + (if (listp name) name (list name)) + (let ((fname (intern (format "slime-test-%s" name)))) + (cons `(defun ,fname ,args + (slime-sync-to-top-level 0.3) + ,@body + (slime-sync-to-top-level 0.3)) + (cl-loop for input in (eval inputs) + for i from 1 + with fails-for = (cdr (assoc :fails-for options)) + with style = (cdr (assoc :style options)) + collect (slime-test-ert-test-for name + input + i + doc + body + fails-for + style + fname)))))))) + +(put 'def-slime-test 'lisp-indent-function 4) + +(defmacro slime-check (check &rest body) + (declare (indent defun)) + `(unless (progn ,@body) + (ert-fail ,(cl-etypecase check + (cons `(concat "Ooops, " ,(cons 'format check))) + (string `(concat "Check failed: " ,check)) + (symbol `(concat "Check failed: " ,(symbol-name check))))))) + + +;;;;; Test case definitions +(defun slime-check-top-level () ;(&optional _test-name) + (accept-process-output nil 0.001) + (slime-check "At the top level (no debugging or pending RPCs)" + (slime-at-top-level-p))) + +(defun slime-at-top-level-p () + (and (not (sldb-get-default-buffer)) + (null (slime-rex-continuations)))) + +(defun slime-wait-condition (name predicate timeout) + (let ((end (time-add (current-time) (seconds-to-time timeout)))) + (while (not (funcall predicate)) + (let ((now (current-time))) + (message "waiting for condition: %s [%s.%06d]" name + (format-time-string "%H:%M:%S" now) (third now))) + (cond ((time-less-p end (current-time)) + (error "Timeout waiting for condition: %S" name)) + (t + ;; XXX if a process-filter enters a recursive-edit, we + ;; hang forever + (accept-process-output nil 0.1)))))) + +(defun slime-sync-to-top-level (timeout) + (slime-wait-condition "top-level" #'slime-at-top-level-p timeout)) + +;; XXX: unused function +(defun slime-check-sldb-level (expected) + (let ((sldb-level (let ((sldb (sldb-get-default-buffer))) + (if sldb + (with-current-buffer sldb + sldb-level))))) + (slime-check ("SLDB level (%S) is %S" expected sldb-level) + (equal expected sldb-level)))) + +(defun slime-test-expect (_name expected actual &optional test) + (when (stringp expected) (setq expected (substring-no-properties expected))) + (when (stringp actual) (setq actual (substring-no-properties actual))) + (if test + (should (funcall test expected actual)) + (should (equal expected actual)))) + +(defun sldb-level () + (let ((sldb (sldb-get-default-buffer))) + (if sldb + (with-current-buffer sldb + sldb-level)))) + +(defun slime-sldb-level= (level) + (equal level (sldb-level))) + +(eval-when-compile + (defvar slime-test-symbols + '(("foobar") ("foo@bar") ("@foobar") ("foobar@") ("\\@foobar") + ("|asdf||foo||bar|") + ("\\#") + ("\\(setf\\ car\\)")))) + +(defun slime-check-symbol-at-point (prefix symbol suffix) + ;; We test that `slime-symbol-at-point' works at every + ;; character of the symbol name. + (with-temp-buffer + (lisp-mode) + (insert prefix) + (let ((start (point))) + (insert symbol suffix) + (dotimes (i (length symbol)) + (goto-char (+ start i)) + (slime-test-expect (format "Check `%s' (at %d)..." + (buffer-string) (point)) + symbol + (slime-symbol-at-point) + #'equal))))) + + + +(def-slime-test symbol-at-point.2 (sym) + "fancy symbol-name _not_ at BOB/EOB" + slime-test-symbols + (slime-check-symbol-at-point "(foo " sym " bar)")) + +(def-slime-test symbol-at-point.3 (sym) + "fancy symbol-name with leading ," + (remove-if (lambda (s) (eq (aref (car s) 0) ?@)) slime-test-symbols) + (slime-check-symbol-at-point "," sym "")) + +(def-slime-test symbol-at-point.4 (sym) + "fancy symbol-name with leading ,@" + slime-test-symbols + (slime-check-symbol-at-point ",@" sym "")) + +(def-slime-test symbol-at-point.5 (sym) + "fancy symbol-name with leading `" + slime-test-symbols + (slime-check-symbol-at-point "`" sym "")) + +(def-slime-test symbol-at-point.6 (sym) + "fancy symbol-name wrapped in ()" + slime-test-symbols + (slime-check-symbol-at-point "(" sym ")")) + +(def-slime-test symbol-at-point.7 (sym) + "fancy symbol-name wrapped in #< {DEADBEEF}>" + slime-test-symbols + (slime-check-symbol-at-point "#<" sym " {DEADBEEF}>")) + +;;(def-slime-test symbol-at-point.8 (sym) +;; "fancy symbol-name wrapped in #<>" +;; slime-test-symbols +;; (slime-check-symbol-at-point "#<" sym ">")) + +(def-slime-test symbol-at-point.9 (sym) + "fancy symbol-name wrapped in #| ... |#" + slime-test-symbols + (slime-check-symbol-at-point "#|\n" sym "\n|#")) + +(def-slime-test symbol-at-point.10 (sym) + "fancy symbol-name after #| )))(( |# (1)" + slime-test-symbols + (slime-check-symbol-at-point "#| )))(( #|\n" sym "")) + +(def-slime-test symbol-at-point.11 (sym) + "fancy symbol-name after #| )))(( |# (2)" + slime-test-symbols + (slime-check-symbol-at-point "#| )))(( #|" sym "")) + +(def-slime-test symbol-at-point.12 (sym) + "fancy symbol-name wrapped in \"...\"" + slime-test-symbols + (slime-check-symbol-at-point "\"\n" sym "\"\n")) + +(def-slime-test symbol-at-point.13 (sym) + "fancy symbol-name wrapped in \" )))(( \" (1)" + slime-test-symbols + (slime-check-symbol-at-point "\" )))(( \"\n" sym "")) + +(def-slime-test symbol-at-point.14 (sym) + "fancy symbol-name wrapped in \" )))(( \" (1)" + slime-test-symbols + (slime-check-symbol-at-point "\" )))(( \"" sym "")) + +(def-slime-test symbol-at-point.15 (sym) + "symbol-at-point after #." + slime-test-symbols + (slime-check-symbol-at-point "#." sym "")) + +(def-slime-test symbol-at-point.16 (sym) + "symbol-at-point after #+" + slime-test-symbols + (slime-check-symbol-at-point "#+" sym "")) + + +(def-slime-test sexp-at-point.1 (string) + "symbol-at-point after #'" + '(("foo") + ("#:foo") + ("#'foo") + ("#'(lambda (x) x)") + ("()")) + (with-temp-buffer + (lisp-mode) + (insert string) + (goto-char (point-min)) + (slime-test-expect (format "Check sexp `%s' (at %d)..." + (buffer-string) (point)) + string + (slime-sexp-at-point) + #'equal))) + +(def-slime-test narrowing () + "Check that narrowing is properly sustained." + '() + (slime-check-top-level) + (let ((random-buffer-name (symbol-name (cl-gensym))) + (defun-pos) (tmpbuffer)) + (with-temp-buffer + (dotimes (i 100) (insert (format ";;; %d. line\n" i))) + (setq tmpbuffer (current-buffer)) + (setq defun-pos (point)) + (insert (concat "(defun __foo__ (x y)" "\n" + " 'nothing)" "\n")) + (dotimes (i 100) (insert (format ";;; %d. line\n" (+ 100 i)))) + (slime-check "Checking that newly created buffer is not narrowed." + (not (slime-buffer-narrowed-p))) + + (goto-char defun-pos) + (narrow-to-defun) + (slime-check "Checking that narrowing succeeded." + (slime-buffer-narrowed-p)) + + (slime-with-popup-buffer (random-buffer-name) + (slime-check ("Checking that we're in Slime's temp buffer `%s'" + random-buffer-name) + (equal (buffer-name (current-buffer)) random-buffer-name))) + (with-current-buffer random-buffer-name + ;; Notice that we cannot quit the buffer within the extent + ;; of slime-with-output-to-temp-buffer. + (quit-window t)) + (slime-check ("Checking that we've got back from `%s'" + random-buffer-name) + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (slime-check "Checking that narrowing sustained \ +after quitting Slime's temp buffer." + (slime-buffer-narrowed-p)) + + (let ((slime-buffer-package "SWANK") + (symbol '*buffer-package*)) + (slime-edit-definition (symbol-name symbol)) + (slime-check ("Checking that we've got M-. into swank.lisp. %S" symbol) + (string= (file-name-nondirectory (buffer-file-name)) + "swank.lisp")) + (slime-pop-find-definition-stack) + (slime-check ("Checking that we've got back.") + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (slime-check "Checking that narrowing sustained after M-," + (slime-buffer-narrowed-p))) + )) + (slime-check-top-level)) + +(defun slime-test--display-region-eval-arg (line window-height) + (cl-etypecase line + (number line) + (cons (slime-dcase line + ((+h line) + (+ (slime-test--display-region-eval-arg line window-height) + window-height)) + ((-h line) + (- (slime-test--display-region-eval-arg line window-height) + window-height)))))) + +(defun slime-test--display-region-line-to-position (line window-height) + (let ((line (slime-test--display-region-eval-arg line window-height))) + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (line-beginning-position)))) + +(def-slime-test display-region + (start end pos window-start expected-window-start expected-point) + "Test `slime-display-region'." + ;; numbers are actually lines numbers + '(;; region visible, point in region + (2 4 3 1 1 3) + ;; region visible, point visible but ouside region + (2 4 5 1 1 5) + ;; end not visible, point at start + (2 (+h 2) 2 1 2 2) + ;; start not visible, point at start + ((+h 2) (+h 500) (+h 2) 1 (+h 2) (+h 2)) + ;; start not visible, point after end + ((+h 2) (+h 500) (+h 6) 1 (+h 2) (+h 6)) + ;; end - start should be visible, point after end + ((+h 2) (+h 7) (+h 10) 1 (-h (+h 7)) (+h 6)) + ;; region is window-height + 1 and ends with newline + ((+h -2) (+h (+h -3)) (+h -2) 1 (+h -3) (+h -2)) + (2 (+h 1) 3 1 1 3) + (2 (+h 0) 3 1 1 3) + (2 (+h -1) 3 1 1 3) + ;; start and end are the beginning + (1 1 1 1 1 1) + ;; + (1 (+h 1) (+h 22) (+h 20) 1 (+h 0)) + ) + (when noninteractive + (slime-skip-test "Can't test slime-display-region in batch mode")) + (with-temp-buffer + (dotimes (i 1000) + (insert (format "%09d\n" i))) + (let* ((win (display-buffer (current-buffer) t)) + (wh (window-text-height win))) + (cl-macrolet ((l2p (l) + `(slime-test--display-region-line-to-position ,l wh))) + (select-window win) + (set-window-start win (l2p window-start)) + (redisplay) + (goto-char (l2p pos)) + (cl-assert (= (l2p window-start) (window-start win))) + (cl-assert (= (point) (l2p pos))) + (slime--display-region (l2p start) (l2p end)) + (redisplay) + (cl-assert (= (l2p expected-window-start) (window-start))) + (cl-assert (= (l2p expected-point) (point))) + )))) + +(def-slime-test find-definition + (name buffer-package snippet) + "Find the definition of a function or macro in swank.lisp." + '(("start-server" "SWANK" "(defun start-server ") + ("swank::start-server" "CL-USER" "(defun start-server ") + ("swank:start-server" "CL-USER" "(defun start-server ") + ("swank::connection" "CL-USER" "(defstruct (connection") + ("swank::*emacs-connection*" "CL-USER" "(defvar \\*emacs-connection\\*") + ) + (switch-to-buffer "*scratch*") ; not buffer of definition + (slime-check-top-level) + (let ((orig-buffer (current-buffer)) + (orig-pos (point)) + (enable-local-variables nil) ; don't get stuck on -*- eval: -*- + (slime-buffer-package buffer-package)) + (slime-edit-definition name) + ;; Postconditions + (slime-check ("Definition of `%S' is in swank.lisp." name) + (string= (file-name-nondirectory (buffer-file-name)) "swank.lisp")) + (slime-check ("Looking at '%s'." snippet) (looking-at snippet)) + (slime-pop-find-definition-stack) + (slime-check "Returning from definition restores original buffer/position." + (and (eq orig-buffer (current-buffer)) + (= orig-pos (point))))) + (slime-check-top-level)) + +(def-slime-test (find-definition.2 (:fails-for "allegro" "lispworks")) + (buffer-content buffer-package snippet) + "Check that we're able to find definitions even when +confronted with nasty #.-fu." + '(("#.(prog1 nil (defvar *foobar* 42)) + + (defun .foo. (x) + (+ x #.*foobar*)) + + #.(prog1 nil (makunbound '*foobar*)) + " + "SWANK" + "[ \t]*(defun .foo. " + ) + ("#.(prog1 nil (defvar *foobar* 42)) + + ;; some comment + (defun .foo. (x) + (+ x #.*foobar*)) + + #.(prog1 nil (makunbound '*foobar*)) + " + "SWANK" + "[ \t]*(defun .foo. " + ) + ("(in-package swank) + (eval-when (:compile-toplevel) (defparameter *bar* 456)) + (eval-when (:load-toplevel :execute) (makunbound '*bar*)) + (defun bar () #.*bar*) + (defun .foo. () 123)" + "SWANK" + "[ \t]*(defun .foo. () 123)")) + (let ((slime-buffer-package buffer-package)) + (with-temp-buffer + (insert buffer-content) + (slime-check-top-level) + (slime-eval + `(swank:compile-string-for-emacs + ,buffer-content + ,(buffer-name) + '((:position 0) (:line 1 1)) + ,nil + ,nil)) + (let ((bufname (buffer-name))) + (slime-edit-definition ".foo.") + (slime-check ("Definition of `.foo.' is in buffer `%s'." bufname) + (string= (buffer-name) bufname)) + (slime-check "Definition now at point." (looking-at snippet)))))) + +(def-slime-test (find-definition.3 + (:fails-for "abcl" "allegro" "clisp" "lispworks" "sbcl" + "ecl")) + (name source regexp) + "Extra tests for defstruct." + '(("swank::foo-struct" + "(progn + (defun foo-fun ()) + (defstruct (foo-struct (:constructor nil) (:predicate nil))) +)" + "(defstruct (foo-struct")) + (switch-to-buffer "*scratch*") + (with-temp-buffer + (insert source) + (let ((slime-buffer-package "SWANK")) + (slime-eval + `(swank:compile-string-for-emacs + ,source + ,(buffer-name) + '((:position 0) (:line 1 1)) + ,nil + ,nil))) + (let ((temp-buffer (current-buffer))) + (with-current-buffer "*scratch*" + (slime-edit-definition name) + (slime-check ("Definition of %S is in buffer `%s'." + name temp-buffer) + (eq (current-buffer) temp-buffer)) + (slime-check "Definition now at point." (looking-at regexp))) + ))) + +(def-slime-test complete-symbol + (prefix expected-completions) + "Find the completions of a symbol-name prefix." + '(("cl:compile" ("cl:compile" "cl:compile-file" "cl:compile-file-pathname" + "cl:compiled-function" "cl:compiled-function-p" + "cl:compiler-macro" "cl:compiler-macro-function")) + ("cl:foobar" ()) + ("swank::compile-file" ("swank::compile-file" + "swank::compile-file-for-emacs" + "swank::compile-file-if-needed" + "swank::compile-file-output" + "swank::compile-file-pathname")) + ("cl:m-v-l" ())) + (let ((completions (slime-simple-completions prefix))) + (slime-test-expect "Completion set" expected-completions completions))) + +(def-slime-test read-from-minibuffer + (input-keys expected-result) + "Test `slime-read-from-minibuffer' with INPUT-KEYS as events." + '(("( r e v e TAB SPC ' ( 1 SPC 2 SPC 3 ) ) RET" + "(reverse '(1 2 3))") + ("( c l : c o n TAB s t a n t l TAB SPC 4 2 ) RET" + "(cl:constantly 42)")) + (when noninteractive + (slime-skip-test "Can't use unread-command-events in batch mode")) + (let ((keys (eval `(kbd ,input-keys)))) ; kbd is a macro in Emacs 23 + (setq unread-command-events (listify-key-sequence keys))) + (let ((actual-result (slime-read-from-minibuffer "Test: "))) + (accept-process-output) ; run idle timers + (slime-test-expect "Completed string" expected-result actual-result))) + +(def-slime-test arglist + ;; N.B. Allegro apparently doesn't return the default values of + ;; optional parameters. Thus the regexp in the start-server + ;; expected value. In a perfect world we'd find a way to smooth + ;; over this difference between implementations--perhaps by + ;; convincing Franz to provide a function that does what we want. + (function-name expected-arglist) + "Lookup the argument list for FUNCTION-NAME. +Confirm that EXPECTED-ARGLIST is displayed." + '(("swank::operator-arglist" "(swank::operator-arglist name package)") + ("swank::compute-backtrace" "(swank::compute-backtrace start end)") + ("swank::emacs-connected" "(swank::emacs-connected)") + ("swank::compile-string-for-emacs" + "(swank::compile-string-for-emacs \ +string buffer position filename policy)") + ("swank::connection.socket-io" + "(swank::connection.socket-io \ +\\(struct\\(ure\\)?\\|object\\|instance\\|x\\|connection\\))") + ("cl:lisp-implementation-type" "(cl:lisp-implementation-type)") + ("cl:class-name" + "(cl:class-name \\(class\\|object\\|instance\\|structure\\))")) + (let ((arglist (slime-eval `(swank:operator-arglist ,function-name + "swank")))) + (slime-test-expect "Argument list is as expected" + expected-arglist (and arglist (downcase arglist)) + (lambda (pattern arglist) + (and arglist (string-match pattern arglist)))))) + +(defun slime-test--compile-defun (program subform) + (slime-check-top-level) + (with-temp-buffer + (lisp-mode) + (insert program) + (let ((font-lock-verbose nil)) + (setq slime-buffer-package ":swank") + (slime-compile-string (buffer-string) 1) + (setq slime-buffer-package ":cl-user") + (slime-sync-to-top-level 5) + (goto-char (point-max)) + (slime-previous-note) + (slime-check error-location-correct + (equal (read (current-buffer)) subform)))) + (slime-check-top-level)) + +(def-slime-test (compile-defun (:fails-for "allegro" "lispworks" "clisp")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that SUBFORM is correctly located." + '(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar)) + ("(defun cl-user::foo () + #\\space + ;;Sdf + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #+(or)skipped + #| #||# + #||# |# + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + \"\\\" bla bla \\\"\" + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #.*log-events* + (cl-user::bar))" + (cl-user::bar)) + ("#.'(defun x () (/ 1 0)) + (defun foo () + (cl-user::bar)) + + " + (cl-user::bar))) + (slime-test--compile-defun program subform)) + +;; This test ideally would be collapsed into the previous +;; compile-defun test, but only 1 case fails for ccl--and that's here +(def-slime-test (compile-defun-with-reader-conditionals + (:fails-for "allegro" "lispworks" "clisp" "ccl")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that SUBFORM is correctly located." + '(("(defun foo () + #+#.'(:and) (/ 1 0))" + (/ 1 0))) + (slime-test--compile-defun program subform)) + +;; SBCL used to pass this one but since they changed the +;; backquote/unquote reader it fails. +(def-slime-test (compile-defun-with-backquote + (:fails-for "allegro" "lispworks" "clisp" "sbcl")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that SUBFORM is correctly located." + '(("(defun cl-user::foo () + (list `(1 ,(random 10) 2 ,@(make-list (random 10)) 3 + ,(cl-user::bar))))" + (cl-user::bar))) + (slime-test--compile-defun program subform)) + +(def-slime-test (compile-file (:fails-for "allegro" "clisp")) + (string) + "Insert STRING in a file, and compile it." + `((,(pp-to-string '(defun foo () nil)))) + (let ((filename "/tmp/slime-tmp-file.lisp")) + (with-temp-file filename + (insert string)) + (let ((cell (cons nil nil))) + (slime-eval-async + `(swank:compile-file-for-emacs ,filename nil) + (slime-rcurry (lambda (result cell) + (setcar cell t) + (setcdr cell result)) + cell)) + (slime-wait-condition "Compilation finished" (lambda () (car cell)) + 0.5) + (let ((result (cdr cell))) + (slime-check "Compilation successfull" + (eq (slime-compilation-result.successp result) t)))))) + +(def-slime-test utf-8-source + (input output) + "Source code containing utf-8 should work" + (list (let* ((bytes "\343\201\212\343\201\257\343\202\210\343\201\206") + ;;(encode-coding-string (string #x304a #x306f #x3088 #x3046) + ;; 'utf-8) + (string (decode-coding-string bytes 'utf-8-unix))) + (assert (equal bytes (encode-coding-string string 'utf-8-unix))) + (list (concat "(defun cl-user::foo () \"" string "\")") + string))) + (slime-eval `(cl:eval (cl:read-from-string ,input))) + (slime-test-expect "Eval result correct" + output (slime-eval '(cl-user::foo))) + (let ((cell (cons nil nil))) + (let ((hook (slime-curry (lambda (cell &rest _) (setcar cell t)) cell))) + (add-hook 'slime-compilation-finished-hook hook) + (unwind-protect + (progn + (slime-compile-string input 0) + (slime-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5) + (slime-test-expect "Compile-string result correct" + output (slime-eval '(cl-user::foo)))) + (remove-hook 'slime-compilation-finished-hook hook)) + (let ((filename "/tmp/slime-tmp-file.lisp")) + (setcar cell nil) + (add-hook 'slime-compilation-finished-hook hook) + (unwind-protect + (with-temp-buffer + (when (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte t)) + (setq buffer-file-coding-system 'utf-8-unix) + (setq buffer-file-name filename) + (insert ";; -*- coding: utf-8-unix -*- \n") + (insert input) + (let ((coding-system-for-write 'utf-8-unix)) + (write-region nil nil filename nil t)) + (let ((slime-load-failed-fasl 'always)) + (slime-compile-and-load-file) + (slime-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5)) + (slime-test-expect "Compile-file result correct" + output (slime-eval '(cl-user::foo)))) + (remove-hook 'slime-compilation-finished-hook hook) + (ignore-errors (delete-file filename))))))) + +(def-slime-test async-eval-debugging (depth) + "Test recursive debugging of asynchronous evaluation requests." + '((1) (2) (3)) + (lexical-let ((depth depth) + (debug-hook-max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sldb-get-default-buffer) + (when (> sldb-level debug-hook-max-depth) + (setq debug-hook-max-depth sldb-level) + (if (= sldb-level depth) + ;; We're at maximum recursion - time to unwind + (sldb-quit) + ;; Going down - enter another recursive debug + ;; Recursively debug. + (slime-eval-async '(error)))))))) + (let ((sldb-hook (cons debug-hook sldb-hook))) + (slime-eval-async '(error)) + (slime-sync-to-top-level 5) + (slime-check ("Maximum depth reached (%S) is %S." + debug-hook-max-depth depth) + (= debug-hook-max-depth depth)))))) + +(def-slime-test unwind-to-previous-sldb-level (level2 level1) + "Test recursive debugging and returning to lower SLDB levels." + '((2 1) (4 2)) + (slime-check-top-level) + (lexical-let ((level2 level2) + (level1 level1) + (state 'enter) + (max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sldb-get-default-buffer) + (setq max-depth (max sldb-level max-depth)) + (ecase state + (enter + (cond ((= sldb-level level2) + (setq state 'leave) + (sldb-invoke-restart (sldb-first-abort-restart))) + (t + (slime-eval-async `(cl:aref cl:nil ,sldb-level))))) + (leave + (cond ((= sldb-level level1) + (setq state 'ok) + (sldb-quit)) + (t + (sldb-invoke-restart (sldb-first-abort-restart)) + )))))))) + (let ((sldb-hook (cons debug-hook sldb-hook))) + (slime-eval-async `(cl:aref cl:nil 0)) + (slime-sync-to-top-level 15) + (slime-check-top-level) + (slime-check ("Maximum depth reached (%S) is %S." max-depth level2) + (= max-depth level2)) + (slime-check ("Final state reached.") + (eq state 'ok)))))) + +(defun sldb-first-abort-restart () + (let ((case-fold-search t)) + (cl-position-if (lambda (x) (string-match "abort" (car x))) + sldb-restarts))) + +(def-slime-test loop-interrupt-quit + () + "Test interrupting a loop." + '(()) + (slime-check-top-level) + (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (accept-process-output nil 1) + (slime-check "In eval state." (slime-busy-p)) + (slime-interrupt) + (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5) + (slime-check-top-level)) + +(def-slime-test loop-interrupt-continue-interrupt-quit + () + "Test interrupting a previously interrupted but continued loop." + '(()) + (slime-check-top-level) + (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (sleep-for 1) + (slime-wait-condition "running" #'slime-busy-p 5) + (slime-interrupt) + (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "running" (lambda () + (and (slime-busy-p) + (not (sldb-get-default-buffer)))) 5) + (slime-interrupt) + (slime-wait-condition "Second interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5) + (slime-check-top-level)) + +(def-slime-test interactive-eval + () + "Test interactive eval and continuing from the debugger." + '(()) + (slime-check-top-level) + (lexical-let ((done nil)) + (let ((sldb-hook (lambda () (sldb-continue) (setq done t)))) + (slime-interactive-eval + "(progn\ + (cerror \"foo\" \"restart\")\ + (cerror \"bar\" \"restart\")\ + (+ 1 2))") + (while (not done) (accept-process-output)) + (slime-sync-to-top-level 5) + (slime-check-top-level) + (unless noninteractive + (let ((message (current-message))) + (slime-check "Minibuffer contains: \"3\"" + (equal "=> 3 (2 bits, #x3, #o3, #b11)" message))))))) + +(def-slime-test report-condition-with-circular-list + (format-control format-argument) + "Test conditions involving circular lists." + '(("~a" "(let ((x (cons nil nil))) (setf (cdr x) x))") + ("~a" "(let ((x (cons nil nil))) (setf (car x) x))") + ("~a" "(let ((x (cons (make-string 100000 :initial-element #\\X) nil)))\ + (setf (cdr x) x))")) + (slime-check-top-level) + (lexical-let ((done nil)) + (let ((sldb-hook (lambda () (sldb-continue) (setq done t)))) + (slime-interactive-eval + (format "(with-standard-io-syntax (cerror \"foo\" \"%s\" %s) (+ 1 2))" + format-control format-argument)) + (while (not done) (accept-process-output)) + (slime-sync-to-top-level 5) + (slime-check-top-level) + (unless noninteractive + (let ((message (current-message))) + (slime-check "Minibuffer contains: \"3\"" + (equal "=> 3 (2 bits, #x3, #o3, #b11)" message))))))) + +(def-slime-test interrupt-bubbling-idiot + () + "Test interrupting a loop that sends a lot of output to Emacs." + '(()) + (accept-process-output nil 1) + (slime-check-top-level) + (slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i) + (cl:finish-output))) + (lambda (_) ) + "CL-USER") + (sleep-for 1) + (slime-interrupt) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window (sldb-get-default-buffer)))) + 30) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5)) + +(def-slime-test (interrupt-encode-message (:style :sigio)) + () + "Test interrupt processing during swank::encode-message" + '(()) + (slime-eval-async '(cl:loop :for i :from 0 + :do (swank::background-message "foo ~d" i))) + (sleep-for 1) + (slime-eval-async '(cl:/ 1 0)) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window (sldb-get-default-buffer)))) + 30) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5)) + +(def-slime-test inspector + (exp) + "Test basic inspector workingness." + '(((let ((h (make-hash-table))) + (loop for i below 10 do (setf (gethash i h) i)) + h)) + ((make-array 10)) + ((make-list 10)) + ('cons) + (#'cons)) + (slime-inspect (prin1-to-string exp)) + (cl-assert (not (slime-inspector-visible-p))) + (slime-wait-condition "Inspector visible" #'slime-inspector-visible-p 5) + (with-current-buffer (window-buffer (selected-window)) + (slime-inspector-quit)) + (slime-wait-condition "Inspector closed" + (lambda () (not (slime-inspector-visible-p))) + 5) + (slime-sync-to-top-level 1)) + +(defun slime-buffer-visible-p (name) + (let ((buffer (window-buffer (selected-window)))) + (string-match name (buffer-name buffer)))) + +(defun slime-inspector-visible-p () + (slime-buffer-visible-p (slime-buffer-name :inspector))) + +(defun slime-execute-as-command (name) + "Execute `name' as if it was done by the user through the +Command Loop. Similiar to `call-interactively' but also pushes on +the buffer's undo-list." + (undo-boundary) + (call-interactively name)) + +(def-slime-test macroexpand + (macro-defs bufcontent expansion1 search-str expansion2) + "foo" + '((("(defmacro qwertz (&body body) `(list :qwertz ',body))" + "(defmacro yxcv (&body body) `(list :yxcv (qwertz ,@body)))") + "(yxcv :A :B :C)" + "(list :yxcv (qwertz :a :b :c))" + "(qwertz" + "(list :yxcv (list :qwertz '(:a :b :c)))")) + (slime-check-top-level) + (setq slime-buffer-package ":swank") + (with-temp-buffer + (lisp-mode) + (dolist (def macro-defs) + (slime-compile-string def 0) + (slime-sync-to-top-level 5)) + (insert bufcontent) + (goto-char (point-min)) + (slime-execute-as-command 'slime-macroexpand-1) + (slime-wait-condition "Macroexpansion buffer visible" + (lambda () + (slime-buffer-visible-p + (slime-buffer-name :macroexpansion))) + 5) + (with-current-buffer (get-buffer (slime-buffer-name :macroexpansion)) + (slime-test-expect "Initial macroexpansion is correct" + expansion1 + (downcase (buffer-string)) + #'slime-test-macroexpansion=) + (search-forward search-str) + (backward-up-list) + (slime-execute-as-command 'slime-macroexpand-1-inplace) + (slime-sync-to-top-level 3) + (slime-test-expect "In-place macroexpansion is correct" + expansion2 + (downcase (buffer-string)) + #'slime-test-macroexpansion=) + (slime-execute-as-command 'slime-macroexpand-undo) + (slime-test-expect "Expansion after undo is correct" + expansion1 + (downcase (buffer-string)) + #'slime-test-macroexpansion=))) + (setq slime-buffer-package ":cl-user")) + +(defun slime-test-macroexpansion= (string1 string2) + (let ((string1 (replace-regexp-in-string " *\n *" " " string1)) + (string2 (replace-regexp-in-string " *\n *" " " string2))) + (equal string1 string2))) + +(def-slime-test indentation (buffer-content point-markers) + "Check indentation update to work correctly." + '((" +\(in-package :swank) + +\(defmacro with-lolipop (&body body) + `(progn ,@body)) + +\(defmacro lolipop (&body body) + `(progn ,@body)) + +\(with-lolipop + 1 + 2 + 42) + +\(lolipop + 1 + 2 + 23) +" + ("23" "42"))) + (with-temp-buffer + (lisp-mode) + (slime-lisp-mode-hook) + (insert buffer-content) + (slime-compile-region (point-min) (point-max)) + (slime-sync-to-top-level 3) + (slime-update-indentation) + (slime-sync-to-top-level 3) + (dolist (marker point-markers) + (search-backward marker) + (beginning-of-defun) + (indent-sexp)) + (slime-test-expect "Correct buffer content" + buffer-content + (substring-no-properties (buffer-string))))) + +(def-slime-test break + (times exp) + "Test whether BREAK invokes SLDB." + (let ((exp1 '(break))) + `((1 ,exp1) (2 ,exp1) (3 ,exp1))) + (accept-process-output nil 0.2) + (slime-check-top-level) + (slime-eval-async + `(cl:eval (cl:read-from-string + ,(prin1-to-string `(dotimes (i ,times) + (unless (= i 0) + (swank::sleep-for 1)) + ,exp))))) + (dotimes (_i times) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window + (sldb-get-default-buffer)))) + 3) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "sldb closed" + (lambda () (not (sldb-get-default-buffer))) + 0.5)) + (slime-sync-to-top-level 1)) + +(def-slime-test (break2 (:fails-for "cmucl" "allegro")) + (times exp) + "Backends should arguably make sure that BREAK does not depend +on *DEBUGGER-HOOK*." + (let ((exp2 + '(block outta + (let ((*debugger-hook* (lambda (c h) (return-from outta 42)))) + (break))))) + `((1 ,exp2) (2 ,exp2) (3 ,exp2))) + (slime-test-break times exp)) + +(def-slime-test locally-bound-debugger-hook + () + "Test that binding *DEBUGGER-HOOK* locally works properly." + '(()) + (accept-process-output nil 1) + (slime-check-top-level) + (slime-compile-string + (prin1-to-string `(defun cl-user::quux () + (block outta + (let ((*debugger-hook* + (lambda (c hook) + (declare (ignore c hook)) + (return-from outta 42)))) + (error "FOO"))))) + 0) + (slime-sync-to-top-level 2) + (slime-eval-async '(cl-user::quux)) + ;; FIXME: slime-wait-condition returns immediately if the test returns true + (slime-wait-condition "Checking that Debugger does not popup" + (lambda () + (not (sldb-get-default-buffer))) + 3) + (slime-sync-to-top-level 5)) + +(def-slime-test end-of-file + (expr) + "Signalling END-OF-FILE should invoke the debugger." + '(((cl:error 'cl:end-of-file)) + ((cl:read-from-string ""))) + (let ((value (slime-eval + `(cl:let ((condition nil)) + (cl:with-simple-restart + (cl:continue "continue") + (cl:let ((cl:*debugger-hook* + (cl:lambda (c h) + (cl:setq condition c) + (cl:continue)))) + ,expr)) + (cl:if (cl:typep condition 'cl:end-of-file) t))))) + (slime-test-expect "Debugger invoked" t value))) + +(def-slime-test interrupt-at-toplevel + () + "Let's see what happens if we send a user interrupt at toplevel." + '(()) + (slime-check-top-level) + (unless (and (eq (slime-communication-style) :spawn) + (not (featurep 'slime-repl))) + (slime-interrupt) + (slime-wait-condition + "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window (sldb-get-default-buffer)))) + 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5))) + +(def-slime-test interrupt-in-debugger (interrupts continues) + "Let's see what happens if we interrupt the debugger. +INTERRUPTS ... number of nested interrupts +CONTINUES ... how often the continue restart should be invoked" + '((1 0) (2 1) (4 2)) + (slime-check "No debugger" (not (sldb-get-default-buffer))) + (when (and (eq (slime-communication-style) :spawn) + (not (featurep 'slime-repl))) + (slime-eval-async '(swank::without-slime-interrupts + (swank::receive))) + (sit-for 0.2)) + (dotimes (i interrupts) + (slime-interrupt) + (let ((level (1+ i))) + (slime-wait-condition (format "Debug level %d reachend" level) + (lambda () (equal (sldb-level) level)) + 2))) + (dotimes (i continues) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (let ((level (- interrupts (1+ i)))) + (slime-wait-condition (format "Return to debug level %d" level) + (lambda () (equal (sldb-level) level)) + 2))) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 1)) + +(def-slime-test flow-control + (n delay interrupts) + "Let Lisp produce output faster than Emacs can consume it." + `((400 0.03 3)) + (when noninteractive + (slime-skip-test "test is currently unstable")) + (slime-check "No debugger" (not (sldb-get-default-buffer))) + (slime-eval-async `(swank:flow-control-test ,n ,delay)) + (sleep-for 0.2) + (dotimes (_i interrupts) + (slime-interrupt) + (slime-wait-condition "In debugger" (lambda () (slime-sldb-level= 1)) 5) + (slime-check "In debugger" (slime-sldb-level= 1)) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "No debugger" (lambda () (slime-sldb-level= nil)) 3) + (slime-check "Debugger closed" (slime-sldb-level= nil))) + (slime-sync-to-top-level 8)) + +(def-slime-test sbcl-world-lock + (n delay) + "Print something from *MACROEXPAND-HOOK*. +In SBCL, the compiler grabs a lock which can be problematic because +no method dispatch code can be generated for other threads. +This test will fail more likely before dispatch caches are warmed up." + '((10 0.03) + ;;((cl:+ swank::send-counter-limit 10) 0.03) + ) + (slime-test-expect "no error" + 123 + (slime-eval + `(cl:let ((cl:*macroexpand-hook* + (cl:lambda (fun form env) + (swank:flow-control-test ,n ,delay) + (cl:funcall fun form env)))) + (cl:eval '(cl:macrolet ((foo () 123)) + (foo))))))) + +(def-slime-test (disconnect-one-connection (:style :spawn)) () + "`slime-disconnect' should disconnect only the current connection" + '(()) + (let ((connection-count (length slime-net-processes)) + (old-connection slime-default-connection) + (slime-connected-hook nil)) + (unwind-protect + (let ((slime-dispatching-connection + (slime-connect "localhost" + ;; Here we assume that the request will + ;; be evaluated in its own thread. + (slime-eval `(swank:create-server + :port 0 ; use random port + :style :spawn + :dont-close nil))))) + (slime-sync-to-top-level 3) + (slime-disconnect) + (slime-test-expect "Number of connections must remane the same" + connection-count + (length slime-net-processes))) + (slime-select-connection old-connection)))) + +(def-slime-test disconnect-and-reconnect + () + "Close the connetion. +Confirm that the subprocess continues gracefully. +Reconnect afterwards." + '(()) + (slime-check-top-level) + (let* ((c (slime-connection)) + (p (slime-inferior-process c))) + (with-current-buffer (process-buffer p) + (erase-buffer)) + (delete-process c) + (assert (equal (process-status c) 'closed) nil "Connection not closed") + (accept-process-output nil 0.1) + (assert (equal (process-status p) 'run) nil "Subprocess not running") + (with-current-buffer (process-buffer p) + (assert (< (buffer-size) 500) nil "Unusual output")) + (slime-inferior-connect p (slime-inferior-lisp-args p)) + (lexical-let ((hook nil) (p p)) + (setq hook (lambda () + (slime-test-expect + "We are connected again" p (slime-inferior-process)) + (remove-hook 'slime-connected-hook hook))) + (add-hook 'slime-connected-hook hook) + (slime-wait-condition "Lisp restarted" + (lambda () + (not (member hook slime-connected-hook))) + 5)))) + + +;;;; SLIME-loading tests that launch separate Emacsen +;;;; +(cl-defun slime-test-recipe-test-for (&key preflight + takeoff + landing) + (let ((success nil) + (test-file (make-temp-file "slime-recipe-" nil ".el")) + (test-forms + `((require 'cl) + (labels + ((die + (reason &optional more) + (princ reason) + (terpri) + (and more (pp more)) + (kill-emacs 254))) + (condition-case err + (progn ,@preflight) + (error + (die "Unexpected error running preflight forms" + err))) + (add-hook + 'slime-connected-hook + #'(lambda () + (condition-case err + (progn + ,@landing + (kill-emacs 0)) + (error + (die "Unexpected error running landing forms" + err)))) + t) + (condition-case err + (progn + ,@takeoff + ,(when (null landing) '(kill-emacs 0))) + (error + (die "Unexpected error running takeoff forms" + err))) + (with-timeout + (20 + (die "Timeout waiting for recipe test to finish." + takeoff)) + (while t (sit-for 1))))))) + (unwind-protect + (progn + (with-temp-buffer + (mapc #'insert (mapcar #'pp-to-string test-forms)) + (write-file test-file)) + (with-temp-buffer + (let ((retval + (call-process (concat invocation-directory invocation-name) + nil (list t nil) nil + "-Q" "--batch" + "-l" test-file))) + (unless (= 0 retval) + (ert-fail (buffer-substring + (+ (goto-char (point-min)) + (skip-chars-forward " \t\n")) + (+ (goto-char (point-max)) + (skip-chars-backward " \t\n"))))))) + (setq success t)) + (if success (delete-file test-file) + (message "Test failed: keeping %s for inspection" test-file))))) + +(define-slime-ert-test readme-recipe () + "Test the README.md's autoload recipe." + (slime-test-recipe-test-for + :preflight `((add-to-list 'load-path ,slime-path) + (require 'slime-autoloads) + (setq inferior-lisp-program ,inferior-lisp-program) + (setq slime-contribs '(slime-fancy))) + :takeoff `((call-interactively 'slime)) + :landing `((unless (and (featurep 'slime-repl) + (find 'swank-repl slime-required-modules)) + (die "slime-repl not loaded properly")) + (with-current-buffer (slime-repl-buffer) + (unless (and (string-match "^; +SLIME" (buffer-string)) + (string-match "CL-USER> *$" (buffer-string))) + (die "REPL prompt not properly setup" + (buffer-substring-no-properties (point-min) + (point-max)))))))) + +(define-slime-ert-test traditional-recipe () + "Test the README.md's traditional recipe." + (slime-test-recipe-test-for + :preflight `((add-to-list 'load-path ,slime-path) + (require 'slime) + (setq inferior-lisp-program ,inferior-lisp-program) + (slime-setup '(slime-fancy))) + :takeoff `((call-interactively 'slime)) + :landing `((unless (and (featurep 'slime-repl) + (find 'swank-repl slime-required-modules)) + (die "slime-repl not loaded properly")) + (with-current-buffer (slime-repl-buffer) + (unless (and (string-match "^; +SLIME" (buffer-string)) + (string-match "CL-USER> *$" (buffer-string))) + (die "REPL prompt not properly setup" + (buffer-substring-no-properties (point-min) + (point-max)))))))) + +(define-slime-ert-test readme-recipe-autoload-on-lisp-visit () + "Test more autoload bits in README.md's installation recipe." + (slime-test-recipe-test-for + :preflight `((add-to-list 'load-path ,slime-path) + (require 'slime-autoloads)) + :takeoff `((if (featurep 'slime) + (die "Didn't expect SLIME to be loaded so early!")) + (find-file ,(make-temp-file "slime-lisp-source-file" nil + ".lisp")) + (unless (featurep 'slime) + (die "Expected SLIME to be fully loaded by now"))))) + +(defun slime-test-eval-now (string) + (second (slime-eval `(swank:eval-and-grab-output ,string)))) + +(def-slime-test (slime-recompile-all-xrefs (:fails-for "cmucl")) () + "Test recompilation of all references within an xref buffer." + '(()) + (let* ((cell (cons nil nil)) + (hook (slime-curry (lambda (cell &rest _) (setcar cell t)) cell)) + (filename (make-temp-file "slime-recompile-all-xrefs" nil ".lisp"))) + (add-hook 'slime-compilation-finished-hook hook) + (unwind-protect + (with-temp-file filename + (set-visited-file-name filename) + (slime-test-eval-now "(defparameter swank::*.var.* nil)") + (insert "(in-package :swank) + (defun .fn1. ()) + (defun .fn2. () (.fn1.) #.*.var.*) + (defun .fn3. () (.fn1.) #.*.var.*)") + (save-buffer) + (slime-compile-and-load-file) + (slime-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5) + (slime-test-eval-now "(setq *.var.* t)") + (setcar cell nil) + (slime-xref :calls ".fn1." + (lambda (&rest args) + (apply #'slime-show-xrefs args) + (setcar cell t))) + (slime-wait-condition "Xrefs computed and displayed" + (lambda () (car cell)) + 0.5) + (setcar cell nil) + (with-current-buffer slime-xref-last-buffer + (slime-recompile-all-xrefs) + (slime-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5)) + (should (cl-equalp (list (slime-test-eval-now "(.fn2.)") + (slime-test-eval-now "(.fn3.)")) + '("T" "T")))) + (remove-hook 'slime-compilation-finished-hook hook) + (when slime-xref-last-buffer + (kill-buffer slime-xref-last-buffer))))) + +(provide 'slime-tests) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/slime.el b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/slime.el new file mode 100644 index 0000000..cce0f88 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/slime.el @@ -0,0 +1,7659 @@ +;;; slime.el --- Superior Lisp Interaction Mode for Emacs -*-lexical-binding:t-*- + +;; URL: https://github.com/slime/slime +;; Package-Requires: ((cl-lib "0.5") (macrostep "0.9")) +;; Keywords: languages, lisp, slime +;; Version: 2.24 + +;;;; License and Commentary + +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler +;; +;; For a detailed list of contributors, see the manual. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + +;;; Commentary: + +;; 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. +;; +;; The slime-mode programming environment follows the example of +;; Emacs's native Emacs Lisp environment. We have also included good +;; ideas from similar systems (such as ILISP) and some new ideas of +;; our own. +;; +;; SLIME is constructed from two parts: a user-interface written in +;; Emacs Lisp, and a supporting server program written in Common +;; Lisp. The two sides are connected together with a socket and +;; communicate using an RPC-like protocol. +;; +;; The Lisp server is primarily written in portable Common Lisp. The +;; required implementation-specific functionality is specified by a +;; well-defined interface and implemented separately for each Lisp +;; implementation. This makes SLIME readily portable. + +;;; Code: + + +;;;; Dependencies and setup +(eval-and-compile + (require 'cl-lib nil t) + ;; For emacs 23, look for bundled version + (require 'cl-lib "lib/cl-lib")) + +(eval-when-compile (require 'cl)) ; defsetf, lexical-let + +(eval-and-compile + (if (< emacs-major-version 23) + (error "Slime requires an Emacs version of 23, or above"))) + +(require 'hyperspec "lib/hyperspec") +(require 'thingatpt) +(require 'comint) +(require 'pp) +(require 'easymenu) +(require 'outline) +(require 'arc-mode) +(require 'etags) +(require 'compile) + +(eval-when-compile + (require 'apropos) + (require 'gud) + (require 'lisp-mnt)) + +(declare-function lm-version "lisp-mnt") + +(defvar slime-path nil + "Directory containing the Slime package. +This is used to load the supporting Common Lisp library, Swank. +The default value is automatically computed from the location of +the Emacs Lisp package.") +(setq slime-path (file-name-directory load-file-name)) + +(defvar slime-version nil + "The version of SLIME that you're using.") +(setq slime-version + (eval-when-compile + (lm-version + (cl-find "slime.el" + (remove nil + (list load-file-name + (when (boundp 'byte-compile-current-file) + byte-compile-current-file))) + :key #'file-name-nondirectory + :test #'string-equal)))) + +(defvar slime-lisp-modes '(lisp-mode)) +(defvar slime-contribs nil + "A list of contrib packages to load with SLIME.") +(define-obsolete-variable-alias 'slime-setup-contribs +'slime-contribs "2.3.2") + +(defun slime-setup (&optional contribs) + "Setup Emacs so that lisp-mode buffers always use SLIME. +CONTRIBS is a list of contrib packages to load. If `nil', use +`slime-contribs'. " + (interactive) + (when (member 'lisp-mode slime-lisp-modes) + (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) + (when contribs + (setq slime-contribs contribs)) + (slime--setup-contribs)) + +(defvar slime-required-modules '()) + +(defun slime--setup-contribs () + "Load and initialize contribs." + (dolist (c slime-contribs) + (unless (featurep c) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init)))))) + +(defun slime-lisp-mode-hook () + (slime-mode 1) + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function)) + +(defvar slime-protocol-version nil) +(setq slime-protocol-version slime-version) + + +;;;; Customize groups +;; +;;;;; slime + +(defgroup slime nil + "Interaction with the Superior Lisp Environment." + :prefix "slime-" + :group 'applications) + +;;;;; slime-ui + +(defgroup slime-ui nil + "Interaction with the Superior Lisp Environment." + :prefix "slime-" + :group 'slime) + +(defcustom slime-truncate-lines t + "Set `truncate-lines' in popup buffers. +This applies to buffers that present lines as rows of data, such as +debugger backtraces and apropos listings." + :type 'boolean + :group 'slime-ui) + +(defcustom slime-kill-without-query-p nil + "If non-nil, kill SLIME processes without query when quitting Emacs. +This applies to the *inferior-lisp* buffer and the network connections." + :type 'boolean + :group 'slime-ui) + +;;;;; slime-lisp + +(defgroup slime-lisp nil + "Lisp server configuration." + :prefix "slime-" + :group 'slime) + +(defcustom slime-backend "swank-loader.lisp" + "The name of the Lisp file that loads the Swank server. +This name is interpreted relative to the directory containing +slime.el, but could also be set to an absolute filename." + :type 'string + :group 'slime-lisp) + +(defcustom slime-connected-hook nil + "List of functions to call when SLIME connects to Lisp." + :type 'hook + :group 'slime-lisp) + +(defcustom slime-enable-evaluate-in-emacs nil + "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. +The default is nil, as this feature can be a security risk." + :type '(boolean) + :group 'slime-lisp) + +(defcustom slime-lisp-host "localhost" + "The default hostname (or IP address) to connect to." + :type 'string + :group 'slime-lisp) + +(defcustom slime-port 4005 + "Port to use as the default for `slime-connect'." + :type 'integer + :group 'slime-lisp) + +(defvar slime-connect-host-history (list slime-lisp-host)) +(defvar slime-connect-port-history (list (prin1-to-string slime-port))) + +(defvar slime-net-valid-coding-systems + '((iso-latin-1-unix nil "iso-latin-1-unix") + (iso-8859-1-unix nil "iso-latin-1-unix") + (binary nil "iso-latin-1-unix") + (utf-8-unix t "utf-8-unix") + (emacs-mule-unix t "emacs-mule-unix") + (euc-jp-unix t "euc-jp-unix")) + "A list of valid coding systems. +Each element is of the form: (NAME MULTIBYTEP CL-NAME)") + +(defun slime-find-coding-system (name) + "Return the coding system for the symbol NAME. +The result is either an element in `slime-net-valid-coding-systems' +of nil." + (let ((probe (assq name slime-net-valid-coding-systems))) + (when (and probe (if (fboundp 'check-coding-system) + (ignore-errors (check-coding-system (car probe))) + (eq (car probe) 'binary))) + probe))) + +(defcustom slime-net-coding-system + (car (cl-find-if 'slime-find-coding-system + slime-net-valid-coding-systems :key 'car)) + "Coding system used for network connections. +See also `slime-net-valid-coding-systems'." + :type (cons 'choice + (mapcar (lambda (x) + (list 'const (car x))) + slime-net-valid-coding-systems)) + :group 'slime-lisp) + +;;;;; slime-mode + +(defgroup slime-mode nil + "Settings for slime-mode Lisp source buffers." + :prefix "slime-" + :group 'slime) + +(defcustom slime-find-definitions-function 'slime-find-definitions-rpc + "Function to find definitions for a name. +The function is called with the definition name, a string, as its +argument." + :type 'function + :group 'slime-mode + :options '(slime-find-definitions-rpc + slime-etags-definitions + (lambda (name) + (append (slime-find-definitions-rpc name) + (slime-etags-definitions name))) + (lambda (name) + (or (slime-find-definitions-rpc name) + (and tags-table-list + (slime-etags-definitions name)))))) + +;; FIXME: remove one day +(defcustom slime-complete-symbol-function 'nil + "Obsolete. Use `slime-completion-at-point-functions' instead." + :group 'slime-mode + :type '(choice (const :tag "Compound" slime-complete-symbol*) + (const :tag "Fuzzy" slime-fuzzy-complete-symbol))) + +(make-obsolete-variable 'slime-complete-symbol-function + 'slime-completion-at-point-functions + "2015-10-18") + +(defcustom slime-completion-at-point-functions + '(slime-filename-completion + slime-simple-completion-at-point) + "List of functions to perform completion. +Works like `completion-at-point-functions'. +`slime--completion-at-point' uses this variable." + :group 'slime-mode) + +;;;;; slime-mode-faces + +(defgroup slime-mode-faces nil + "Faces in slime-mode source code buffers." + :prefix "slime-" + :group 'slime-mode) + +(defface slime-error-face + `((((class color) (background light)) + (:underline "red")) + (((class color) (background dark)) + (:underline "red")) + (t (:underline t))) + "Face for errors from the compiler." + :group 'slime-mode-faces) + +(defface slime-warning-face + `((((class color) (background light)) + (:underline "orange")) + (((class color) (background dark)) + (:underline "coral")) + (t (:underline t))) + "Face for warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-style-warning-face + `((((class color) (background light)) + (:underline "brown")) + (((class color) (background dark)) + (:underline "gold")) + (t (:underline t))) + "Face for style-warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-note-face + `((((class color) (background light)) + (:underline "brown4")) + (((class color) (background dark)) + (:underline "light goldenrod")) + (t (:underline t))) + "Face for notes from the compiler." + :group 'slime-mode-faces) + +(defface slime-early-deprecation-warning-face + `((((type graphic) (class color) (background light)) + (:strike-through "brown")) + (((type graphic) (class color) (background dark)) + (:strike-through "gold")) + (((type graphic)) + (:strike-through t)) + (((class color) (background light)) + (:underline "brown")) + (((class color) (background dark)) + (:underline "gold")) + (t + (:underline t))) + "Face for early deprecation warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-late-deprecation-warning-face + `((((type graphic) (class color) (background light)) + (:strike-through "orange")) + (((type graphic) (class color) (background dark)) + (:strike-through "coral")) + (((type graphic)) + (:strike-through t)) + (((class color) (background light)) + (:underline "orange")) + (((class color) (background dark)) + (:underline "coral")) + (t + (:underline t))) + "Face for late deprecation warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-final-deprecation-warning-face + `((((type graphic) (class color) (background light)) + (:strike-through "red")) + (((type graphic) (class color) (background dark)) + (:strike-through "red")) + (((type graphic)) + (:strike-through t)) + (((class color) (background light)) + (:underline "red")) + (((class color) (background dark)) + (:underline "red")) + (t + (:strike-through t))) + "Face for final deprecation warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-highlight-face + '((t (:inherit highlight :underline nil))) + "Face for compiler notes while selected." + :group 'slime-mode-faces) + +;;;;; sldb + +(defgroup slime-debugger nil + "Backtrace options and fontification." + :prefix "sldb-" + :group 'slime) + +(defmacro define-sldb-faces (&rest faces) + "Define the set of SLDB faces. +Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES). +NAME is a symbol; the face will be called sldb-NAME-face. +DESCRIPTION is a one-liner for the customization buffer. +PROPERTIES specifies any default face properties." + `(progn ,@(cl-loop for face in faces + collect `(define-sldb-face ,@face)))) + +(defmacro define-sldb-face (name description &optional default) + (let ((facename (intern (format "sldb-%s-face" (symbol-name name))))) + `(defface ,facename + (list (list t ,default)) + ,(format "Face for %s." description) + :group 'slime-debugger))) + +(define-sldb-faces + (topline "the top line describing the error") + (condition "the condition class" + '(:inherit font-lock-warning-face)) + (section "the labels of major sections in the debugger buffer" + '(:inherit header-line)) + (frame-label "backtrace frame numbers" + '(:inherit shadow)) + (restart-type "restart names." + '(:inherit font-lock-keyword-face)) + (restart "restart descriptions") + (restart-number "restart numbers (correspond to keystrokes to invoke)" + '(:bold t)) + (frame-line "function names and arguments in the backtrace") + (restartable-frame-line + "frames which are surely restartable" + '(:foreground "lime green")) + (non-restartable-frame-line + "frames which are surely not restartable") + (detailed-frame-line + "function names and arguments in a detailed (expanded) frame") + (local-name "local variable names" + '(:inherit font-lock-variable-name-face)) + (local-value "local variable values") + (catch-tag "catch tags" + '(:inherit highlight))) + + +;;;; Minor modes + +;;;;; slime-mode + +(defvar slime-mode-indirect-map (make-sparse-keymap) + "Empty keymap which has `slime-mode-map' as it's parent. +This is a hack so that we can reinitilize the real slime-mode-map +more easily. See `slime-init-keymaps'.") + +(defvar slime-buffer-connection) +(defvar slime-dispatching-connection) +(defvar slime-current-thread) + +(defun slime--on () + (slime-setup-completion)) + +(defun slime--off () + (remove-hook 'completion-at-point-functions #'slime--completion-at-point t)) + +(define-minor-mode slime-mode + "\\\ +SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode). + +Commands to compile the current buffer's source file and visually +highlight any resulting compiler notes and warnings: +\\[slime-compile-and-load-file] - Compile and load the current buffer's file. +\\[slime-compile-file] - Compile (but not load) the current buffer's file. +\\[slime-compile-defun] - Compile the top-level form at point. + +Commands for visiting compiler notes: +\\[slime-next-note] - Goto the next form with a compiler note. +\\[slime-previous-note] - Goto the previous form with a compiler note. +\\[slime-remove-notes] - Remove compiler-note annotations in buffer. + +Finding definitions: +\\[slime-edit-definition] +- Edit the definition of the function called at point. +\\[slime-pop-find-definition-stack] +- Pop the definition stack to go back from a definition. + +Documentation commands: +\\[slime-describe-symbol] - Describe symbol. +\\[slime-apropos] - Apropos search. +\\[slime-disassemble-symbol] - Disassemble a function. + +Evaluation commands: +\\[slime-eval-defun] - Evaluate top-level from containing point. +\\[slime-eval-last-expression] - Evaluate sexp before point. +\\[slime-pprint-eval-last-expression] \ +- Evaluate sexp before point, pretty-print result. + +Full set of commands: +\\{slime-mode-map}" + :keymap slime-mode-indirect-map + :lighter (:eval (slime-modeline-string)) + (cond (slime-mode (slime--on)) + (t (slime--off)))) + + +;;;;;; Modeline + +(defun slime-modeline-string () + "Return the string to display in the modeline. +\"Slime\" only appears if we aren't connected. If connected, +include package-name, connection-name, and possibly some state +information." + (let ((conn (slime-current-connection))) + ;; Bail out early in case there's no connection, so we won't + ;; implicitly invoke `slime-connection' which may query the user. + (if (not conn) + (and slime-mode " Slime") + (let ((local (eq conn slime-buffer-connection)) + (pkg (slime-current-package))) + (concat " " + (if local "{" "[") + (if pkg (slime-pretty-package-name pkg) "?") + " " + ;; ignore errors for closed connections + (ignore-errors (slime-connection-name conn)) + (slime-modeline-state-string conn) + (if local "}" "]")))))) + +(defun slime-pretty-package-name (name) + "Return a pretty version of a package name NAME." + (cond ((string-match "^#?:\\(.*\\)$" name) + (match-string 1 name)) + ((string-match "^\"\\(.*\\)\"$" name) + (match-string 1 name)) + (t name))) + +(defun slime-modeline-state-string (conn) + "Return a string possibly describing CONN's state." + (cond ((not (eq (process-status conn) 'open)) + (format " %s" (process-status conn))) + ((let ((pending (length (slime-rex-continuations conn))) + (sldbs (length (sldb-buffers conn)))) + (cond ((and (zerop sldbs) (zerop pending)) nil) + ((zerop sldbs) (format " %s" pending)) + (t (format " %s/%s" pending sldbs))))))) + +(defun slime--recompute-modelines () + (force-mode-line-update t)) + + +;;;;; Key bindings + +(defvar slime-parent-map nil + "Parent keymap for shared between all Slime related modes.") + +(defvar slime-parent-bindings + '(("\M-." slime-edit-definition) + ("\M-," slime-pop-find-definition-stack) + ("\M-_" slime-edit-uses) ; for German layout + ("\M-?" slime-edit-uses) ; for USian layout + ("\C-x4." slime-edit-definition-other-window) + ("\C-x5." slime-edit-definition-other-frame) + ("\C-x\C-e" slime-eval-last-expression) + ("\C-\M-x" slime-eval-defun) + ;; Include PREFIX keys... + ("\C-c" slime-prefix-map))) + +(defvar slime-prefix-map nil + "Keymap for commands prefixed with `slime-prefix-key'.") + +(defvar slime-prefix-bindings + '(("\C-r" slime-eval-region) + (":" slime-interactive-eval) + ("\C-e" slime-interactive-eval) + ("E" slime-edit-value) + ("\C-l" slime-load-file) + ("\C-b" slime-interrupt) + ("\M-d" slime-disassemble-symbol) + ("\C-t" slime-toggle-trace-fdefinition) + ("I" slime-inspect) + ("\C-xt" slime-list-threads) + ("\C-xn" slime-next-connection) + ("\C-xp" slime-prev-connection) + ("\C-xc" slime-list-connections) + ("<" slime-list-callers) + (">" slime-list-callees) + ;; Include DOC keys... + ("\C-d" slime-doc-map) + ;; Include XREF WHO-FOO keys... + ("\C-w" slime-who-map) + )) + +(defvar slime-editing-map nil + "These keys are useful for buffers where the user can insert and +edit s-exprs, e.g. for source buffers and the REPL.") + +(defvar slime-editing-keys + `(;; Arglist display & completion + (" " slime-space) + ;; Evaluating + ;;("\C-x\M-e" slime-eval-last-expression-display-output :inferior t) + ("\C-c\C-p" slime-pprint-eval-last-expression) + ;; Macroexpand + ("\C-c\C-m" slime-expand-1) + ("\C-c\M-m" slime-macroexpand-all) + ;; Misc + ("\C-c\C-u" slime-undefine-function) + (,(kbd "C-M-.") slime-next-location) + (,(kbd "C-M-,") slime-previous-location) + ;; Obsolete, redundant bindings + ("\C-c\C-i" completion-at-point) + ;;("\M-*" pop-tag-mark) ; almost to clever + )) + +(defvar slime-mode-map nil + "Keymap for slime-mode.") + +(defvar slime-keys + '( ;; Compiler notes + ("\M-p" slime-previous-note) + ("\M-n" slime-next-note) + ("\C-c\M-c" slime-remove-notes) + ("\C-c\C-k" slime-compile-and-load-file) + ("\C-c\M-k" slime-compile-file) + ("\C-c\C-c" slime-compile-defun))) + +(defun slime-nop () + "The null command. Used to shadow currently-unused keybindings." + (interactive) + (call-interactively 'undefined)) + +(defvar slime-doc-map nil + "Keymap for documentation commands. Bound to a prefix key.") + +(defvar slime-doc-bindings + '((?a slime-apropos) + (?z slime-apropos-all) + (?p slime-apropos-package) + (?d slime-describe-symbol) + (?f slime-describe-function) + (?h slime-documentation-lookup) + (?~ common-lisp-hyperspec-format) + (?g common-lisp-hyperspec-glossary-term) + (?# common-lisp-hyperspec-lookup-reader-macro))) + +(defvar slime-who-map nil + "Keymap for who-xref commands. Bound to a prefix key.") + +(defvar slime-who-bindings + '((?c slime-who-calls) + (?w slime-calls-who) + (?r slime-who-references) + (?b slime-who-binds) + (?s slime-who-sets) + (?m slime-who-macroexpands) + (?a slime-who-specializes))) + +(defun slime-init-keymaps () + "(Re)initialize the keymaps for `slime-mode'." + (interactive) + (slime-init-keymap 'slime-doc-map t t slime-doc-bindings) + (slime-init-keymap 'slime-who-map t t slime-who-bindings) + (slime-init-keymap 'slime-prefix-map t nil slime-prefix-bindings) + (slime-init-keymap 'slime-parent-map nil nil slime-parent-bindings) + (slime-init-keymap 'slime-editing-map nil nil slime-editing-keys) + (set-keymap-parent slime-editing-map slime-parent-map) + (slime-init-keymap 'slime-mode-map nil nil slime-keys) + (set-keymap-parent slime-mode-map slime-editing-map) + (set-keymap-parent slime-mode-indirect-map slime-mode-map)) + +(defun slime-init-keymap (keymap-name prefixp bothp bindings) + (set keymap-name (make-sparse-keymap)) + (when prefixp (define-prefix-command keymap-name)) + (slime-bind-keys (eval keymap-name) bothp bindings)) + +(defun slime-bind-keys (keymap bothp bindings) + "Add BINDINGS to KEYMAP. +If BOTHP is true also add bindings with control modifier." + (cl-loop for (key command) in bindings do + (cond (bothp + (define-key keymap `[,key] command) + (unless (equal key ?h) ; But don't bind C-h + (define-key keymap `[(control ,key)] command))) + (t (define-key keymap key command))))) + +(slime-init-keymaps) + +(define-minor-mode slime-editing-mode + "Minor mode which makes slime-editing-map available. +\\{slime-editing-map}" + nil + nil + slime-editing-map) + + +;;;; Framework'ey bits +;;; +;;; This section contains some standard SLIME idioms: basic macros, +;;; ways of showing messages to the user, etc. All the code in this +;;; file should use these functions when applicable. +;;; +;;;;; Syntactic sugar + +(defmacro slime-dcase (value &rest patterns) + (declare (indent 1)) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (cl-gensym "op-")) + (operands (cl-gensym "rand-")) + (tmp (cl-gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (cl-case ,operator + ,@(mapcar (lambda (clause) + (if (eq (car clause) t) + `(t ,@(cdr clause)) + (cl-destructuring-bind ((op &rest rands) &rest body) + clause + `(,op (cl-destructuring-bind ,rands ,operands + . ,(or body + '((ignore)) ; suppress some warnings + )))))) + patterns) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "slime-dcase failed: %S" ,tmp)))))))) + +(defmacro slime-define-keys (keymap &rest key-command) + "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)." + (declare (indent 1)) + `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c)) + key-command))) + +(cl-defmacro with-struct ((conc-name &rest slots) struct &body body) + "Like with-slots but works only for structs. +\(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)" + (declare (indent 2)) + (let ((struct-var (cl-gensym "struct")) + (reader (lambda (slot) + (intern (concat (symbol-name conc-name) + (symbol-name slot)))))) + `(let ((,struct-var ,struct)) + (cl-symbol-macrolet + ,(mapcar (lambda (slot) + (cl-etypecase slot + (symbol `(,slot (,(funcall reader slot) ,struct-var))) + (cons `(,(cl-first slot) + (,(funcall reader (cl-second slot)) + ,struct-var))))) + slots) + . ,body)))) + +;;;;; Very-commonly-used functions + +(defvar slime-message-function 'message) + +;; Interface +(defun slime-buffer-name (type &optional hidden) + (cl-assert (keywordp type)) + (concat (if hidden " " "") + (format "*slime-%s*" (substring (symbol-name type) 1)))) + +;; Interface +(defun slime-message (format &rest args) + "Like `message' but with special support for multi-line messages. +Single-line messages use the echo area." + (apply slime-message-function format args)) + +(defun slime-display-warning (message &rest args) + (display-warning '(slime warning) (apply #'format message args))) + +(defvar slime-background-message-function 'slime-display-oneliner) + +;; Interface +(defun slime-background-message (format-string &rest format-args) + "Display a message in passing. +This is like `slime-message', but less distracting because it +will never pop up a buffer or display multi-line messages. +It should be used for \"background\" messages such as argument lists." + (apply slime-background-message-function format-string format-args)) + +(defun slime-display-oneliner (format-string &rest format-args) + (let* ((msg (apply #'format format-string format-args))) + (unless (minibuffer-window-active-p (minibuffer-window)) + (message "%s" (slime-oneliner msg))))) + +(defun slime-oneliner (string) + "Return STRING truncated to fit in a single echo-area line." + (substring string 0 (min (length string) + (or (cl-position ?\n string) most-positive-fixnum) + (1- (window-width (minibuffer-window)))))) + +;; Interface +(defun slime-set-truncate-lines () + "Apply `slime-truncate-lines' to the current buffer." + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +;; Interface +(defun slime-read-package-name (prompt &optional initial-value) + "Read a package name from the minibuffer, prompting with PROMPT." + (let ((completion-ignore-case t)) + (completing-read prompt (slime-bogus-completion-alist + (slime-eval + `(swank:list-all-package-names t))) + nil t initial-value))) + +;; Interface +(defun slime-read-symbol-name (prompt &optional query) + "Either read a symbol name or choose the one at point. +The user is prompted if a prefix argument is in effect, if there is no +symbol at point, or if QUERY is non-nil." + (cond ((or current-prefix-arg query (not (slime-symbol-at-point))) + (slime-read-from-minibuffer prompt (slime-symbol-at-point))) + (t (slime-symbol-at-point)))) + +;; Interface +(defmacro slime-propertize-region (props &rest body) + "Execute BODY and add PROPS to all the text it inserts. +More precisely, PROPS are added to the region between the point's +positions before and after executing BODY." + (declare (indent 1) (debug (sexp &rest form))) + (let ((start (cl-gensym))) + `(let ((,start (point))) + (prog1 (progn ,@body) + (add-text-properties ,start (point) ,props))))) + +(defun slime-add-face (face string) + (declare (indent 1)) + (add-text-properties 0 (length string) (list 'face face) string) + string) + +;; Interface +(defsubst slime-insert-propertized (props &rest args) + "Insert all ARGS and then add text-PROPS to the inserted text." + (slime-propertize-region props (apply #'insert args))) + +(defmacro slime-with-rigid-indentation (level &rest body) + "Execute BODY and then rigidly indent its text insertions. +Assumes all insertions are made at point." + (declare (indent 1)) + (let ((start (cl-gensym)) (l (cl-gensym))) + `(let ((,start (point)) (,l ,(or level '(current-column)))) + (prog1 (progn ,@body) + (slime-indent-rigidly ,start (point) ,l))))) + +(defun slime-indent-rigidly (start end column) + ;; Similar to `indent-rigidly' but doesn't inherit text props. + (let ((indent (make-string column ?\ ))) + (save-excursion + (goto-char end) + (beginning-of-line) + (while (and (<= start (point)) + (progn + (insert-before-markers indent) + (zerop (forward-line -1)))))))) + +(defun slime-insert-indented (&rest strings) + "Insert all arguments rigidly indented." + (slime-with-rigid-indentation nil + (apply #'insert strings))) + +(defun slime-property-bounds (prop) + "Return two the positions of the previous and next changes to PROP. +PROP is the name of a text property." + (cl-assert (get-text-property (point) prop)) + (let ((end (next-single-char-property-change (point) prop))) + (list (previous-single-char-property-change end prop) end))) + +(defun slime-curry (fun &rest args) + "Partially apply FUN to ARGS. The result is a new function. +This idiom is preferred over `lexical-let'." + `(lambda (&rest more) (apply ',fun (append ',args more)))) + +(defun slime-rcurry (fun &rest args) + "Like `slime-curry' but ARGS on the right are applied." + `(lambda (&rest more) (apply ',fun (append more ',args)))) + + +;;;;; Temporary popup buffers + +;; keep compiler quiet +(defvar slime-buffer-package) +(defvar slime-buffer-connection) + +;; Interface +(cl-defmacro slime-with-popup-buffer ((name &key package connection select + mode) + &body body) + "Similar to `with-output-to-temp-buffer'. +Bind standard-output and initialize some buffer-local variables. +Restore window configuration when closed. + +NAME is the name of the buffer to be created. +PACKAGE is the value `slime-buffer-package'. +CONNECTION is the value for `slime-buffer-connection', + if nil, no explicit connection is associated with + the buffer. If t, the current connection is taken. +MODE is the name of a major mode which will be enabled. +" + (declare (indent 1)) + (let ((package-sym (cl-gensym "package-")) + (connection-sym (cl-gensym "connection-"))) + `(let ((,package-sym ,(if (eq package t) + `(slime-current-package) + package)) + (,connection-sym ,(if (eq connection t) + `(slime-current-connection) + connection))) + (with-current-buffer (get-buffer-create ,name) + (let ((inhibit-read-only t) + (standard-output (current-buffer))) + (erase-buffer) + (funcall (or ,mode 'fundamental-mode)) + (setq slime-buffer-package ,package-sym + slime-buffer-connection ,connection-sym) + (set-syntax-table lisp-mode-syntax-table) + ,@body + (slime-popup-buffer-mode 1) + (funcall (if ,select 'pop-to-buffer 'display-buffer) + (current-buffer)) + (current-buffer)))))) + +(defvar slime-popup-buffer-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "q") 'quit-window) + ;;("\C-c\C-z" . slime-switch-to-output-buffer) + (define-key map (kbd "M-.") 'slime-edit-definition) + map)) + +(define-minor-mode slime-popup-buffer-mode + "Mode for displaying read only stuff" + nil nil nil + (setq buffer-read-only t)) + +(add-to-list 'minor-mode-alist + `(slime-popup-buffer-mode + (:eval (unless slime-mode + (slime-modeline-string))))) + +(set-keymap-parent slime-popup-buffer-mode-map slime-parent-map) + +;;;;; Filename translation +;;; +;;; Filenames passed between Emacs and Lisp should be translated using +;;; these functions. This way users who run Emacs and Lisp on separate +;;; machines have a chance to integrate file operations somehow. + +(defvar slime-to-lisp-filename-function #'convert-standard-filename + "Function to translate Emacs filenames to CL namestrings.") +(defvar slime-from-lisp-filename-function #'identity + "Function to translate CL namestrings to Emacs filenames.") + +(defun slime-to-lisp-filename (filename) + "Translate the string FILENAME to a Lisp filename." + (funcall slime-to-lisp-filename-function filename)) + +(defun slime-from-lisp-filename (filename) + "Translate the Lisp filename FILENAME to an Emacs filename." + (funcall slime-from-lisp-filename-function filename)) + + +;;;; Starting SLIME +;;; +;;; This section covers starting an inferior-lisp, compiling and +;;; starting the server, initiating a network connection. + +;;;;; Entry points + +;; We no longer load inf-lisp, but we use this variable for backward +;; compatibility. +(defvar inferior-lisp-program "lisp" + "*Program name for invoking an inferior Lisp with for Inferior Lisp mode.") + +(defvar slime-lisp-implementations nil + "*A list of known Lisp implementations. +The list should have the form: + ((NAME (PROGRAM PROGRAM-ARGS...) &key KEYWORD-ARGS) ...) + +NAME is a symbol for the implementation. +PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process. +For KEYWORD-ARGS see `slime-start'. + +Here's an example: + ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init slime-init-command) + (acl (\"acl7\") :coding-system emacs-mule))") + +(defvar slime-default-lisp nil + "*The name of the default Lisp implementation. +See `slime-lisp-implementations'") + +;; dummy definitions for the compiler +(defvar slime-net-processes) +(defvar slime-default-connection) + +(defun slime (&optional command coding-system) + "Start an inferior^_superior Lisp and connect to its Swank server." + (interactive) + (slime-setup) + (let ((inferior-lisp-program (or command inferior-lisp-program)) + (slime-net-coding-system (or coding-system slime-net-coding-system))) + (slime-start* (cond ((and command (symbolp command)) + (slime-lisp-options command)) + (t (slime-read-interactive-args)))))) + +(defvar slime-inferior-lisp-program-history '() + "History list of command strings. Used by `slime'.") + +(defun slime-read-interactive-args () + "Return the list of args which should be passed to `slime-start'. + +The rules for selecting the arguments are rather complicated: + +- In the most common case, i.e. if there's no prefix-arg in + effect and if `slime-lisp-implementations' is nil, use + `inferior-lisp-program' as fallback. + +- If the table `slime-lisp-implementations' is non-nil use the + implementation with name `slime-default-lisp' or if that's nil + the first entry in the table. + +- If the prefix-arg is `-', prompt for one of the registered + lisps. + +- If the prefix-arg is positive, read the command to start the + process." + (let ((table slime-lisp-implementations)) + (cond ((not current-prefix-arg) (slime-lisp-options)) + ((eq current-prefix-arg '-) + (let ((key (completing-read + "Lisp name: " (mapcar (lambda (x) + (list (symbol-name (car x)))) + table) + nil t))) + (slime-lookup-lisp-implementation table (intern key)))) + (t + (cl-destructuring-bind (program &rest program-args) + (split-string-and-unquote + (read-shell-command "Run lisp: " inferior-lisp-program + 'slime-inferior-lisp-program-history)) + (let ((coding-system + (if (eq 16 (prefix-numeric-value current-prefix-arg)) + (read-coding-system "set slime-coding-system: " + slime-net-coding-system) + slime-net-coding-system))) + (list :program program :program-args program-args + :coding-system coding-system))))))) + +(defun slime-lisp-options (&optional name) + (let ((table slime-lisp-implementations)) + (cl-assert (or (not name) table)) + (cond (table (slime-lookup-lisp-implementation slime-lisp-implementations + (or name slime-default-lisp + (car (car table))))) + (t (cl-destructuring-bind (program &rest args) + (split-string inferior-lisp-program) + (list :program program :program-args args)))))) + +(defun slime-lookup-lisp-implementation (table name) + (let ((arguments (cl-rest (assoc name table)))) + (unless arguments + (error "Could not find lisp implementation with the name '%S'" name)) + (when (and (= (length arguments) 1) + (functionp (cl-first arguments))) + (setf arguments (funcall (cl-first arguments)))) + (cl-destructuring-bind ((prog &rest args) &rest keys) arguments + (cl-list* :name name :program prog :program-args args keys)))) + +(cl-defun slime-start (&key (program inferior-lisp-program) program-args + directory + (coding-system slime-net-coding-system) + (init 'slime-init-command) + name + (buffer "*inferior-lisp*") + init-function + env) + "Start a Lisp process and connect to it. +This function is intended for programmatic use if `slime' is not +flexible enough. + +PROGRAM and PROGRAM-ARGS are the filename and argument strings + for the subprocess. +INIT is a function that should return a string to load and start + Swank. The function will be called with the PORT-FILENAME and ENCODING as + arguments. INIT defaults to `slime-init-command'. +CODING-SYSTEM a symbol for the coding system. The default is + slime-net-coding-system +ENV environment variables for the subprocess (see `process-environment'). +INIT-FUNCTION function to call right after the connection is established. +BUFFER the name of the buffer to use for the subprocess. +NAME a symbol to describe the Lisp implementation +DIRECTORY change to this directory before starting the process. +" + (let ((args (list :program program :program-args program-args :buffer buffer + :coding-system coding-system :init init :name name + :init-function init-function :env env))) + (slime-check-coding-system coding-system) + (when (slime-bytecode-stale-p) + (slime-urge-bytecode-recompile)) + (let ((proc (slime-maybe-start-lisp program program-args env + directory buffer))) + (slime-inferior-connect proc args) + (pop-to-buffer (process-buffer proc))))) + +(defun slime-start* (options) + (apply #'slime-start options)) + +(defun slime-connect (host port &optional _coding-system interactive-p) + "Connect to a running Swank server. Return the connection." + (interactive (list (read-from-minibuffer + "Host: " (cl-first slime-connect-host-history) + nil nil '(slime-connect-host-history . 1)) + (string-to-number + (read-from-minibuffer + "Port: " (cl-first slime-connect-port-history) + nil nil '(slime-connect-port-history . 1))) + nil t)) + (slime-setup) + (when (and interactive-p + slime-net-processes + (y-or-n-p "Close old connections first? ")) + (slime-disconnect-all)) + (message "Connecting to Swank on port %S.." port) + (let* ((process (slime-net-connect host port)) + (slime-dispatching-connection process)) + (slime-setup-connection process))) + +;; FIXME: seems redundant +(defun slime-start-and-init (options fun) + (let* ((rest (plist-get options :init-function)) + (init (cond (rest `(lambda () (funcall ',rest) (funcall ',fun))) + (t fun)))) + (slime-start* (plist-put (cl-copy-list options) :init-function init)))) + +;;;;; Start inferior lisp +;;; +;;; Here is the protocol for starting SLIME: +;;; +;;; 0. Emacs recompiles/reloads slime.elc if it exists and is stale. +;;; 1. Emacs starts an inferior Lisp process. +;;; 2. Emacs tells Lisp (via stdio) to load and start Swank. +;;; 3. Lisp recompiles the Swank if needed. +;;; 4. Lisp starts the Swank server and writes its TCP port to a temp file. +;;; 5. Emacs reads the temp file to get the port and then connects. +;;; 6. Emacs prints a message of warm encouragement for the hacking ahead. +;;; +;;; Between steps 2-5 Emacs polls for the creation of the temp file so +;;; that it can make the connection. This polling may continue for a +;;; fair while if Swank needs recompilation. + +(defvar slime-connect-retry-timer nil + "Timer object while waiting for an inferior-lisp to start.") + +;;; Recompiling bytecode: + +(defun slime-bytecode-stale-p () + "Return true if slime.elc is older than slime.el." + (let ((libfile (locate-library "slime"))) + (when libfile + (let* ((basename (file-name-sans-extension libfile)) + (sourcefile (concat basename ".el")) + (bytefile (concat basename ".elc"))) + (and (file-exists-p bytefile) + (file-newer-than-file-p sourcefile bytefile)))))) + +(defun slime-recompile-bytecode () + "Recompile and reload slime." + (interactive) + (let ((sourcefile (concat (file-name-sans-extension (locate-library "slime")) + ".el"))) + (byte-compile-file sourcefile t))) + +(defun slime-urge-bytecode-recompile () + "Urge the user to recompile slime.elc. +Return true if we have been given permission to continue." + (when (y-or-n-p "slime.elc is older than source. Recompile first? ") + (slime-recompile-bytecode))) + +(defun slime-abort-connection () + "Abort connection the current connection attempt." + (interactive) + (cond (slime-connect-retry-timer + (slime-cancel-connect-retry-timer) + (message "Cancelled connection attempt.")) + (t (error "Not connecting")))) + +;;; Starting the inferior Lisp and loading Swank: + +(defun slime-maybe-start-lisp (program program-args env directory buffer) + "Return a new or existing inferior lisp process." + (cond ((not (comint-check-proc buffer)) + (slime-start-lisp program program-args env directory buffer)) + ((slime-reinitialize-inferior-lisp-p program program-args env buffer) + (let ((conn (cl-find (get-buffer-process buffer) + slime-net-processes + :key #'slime-inferior-process))) + (when conn + (slime-net-close conn))) + (get-buffer-process buffer)) + (t (slime-start-lisp program program-args env directory + (generate-new-buffer-name buffer))))) + +(defun slime-reinitialize-inferior-lisp-p (program program-args env buffer) + (let ((args (slime-inferior-lisp-args (get-buffer-process buffer)))) + (and (equal (plist-get args :program) program) + (equal (plist-get args :program-args) program-args) + (equal (plist-get args :env) env) + (not (y-or-n-p "Create an additional *inferior-lisp*? "))))) + +(defvar slime-inferior-process-start-hook nil + "Hook called whenever a new process gets started.") + +(defun slime-start-lisp (program program-args env directory buffer) + "Does the same as `inferior-lisp' but less ugly. +Return the created process." + (with-current-buffer (get-buffer-create buffer) + (when directory + (cd (expand-file-name directory))) + (comint-mode) + (let ((process-environment (append env process-environment)) + (process-connection-type nil)) + (comint-exec (current-buffer) "inferior-lisp" program nil program-args)) + (lisp-mode-variables t) + (let ((proc (get-buffer-process (current-buffer)))) + (slime-set-query-on-exit-flag proc) + (run-hooks 'slime-inferior-process-start-hook) + proc))) + +(defun slime-inferior-connect (process args) + "Start a Swank server in the inferior Lisp and connect." + (slime-delete-swank-port-file 'quiet) + (slime-start-swank-server process args) + (slime-read-port-and-connect process)) + +(defvar slime-inferior-lisp-args nil + "A buffer local variable in the inferior proccess. +See `slime-start'.") + +(defun slime-start-swank-server (process args) + "Start a Swank server on the inferior lisp." + (cl-destructuring-bind (&key coding-system init &allow-other-keys) args + (with-current-buffer (process-buffer process) + (make-local-variable 'slime-inferior-lisp-args) + (setq slime-inferior-lisp-args args) + (let ((str (funcall init (slime-swank-port-file) coding-system))) + (goto-char (process-mark process)) + (insert-before-markers str) + (process-send-string process str))))) + +(defun slime-inferior-lisp-args (process) + "Return the initial process arguments. +See `slime-start'." + (with-current-buffer (process-buffer process) + slime-inferior-lisp-args)) + +;; XXX load-server & start-server used to be separated. maybe that was better. +(defun slime-init-command (port-filename _coding-system) + "Return a string to initialize Lisp." + (let ((loader (if (file-name-absolute-p slime-backend) + slime-backend + (concat slime-path slime-backend)))) + ;; Return a single form to avoid problems with buffered input. + (format "%S\n\n" + `(progn + (load ,(slime-to-lisp-filename (expand-file-name loader)) + :verbose t) + (funcall (read-from-string "swank-loader:init") + :from-emacs t) + (funcall (read-from-string "swank:start-server") + ,(slime-to-lisp-filename port-filename)))))) + +(defun slime-swank-port-file () + "Filename where the SWANK server writes its TCP port number." + (expand-file-name (format "slime.%S" (emacs-pid)) (slime-temp-directory))) + +(defun slime-temp-directory () + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + (t "/tmp/"))) + +(defun slime-delete-swank-port-file (&optional quiet) + (condition-case data + (delete-file (slime-swank-port-file)) + (error + (cl-ecase quiet + ((nil) (signal (car data) (cdr data))) + (quiet) + (message (message "Unable to delete swank port file %S" + (slime-swank-port-file))))))) + +(defun slime-read-port-and-connect (inferior-process) + (slime-attempt-connection inferior-process nil 1)) + +(defun slime-attempt-connection (process retries attempt) + ;; A small one-state machine to attempt a connection with + ;; timer-based retries. + (slime-cancel-connect-retry-timer) + (let ((file (slime-swank-port-file))) + (unless (active-minibuffer-window) + (message "Polling %S .. %d (Abort with `M-x slime-abort-connection'.)" + file attempt)) + (cond ((and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) ; file size + (let ((port (slime-read-swank-port)) + (args (slime-inferior-lisp-args process))) + (slime-delete-swank-port-file 'message) + (let ((c (slime-connect slime-lisp-host port + (plist-get args :coding-system)))) + (slime-set-inferior-process c process)))) + ((and retries (zerop retries)) + (message "Gave up connecting to Swank after %d attempts." attempt)) + ((eq (process-status process) 'exit) + (message "Failed to connect to Swank: inferior process exited.")) + (t + (when (and (file-exists-p file) + (zerop (nth 7 (file-attributes file)))) + (message "(Zero length port file)") + ;; the file may be in the filesystem but not yet written + (unless retries (setq retries 3))) + (cl-assert (not slime-connect-retry-timer)) + (setq slime-connect-retry-timer + (run-with-timer + 0.3 nil + #'slime-timer-call #'slime-attempt-connection + process (and retries (1- retries)) + (1+ attempt))))))) + +(defun slime-timer-call (fun &rest args) + "Call function FUN with ARGS, reporting all errors. + +The default condition handler for timer functions (see +`timer-event-handler') ignores errors." + (condition-case data + (apply fun args) + ((debug error) + (debug nil (list "Error in timer" fun args data))))) + +(defun slime-cancel-connect-retry-timer () + (when slime-connect-retry-timer + (cancel-timer slime-connect-retry-timer) + (setq slime-connect-retry-timer nil))) + +(defun slime-read-swank-port () + "Read the Swank server port number from the `slime-swank-port-file'." + (save-excursion + (with-temp-buffer + (insert-file-contents (slime-swank-port-file)) + (goto-char (point-min)) + (let ((port (read (current-buffer)))) + (cl-assert (integerp port)) + port)))) + +(defun slime-toggle-debug-on-swank-error () + (interactive) + (if (slime-eval `(swank:toggle-debug-on-swank-error)) + (message "Debug on SWANK error enabled.") + (message "Debug on SWANK error disabled."))) + +;;; Words of encouragement + +(defun slime-user-first-name () + (let ((name (if (string= (user-full-name) "") + (user-login-name) + (user-full-name)))) + (string-match "^[^ ]*" name) + (capitalize (match-string 0 name)))) + +(defvar slime-words-of-encouragement + `("Let the hacking commence!" + "Hacks and glory await!" + "Hack and be merry!" + "Your hacking starts... NOW!" + "May the source be with you!" + "Take this REPL, brother, and may it serve you well." + "Lemonodor-fame is but a hack away!" + "Are we consing yet?" + ,(format "%s, this could be the start of a beautiful program." + (slime-user-first-name))) + "Scientifically-proven optimal words of hackerish encouragement.") + +(defun slime-random-words-of-encouragement () + "Return a string of hackerish encouragement." + (eval (nth (random (length slime-words-of-encouragement)) + slime-words-of-encouragement))) + + +;;;; Networking +;;; +;;; This section covers the low-level networking: establishing +;;; connections and encoding/decoding protocol messages. +;;; +;;; Each SLIME protocol message beings with a 6-byte header followed +;;; by an S-expression as text. The sexp must be readable both by +;;; Emacs and by Common Lisp, so if it contains any embedded code +;;; fragments they should be sent as strings: +;;; +;;; The set of meaningful protocol messages are not specified +;;; here. They are defined elsewhere by the event-dispatching +;;; functions in this file and in swank.lisp. + +(defvar slime-net-processes nil + "List of processes (sockets) connected to Lisps.") + +(defvar slime-net-process-close-hooks '() + "List of functions called when a slime network connection closes. +The functions are called with the process as their argument.") + +(defun slime-secret () + "Find the magic secret from the user's home directory. +Return nil if the file doesn't exist or is empty; otherwise the +first line of the file." + (condition-case _err + (with-temp-buffer + (insert-file-contents "~/.slime-secret") + (goto-char (point-min)) + (buffer-substring (point-min) (line-end-position))) + (file-error nil))) + +;;; Interface + +(defun slime-send-secret (proc) + (let ((secret (slime-secret))) + (when secret + (let* ((payload (encode-coding-string secret 'utf-8-unix)) + (string (concat (slime-net-encode-length (length payload)) + payload))) + (process-send-string proc string))))) + +(defun slime-net-connect (host port) + "Establish a connection with a CL." + (let* ((inhibit-quit nil) + (proc (open-network-stream "SLIME Lisp" nil host port)) + (buffer (slime-make-net-buffer " *cl-connection*"))) + (push proc slime-net-processes) + (set-process-buffer proc buffer) + (set-process-filter proc 'slime-net-filter) + (set-process-sentinel proc 'slime-net-sentinel) + (slime-set-query-on-exit-flag proc) + (when (fboundp 'set-process-coding-system) + (set-process-coding-system proc 'binary 'binary)) + (slime-send-secret proc) + proc)) + +(defun slime-make-net-buffer (name) + "Make a buffer suitable for a network process." + (let ((buffer (generate-new-buffer name))) + (with-current-buffer buffer + (buffer-disable-undo) + (set (make-local-variable 'kill-buffer-query-functions) nil)) + buffer)) + +(defun slime-set-query-on-exit-flag (process) + "Set PROCESS's query-on-exit-flag to `slime-kill-without-query-p'." + (when slime-kill-without-query-p + ;; avoid byte-compiler warnings + (let ((fun (if (fboundp 'set-process-query-on-exit-flag) + 'set-process-query-on-exit-flag + 'process-kill-without-query))) + (funcall fun process nil)))) + +;;;;; Coding system madness + +(defun slime-check-coding-system (coding-system) + "Signal an error if CODING-SYSTEM isn't a valid coding system." + (interactive) + (let ((props (slime-find-coding-system coding-system))) + (unless props + (error "Invalid slime-net-coding-system: %s. %s" + coding-system (mapcar #'car slime-net-valid-coding-systems))) + (when (and (cl-second props) (boundp 'default-enable-multibyte-characters)) + (cl-assert default-enable-multibyte-characters)) + t)) + +(defun slime-coding-system-mulibyte-p (coding-system) + (cl-second (slime-find-coding-system coding-system))) + +(defun slime-coding-system-cl-name (coding-system) + (cl-third (slime-find-coding-system coding-system))) + +;;; Interface +(defun slime-net-send (sexp proc) + "Send a SEXP to Lisp over the socket PROC. +This is the lowest level of communication. The sexp will be READ and +EVAL'd by Lisp." + (let* ((payload (encode-coding-string + (concat (slime-prin1-to-string sexp) "\n") + 'utf-8-unix)) + (string (concat (slime-net-encode-length (length payload)) + payload))) + (slime-log-event sexp) + (process-send-string proc string))) + +(defun slime-safe-encoding-p (coding-system string) + "Return true iff CODING-SYSTEM can safely encode STRING." + (or (let ((candidates (find-coding-systems-string string)) + (base (coding-system-base coding-system))) + (or (equal candidates '(undecided)) + (memq base candidates))) + (and (not (multibyte-string-p string)) + (not (slime-coding-system-mulibyte-p coding-system))))) + +(defun slime-net-close (process &optional debug) + (setq slime-net-processes (remove process slime-net-processes)) + (when (eq process slime-default-connection) + (setq slime-default-connection nil)) + (cond (debug + (set-process-sentinel process 'ignore) + (set-process-filter process 'ignore) + (delete-process process)) + (t + (run-hook-with-args 'slime-net-process-close-hooks process) + ;; killing the buffer also closes the socket + (kill-buffer (process-buffer process))))) + +(defun slime-net-sentinel (process message) + (message "Lisp connection closed unexpectedly: %s" message) + (slime-net-close process)) + +;;; Socket input is handled by `slime-net-filter', which decodes any +;;; complete messages and hands them off to the event dispatcher. + +(defun slime-net-filter (process string) + "Accept output from the socket and process all complete messages." + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string)) + (slime-process-available-input process)) + +(defun slime-process-available-input (process) + "Process all complete messages that have arrived from Lisp." + (with-current-buffer (process-buffer process) + (while (slime-net-have-input-p) + (let ((event (slime-net-read-or-lose process)) + (ok nil)) + (slime-log-event event) + (unwind-protect + (save-current-buffer + (slime-dispatch-event event process) + (setq ok t)) + (unless ok + (slime-run-when-idle 'slime-process-available-input process))))))) + +(defun slime-net-have-input-p () + "Return true if a complete message is available." + (goto-char (point-min)) + (and (>= (buffer-size) 6) + (>= (- (buffer-size) 6) (slime-net-decode-length)))) + +(defun slime-run-when-idle (function &rest args) + "Call FUNCTION as soon as Emacs is idle." + (apply #'run-at-time 0 nil function args)) + +(defun slime-handle-net-read-error (error) + (let ((packet (buffer-string))) + (slime-with-popup-buffer ((slime-buffer-name :error)) + (princ (format "%s\nin packet:\n%s" (error-message-string error) packet)) + (goto-char (point-min))) + (cond ((y-or-n-p "Skip this packet? ") + `(:emacs-skipped-packet ,packet)) + (t + (when (y-or-n-p "Enter debugger instead? ") + (debug 'error error)) + (signal (car error) (cdr error)))))) + +(defun slime-net-read-or-lose (process) + (condition-case error + (slime-net-read) + (error + (slime-net-close process t) + (error "net-read error: %S" error)))) + +(defun slime-net-read () + "Read a message from the network buffer." + (goto-char (point-min)) + (let* ((length (slime-net-decode-length)) + (start (+ (point) 6)) + (end (+ start length))) + (cl-assert (cl-plusp length)) + (prog1 (save-restriction + (narrow-to-region start end) + (condition-case error + (progn + (decode-coding-region start end 'utf-8-unix) + (setq end (point-max)) + (read (current-buffer))) + (error + (slime-handle-net-read-error error)))) + (delete-region (point-min) end)))) + +(defun slime-net-decode-length () + (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) + 16)) + +(defun slime-net-encode-length (n) + (format "%06x" n)) + +(defun slime-prin1-to-string (sexp) + "Like `prin1-to-string' but don't octal-escape non-ascii characters. +This is more compatible with the CL reader." + (let (print-escape-nonascii + print-escape-newlines + print-length + print-level) + (prin1-to-string sexp))) + + +;;;; Connections +;;; +;;; "Connections" are the high-level Emacs<->Lisp networking concept. +;;; +;;; Emacs has a connection to each Lisp process that it's interacting +;;; with. Typically there would only be one, but a user can choose to +;;; connect to many Lisps simultaneously. +;;; +;;; A connection consists of a control socket, optionally an extra +;;; socket dedicated to receiving Lisp output (an optimization), and a +;;; set of connection-local state variables. +;;; +;;; The state variables are stored as buffer-local variables in the +;;; control socket's process-buffer and are used via accessor +;;; functions. These variables include things like the *FEATURES* list +;;; and Unix Pid of the Lisp process. +;;; +;;; One connection is "current" at any given time. This is: +;;; `slime-dispatching-connection' if dynamically bound, or +;;; `slime-buffer-connection' if this is set buffer-local, or +;;; `slime-default-connection' otherwise. +;;; +;;; When you're invoking commands in your source files you'll be using +;;; `slime-default-connection'. This connection can be interactively +;;; reassigned via the connection-list buffer. +;;; +;;; When a command creates a new buffer it will set +;;; `slime-buffer-connection' so that commands in the new buffer will +;;; use the connection that the buffer originated from. For example, +;;; the apropos command creates the *Apropos* buffer and any command +;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the +;;; apropos search. REPL buffers are similarly tied to their +;;; respective connections. +;;; +;;; When Emacs is dispatching some network message that arrived from a +;;; connection it will dynamically bind `slime-dispatching-connection' +;;; so that the event will be processed in the context of that +;;; connection. +;;; +;;; This is mostly transparent. The user should be aware that he can +;;; set the default connection to pick which Lisp handles commands in +;;; Lisp-mode source buffers, and slime hackers should be aware that +;;; they can tie a buffer to a specific connection. The rest takes +;;; care of itself. + +(defvar slime-dispatching-connection nil + "Network process currently executing. +This is dynamically bound while handling messages from Lisp; it +overrides `slime-buffer-connection' and `slime-default-connection'.") + +(make-variable-buffer-local + (defvar slime-buffer-connection nil + "Network connection to use in the current buffer. +This overrides `slime-default-connection'.")) + +(defvar slime-default-connection nil + "Network connection to use by default. +Used for all Lisp communication, except when overridden by +`slime-dispatching-connection' or `slime-buffer-connection'.") + +(defun slime-current-connection () + "Return the connection to use for Lisp interaction. +Return nil if there's no connection." + (or slime-dispatching-connection + slime-buffer-connection + slime-default-connection)) + +(defun slime-connection () + "Return the connection to use for Lisp interaction. +Signal an error if there's no connection." + (let ((conn (slime-current-connection))) + (cond ((and (not conn) slime-net-processes) + (or (slime-auto-select-connection) + (error "No default connection selected."))) + ((not conn) + (or (slime-auto-start) + (error "Not connected."))) + ((not (eq (process-status conn) 'open)) + (error "Connection closed.")) + (t conn)))) + +(define-obsolete-variable-alias 'slime-auto-connect +'slime-auto-start "2.5") +(defcustom slime-auto-start 'never + "Controls auto connection when information from lisp process is needed. +This doesn't mean it will connect right after Slime is loaded." + :group 'slime-mode + :type '(choice (const never) + (const always) + (const ask))) + +(defun slime-auto-start () + (cond ((or (eq slime-auto-start 'always) + (and (eq slime-auto-start 'ask) + (y-or-n-p "No connection. Start Slime? "))) + (save-window-excursion + (slime) + (while (not (slime-current-connection)) + (sleep-for 1)) + (slime-connection))) + (t nil))) + +(defcustom slime-auto-select-connection 'ask + "Controls auto selection after the default connection was closed." + :group 'slime-mode + :type '(choice (const never) + (const always) + (const ask))) + +(defun slime-auto-select-connection () + (let* ((c0 (car slime-net-processes)) + (c (cond ((eq slime-auto-select-connection 'always) c0) + ((and (eq slime-auto-select-connection 'ask) + (y-or-n-p + (format "No default connection selected. %s %s? " + "Switch to" (slime-connection-name c0)))) + c0)))) + (when c + (slime-select-connection c) + (message "Switching to connection: %s" (slime-connection-name c)) + c))) + +(defun slime-select-connection (process) + "Make PROCESS the default connection." + (setq slime-default-connection process)) + +(defvar slime-cycle-connections-hook nil) + +(defun slime-cycle-connections-within (connections) + (let* ((tail (or (cdr (member (slime-current-connection) connections)) + connections)) ; loop around to the beginning + (next (car tail))) + (slime-select-connection next) + (run-hooks 'slime-cycle-connections-hook) + (message "Lisp: %s %s" + (slime-connection-name next) + (process-contact next)))) + +(defun slime-next-connection () + "Change current slime connection, cycling through all connections." + (interactive) + (slime-cycle-connections-within (reverse slime-net-processes))) + +(define-obsolete-function-alias 'slime-cycle-connections + 'slime-next-connection "2.13") + +(defun slime-prev-connection () + "Change current slime connection, cycling through all connections. +Goes in reverse order, relative to `slime-next-connection'." + (interactive) + (slime-cycle-connections-within slime-net-processes)) + +(cl-defmacro slime-with-connection-buffer ((&optional process) &rest body) + "Execute BODY in the process-buffer of PROCESS. +If PROCESS is not specified, `slime-connection' is used. + +\(fn (&optional PROCESS) &body BODY))" + (declare (indent 1)) + `(with-current-buffer + (process-buffer (or ,process (slime-connection) + (error "No connection"))) + ,@body)) + +;;; Connection-local variables: + +(defmacro slime-def-connection-var (varname &rest initial-value-and-doc) + "Define a connection-local variable. +The value of the variable can be read by calling the function of the +same name (it must not be accessed directly). The accessor function is +setf-able. + +The actual variable bindings are stored buffer-local in the +process-buffers of connections. The accessor function refers to +the binding for `slime-connection'." + (declare (indent 2)) + (let ((real-var (intern (format "%s:connlocal" varname)))) + `(progn + ;; Variable + (make-variable-buffer-local + (defvar ,real-var ,@initial-value-and-doc)) + ;; Accessor + (defun ,varname (&optional process) + (slime-with-connection-buffer (process) ,real-var)) + ;; Setf + (defsetf ,varname (&optional process) (store) + `(slime-with-connection-buffer (,process) + (setq (\, (quote (\, real-var))) (\, store)))) + '(\, varname)))) + +(slime-def-connection-var slime-connection-number nil + "Serial number of a connection. +Bound in the connection's process-buffer.") + +(slime-def-connection-var slime-lisp-features '() + "The symbol-names of Lisp's *FEATURES*. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-lisp-modules '() + "The strings of Lisp's *MODULES*.") + +(slime-def-connection-var slime-pid nil + "The process id of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-type nil + "The implementation type of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-version nil + "The implementation type of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-name nil + "The short name for the Lisp implementation.") + +(slime-def-connection-var slime-lisp-implementation-program nil + "The argv[0] of the process running the Lisp implementation.") + +(slime-def-connection-var slime-connection-name nil + "The short name for connection.") + +(slime-def-connection-var slime-inferior-process nil + "The inferior process for the connection if any.") + +(slime-def-connection-var slime-communication-style nil + "The communication style.") + +(slime-def-connection-var slime-machine-instance nil + "The name of the (remote) machine running the Lisp process.") + +(slime-def-connection-var slime-connection-coding-systems nil + "Coding systems supported by the Lisp process.") + +;;;;; Connection setup + +(defvar slime-connection-counter 0 + "The number of SLIME connections made. For generating serial numbers.") + +;;; Interface +(defun slime-setup-connection (process) + "Make a connection out of PROCESS." + (let ((slime-dispatching-connection process)) + (slime-init-connection-state process) + (slime-select-connection process) + process)) + +(defun slime-init-connection-state (proc) + "Initialize connection state in the process-buffer of PROC." + ;; To make life simpler for the user: if this is the only open + ;; connection then reset the connection counter. + (when (equal slime-net-processes (list proc)) + (setq slime-connection-counter 0)) + (slime-with-connection-buffer () + (setq slime-buffer-connection proc)) + (setf (slime-connection-number proc) (cl-incf slime-connection-counter)) + ;; We do the rest of our initialization asynchronously. The current + ;; function may be called from a timer, and if we setup the REPL + ;; from a timer then it mysteriously uses the wrong keymap for the + ;; first command. + (let ((slime-current-thread t)) + (slime-eval-async '(swank:connection-info) + (slime-curry #'slime-set-connection-info proc)))) + +(defun slime-set-connection-info (connection info) + "Initialize CONNECTION with INFO received from Lisp." + (let ((slime-dispatching-connection connection) + (slime-current-thread t)) + (cl-destructuring-bind (&key pid style lisp-implementation machine + features version modules encoding + &allow-other-keys) info + (slime-check-version version connection) + (setf (slime-pid) pid + (slime-communication-style) style + (slime-lisp-features) features + (slime-lisp-modules) modules) + (cl-destructuring-bind (&key type name version program) + lisp-implementation + (setf (slime-lisp-implementation-type) type + (slime-lisp-implementation-version) version + (slime-lisp-implementation-name) name + (slime-lisp-implementation-program) program + (slime-connection-name) (slime-generate-connection-name name))) + (cl-destructuring-bind (&key instance ((:type _)) ((:version _))) machine + (setf (slime-machine-instance) instance)) + (cl-destructuring-bind (&key coding-systems) encoding + (setf (slime-connection-coding-systems) coding-systems))) + (let ((args (let ((p (slime-inferior-process))) + (if p (slime-inferior-lisp-args p))))) + (let ((name (plist-get args ':name))) + (when name + (unless (string= (slime-lisp-implementation-name) name) + (setf (slime-connection-name) + (slime-generate-connection-name (symbol-name name)))))) + (slime-load-contribs) + (run-hooks 'slime-connected-hook) + (let ((fun (plist-get args ':init-function))) + (when fun (funcall fun)))) + (message "Connected. %s" (slime-random-words-of-encouragement)))) + +(defun slime-check-version (version conn) + (or (equal version slime-protocol-version) + (equal slime-protocol-version 'ignore) + (y-or-n-p + (format "Versions differ: %s (slime) vs. %s (swank). Continue? " + slime-protocol-version version)) + (slime-net-close conn) + (top-level))) + +(defun slime-generate-connection-name (lisp-name) + (cl-loop for i from 1 + for name = lisp-name then (format "%s<%d>" lisp-name i) + while (cl-find name slime-net-processes + :key #'slime-connection-name :test #'equal) + finally (cl-return name))) + +(defun slime-connection-close-hook (process) + (when (eq process slime-default-connection) + (when slime-net-processes + (slime-select-connection (car slime-net-processes)) + (message "Default connection closed; switched to #%S (%S)" + (slime-connection-number) + (slime-connection-name))))) + +(add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook) + +;;;;; Commands on connections + +(defun slime-disconnect () + "Close the current connection." + (interactive) + (slime-net-close (slime-connection))) + +(defun slime-disconnect-all () + "Disconnect all connections." + (interactive) + (mapc #'slime-net-close slime-net-processes)) + +(defun slime-connection-port (connection) + "Return the remote port number of CONNECTION." + (cadr (process-contact connection))) + +(defun slime-process (&optional connection) + "Return the Lisp process for CONNECTION (default `slime-connection'). +Return nil if there's no process object for the connection." + (let ((proc (slime-inferior-process connection))) + (if (and proc + (memq (process-status proc) '(run stop))) + proc))) + +;; Non-macro version to keep the file byte-compilable. +(defun slime-set-inferior-process (connection process) + (setf (slime-inferior-process connection) process)) + +(defun slime-use-sigint-for-interrupt (&optional connection) + (let ((c (or connection (slime-connection)))) + (cl-ecase (slime-communication-style c) + ((:fd-handler nil) t) + ((:spawn :sigio) nil)))) + +(defvar slime-inhibit-pipelining t + "*If true, don't send background requests if Lisp is already busy.") + +(defun slime-background-activities-enabled-p () + (and (let ((con (slime-current-connection))) + (and con + (eq (process-status con) 'open))) + (or (not (slime-busy-p)) + (not slime-inhibit-pipelining)))) + + +;;;; Communication protocol + +;;;;; Emacs Lisp programming interface +;;; +;;; The programming interface for writing Emacs commands is based on +;;; remote procedure calls (RPCs). The basic operation is to ask Lisp +;;; to apply a named Lisp function to some arguments, then to do +;;; something with the result. +;;; +;;; Requests can be either synchronous (blocking) or asynchronous +;;; (with the result passed to a callback/continuation function). If +;;; an error occurs during the request then the debugger is entered +;;; before the result arrives -- for synchronous evaluations this +;;; requires a recursive edit. +;;; +;;; You should use asynchronous evaluations (`slime-eval-async') for +;;; most things. Reserve synchronous evaluations (`slime-eval') for +;;; the cases where blocking Emacs is really appropriate (like +;;; completion) and that shouldn't trigger errors (e.g. not evaluate +;;; user-entered code). +;;; +;;; We have the concept of the "current Lisp package". RPC requests +;;; always say what package the user is making them from and the Lisp +;;; side binds that package to *BUFFER-PACKAGE* to use as it sees +;;; fit. The current package is defined as the buffer-local value of +;;; `slime-buffer-package' if set, and otherwise the package named by +;;; the nearest IN-PACKAGE as found by text search (cl-first backwards, +;;; then forwards). +;;; +;;; Similarly we have the concept of the current thread, i.e. which +;;; thread in the Lisp process should handle the request. The current +;;; thread is determined solely by the buffer-local value of +;;; `slime-current-thread'. This is usually bound to t meaning "no +;;; particular thread", but can also be used to nominate a specific +;;; thread. The REPL and the debugger both use this feature to deal +;;; with specific threads. + +(make-variable-buffer-local + (defvar slime-current-thread t + "The id of the current thread on the Lisp side. +t means the \"current\" thread; +:repl-thread the thread that executes REPL requests; +fixnum a specific thread.")) + +(make-variable-buffer-local + (defvar slime-buffer-package nil + "The Lisp package associated with the current buffer. +This is set only in buffers bound to specific packages.")) + +;;; `slime-rex' is the RPC primitive which is used to implement both +;;; `slime-eval' and `slime-eval-async'. You can use it directly if +;;; you need to, but the others are usually more convenient. + +(cl-defmacro slime-rex ((&rest saved-vars) + (sexp &optional + (package '(slime-current-package)) + (thread 'slime-current-thread)) + &rest continuations) + "(slime-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) + +Remote EXecute SEXP. + +VARs are a list of saved variables visible in the other forms. Each +VAR is either a symbol or a list (VAR INIT-VALUE). + +SEXP is evaluated and the princed version is sent to Lisp. + +PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package. +The default value is (slime-current-package). + +CLAUSES is a list of patterns with same syntax as +`slime-dcase'. The result of the evaluation of SEXP is +dispatched on CLAUSES. The result is either a sexp of the +form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed +asynchronously. + +Note: don't use backquote syntax for SEXP, because various Emacs +versions cannot deal with that." + (declare (indent 2)) + (let ((result (cl-gensym))) + `(lexical-let ,(cl-loop for var in saved-vars + collect (cl-etypecase var + (symbol (list var var)) + (cons var))) + (slime-dispatch-event + (list :emacs-rex ,sexp ,package ,thread + (lambda (,result) + (slime-dcase ,result + ,@continuations))))))) + +;;; Interface +(defun slime-current-package () + "Return the Common Lisp package in the current context. +If `slime-buffer-package' has a value then return that, otherwise +search for and read an `in-package' form." + (or slime-buffer-package + (save-restriction + (widen) + (slime-find-buffer-package)))) + +(defvar slime-find-buffer-package-function 'slime-search-buffer-package + "*Function to use for `slime-find-buffer-package'. +The result should be the package-name (a string) +or nil if nothing suitable can be found.") + +(defun slime-find-buffer-package () + "Figure out which Lisp package the current buffer is associated with." + (funcall slime-find-buffer-package-function)) + +(make-variable-buffer-local + (defvar slime-package-cache nil + "Cons of the form (buffer-modified-tick . package)")) + +;; When modifing this code consider cases like: +;; (in-package #.*foo*) +;; (in-package #:cl) +;; (in-package :cl) +;; (in-package "CL") +;; (in-package |CL|) +;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp) + +(defun slime-search-buffer-package () + (let ((case-fold-search t) + (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*" + "\\([^)]+\\)[ \t]*)"))) + (save-excursion + (when (or (re-search-backward regexp nil t) + (re-search-forward regexp nil t)) + (match-string-no-properties 2))))) + +;;; Synchronous requests are implemented in terms of asynchronous +;;; ones. We make an asynchronous request with a continuation function +;;; that `throw's its result up to a `catch' and then enter a loop of +;;; handling I/O until that happens. + +(defvar slime-stack-eval-tags nil + "List of stack-tags of continuations waiting on the stack.") + +(defun slime-eval (sexp &optional package) + "Evaluate EXPR on the superior Lisp and return the result." + (when (null package) (setq package (slime-current-package))) + (let* ((tag (cl-gensym (format "slime-result-%d-" + (1+ (slime-continuation-counter))))) + (slime-stack-eval-tags (cons tag slime-stack-eval-tags))) + (apply + #'funcall + (catch tag + (slime-rex (tag sexp) + (sexp package) + ((:ok value) + (unless (member tag slime-stack-eval-tags) + (error "Reply to canceled synchronous eval request tag=%S sexp=%S" + tag sexp)) + (throw tag (list #'identity value))) + ((:abort _condition) + (throw tag (list #'error "Synchronous Lisp Evaluation aborted")))) + (let ((debug-on-quit t) + (inhibit-quit nil) + (conn (slime-connection))) + (while t + (unless (eq (process-status conn) 'open) + (error "Lisp connection closed unexpectedly")) + (accept-process-output nil 0.01))))))) + +(defun slime-eval-async (sexp &optional cont package) + "Evaluate EXPR on the superior Lisp and call CONT with the result." + (declare (indent 1)) + (slime-rex (cont (buffer (current-buffer))) + (sexp (or package (slime-current-package))) + ((:ok result) + (when cont + (set-buffer buffer) + (funcall cont result))) + ((:abort condition) + (message "Evaluation aborted on %s." condition))) + ;; Guard against arbitrary return values which once upon a time + ;; showed up in the minibuffer spuriously (due to a bug in + ;; slime-autodoc.) If this ever happens again, returning the + ;; following will make debugging much easier: + :slime-eval-async) + +;;; These functions can be handy too: + +(defun slime-connected-p () + "Return true if the Swank connection is open." + (not (null slime-net-processes))) + +(defun slime-check-connected () + "Signal an error if we are not connected to Lisp." + (unless (slime-connected-p) + (error "Not connected. Use `%s' to start a Lisp." + (substitute-command-keys "\\[slime]")))) + +;; UNUSED +(defun slime-debugged-connection-p (conn) + ;; This previously was (AND (SLDB-DEBUGGED-CONTINUATIONS CONN) T), + ;; but an SLDB buffer may exist without having continuations + ;; attached to it, e.g. the one resulting from `slime-interrupt'. + (cl-loop for b in (sldb-buffers) + thereis (with-current-buffer b + (eq slime-buffer-connection conn)))) + +(defun slime-busy-p (&optional conn) + "True if Lisp has outstanding requests. +Debugged requests are ignored." + (let ((debugged (sldb-debugged-continuations (or conn (slime-connection))))) + (cl-remove-if (lambda (id) + (memq id debugged)) + (slime-rex-continuations) + :key #'car))) + +(defun slime-sync () + "Block until the most recent request has finished." + (when (slime-rex-continuations) + (let ((tag (caar (slime-rex-continuations)))) + (while (cl-find tag (slime-rex-continuations) :key #'car) + (accept-process-output nil 0.1))))) + +(defun slime-ping () + "Check that communication works." + (interactive) + (message "%s" (slime-eval "PONG"))) + +;;;;; Protocol event handler (cl-the guts) +;;; +;;; This is the protocol in all its glory. The input to this function +;;; is a protocol event that either originates within Emacs or arrived +;;; over the network from Lisp. +;;; +;;; Each event is a list beginning with a keyword and followed by +;;; arguments. The keyword identifies the type of event. Events +;;; originating from Emacs have names starting with :emacs- and events +;;; from Lisp don't. + +(slime-def-connection-var slime-rex-continuations '() + "List of (ID . FUNCTION) continuations waiting for RPC results.") + +(slime-def-connection-var slime-continuation-counter 0 + "Continuation serial number counter.") + +(defvar slime-event-hooks) + +(defun slime-dispatch-event (event &optional process) + (let ((slime-dispatching-connection (or process (slime-connection)))) + (or (run-hook-with-args-until-success 'slime-event-hooks event) + (slime-dcase event + ((:emacs-rex form package thread continuation) + (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) + (slime-display-oneliner "; pipelined request... %S" form)) + (let ((id (cl-incf (slime-continuation-counter)))) + (slime-send `(:emacs-rex ,form ,package ,thread ,id)) + (push (cons id continuation) (slime-rex-continuations)) + (slime--recompute-modelines))) + ((:return value id) + (let ((rec (assq id (slime-rex-continuations)))) + (cond (rec (setf (slime-rex-continuations) + (remove rec (slime-rex-continuations))) + (slime--recompute-modelines) + (funcall (cdr rec) value)) + (t + (error "Unexpected reply: %S %S" id value))))) + ((:debug-activate thread level &optional select) + (cl-assert thread) + (sldb-activate thread level select)) + ((:debug thread level condition restarts frames conts) + (cl-assert thread) + (sldb-setup thread level condition restarts frames conts)) + ((:debug-return thread level stepping) + (cl-assert thread) + (sldb-exit thread level stepping)) + ((:emacs-interrupt thread) + (slime-send `(:emacs-interrupt ,thread))) + ((:channel-send id msg) + (slime-channel-send (or (slime-find-channel id) + (error "Invalid channel id: %S %S" id msg)) + msg)) + ((:emacs-channel-send id msg) + (slime-send `(:emacs-channel-send ,id ,msg))) + ((:read-from-minibuffer thread tag prompt initial-value) + (slime-read-from-minibuffer-for-swank thread tag prompt + initial-value)) + ((:y-or-n-p thread tag question) + (slime-y-or-n-p thread tag question)) + ((:emacs-return-string thread tag string) + (slime-send `(:emacs-return-string ,thread ,tag ,string))) + ((:new-features features) + (setf (slime-lisp-features) features)) + ((:indentation-update info) + (slime-handle-indentation-update info)) + ((:eval-no-wait form) + (slime-check-eval-in-emacs-enabled) + (eval (read form))) + ((:eval thread tag form-string) + (slime-check-eval-in-emacs-enabled) + (slime-eval-for-lisp thread tag form-string)) + ((:ed-rpc-no-wait fn-name &rest args) + (let ((fn (intern-soft fn-name))) + (slime-check-rpc-allowed fn) + (apply fn args))) + ((:ed-rpc thread tag fn-name &rest args) + (slime-rpc-from-lisp thread tag (intern-soft fn-name) args)) + ((:emacs-return thread tag value) + (slime-send `(:emacs-return ,thread ,tag ,value))) + ((:ed what) + (slime-ed what)) + ((:inspect what thread tag) + (let ((hook (when (and thread tag) + (slime-curry #'slime-send + `(:emacs-return ,thread ,tag nil))))) + (slime-open-inspector what nil hook))) + ((:background-message message) + (slime-background-message "%s" message)) + ((:debug-condition thread message) + (cl-assert thread) + (message "%s" message)) + ((:ping thread tag) + (slime-send `(:emacs-pong ,thread ,tag))) + ((:reader-error packet condition) + (slime-with-popup-buffer ((slime-buffer-name :error)) + (princ (format "Invalid protocol message:\n%s\n\n%s" + condition packet)) + (goto-char (point-min))) + (error "Invalid protocol message")) + ((:invalid-rpc id message) + (setf (slime-rex-continuations) + (cl-remove id (slime-rex-continuations) :key #'car)) + (error "Invalid rpc: %s" message)) + ((:emacs-skipped-packet _pkg)) + ((:test-delay seconds) ; for testing only + (sit-for seconds)))))) + +(defun slime-send (sexp) + "Send SEXP directly over the wire on the current connection." + (slime-net-send sexp (slime-connection))) + +(defun slime-reset () + "Clear all pending continuations and erase connection buffer." + (interactive) + (setf (slime-rex-continuations) '()) + (mapc #'kill-buffer (sldb-buffers)) + (slime-with-connection-buffer () + (erase-buffer))) + +(defun slime-send-sigint () + (interactive) + (signal-process (slime-pid) 'SIGINT)) + +;;;;; Channels + +;;; A channel implements a set of operations. Those operations can be +;;; invoked by sending messages to the channel. Channels are used for +;;; protocols which can't be expressed naturally with RPCs, e.g. for +;;; streaming data over the wire. +;;; +;;; A channel can be "remote" or "local". Remote channels are +;;; represented by integers. Local channels are structures. Messages +;;; sent to a closed (remote) channel are ignored. + +(slime-def-connection-var slime-channels '() + "Alist of the form (ID . CHANNEL).") + +(slime-def-connection-var slime-channels-counter 0 + "Channel serial number counter.") + +(cl-defstruct (slime-channel (:conc-name slime-channel.) + (:constructor + slime-make-channel% (operations name id plist))) + operations name id plist) + +(defun slime-make-channel (operations &optional name) + (let* ((id (cl-incf (slime-channels-counter))) + (ch (slime-make-channel% operations name id nil))) + (push (cons id ch) (slime-channels)) + ch)) + +(defun slime-close-channel (channel) + (setf (slime-channel.operations channel) 'closed-channel) + (let ((probe (assq (slime-channel.id channel) (slime-channels)))) + (cond (probe (setf (slime-channels) (delete probe (slime-channels)))) + (t (error "Invalid channel: %s" channel))))) + +(defun slime-find-channel (id) + (cdr (assq id (slime-channels)))) + +(defun slime-channel-send (channel message) + (apply (or (gethash (car message) (slime-channel.operations channel)) + (error "Unsupported operation: %S %S" message channel)) + channel (cdr message))) + +(defun slime-channel-put (channel prop value) + (setf (slime-channel.plist channel) + (plist-put (slime-channel.plist channel) prop value))) + +(defun slime-channel-get (channel prop) + (plist-get (slime-channel.plist channel) prop)) + +(eval-and-compile + (defun slime-channel-method-table-name (type) + (intern (format "slime-%s-channel-methods" type)))) + +(defmacro slime-define-channel-type (name) + (declare (indent defun)) + (let ((tab (slime-channel-method-table-name name))) + `(progn + (defvar ,tab) + (setq ,tab (make-hash-table :size 10))))) + +(defmacro slime-define-channel-method (type method args &rest body) + (declare (indent 3) (debug (&define name sexp lambda-list + def-body))) + `(puthash ',method + (lambda (self . ,args) . ,body) + ,(slime-channel-method-table-name type))) + +(defun slime-send-to-remote-channel (channel-id msg) + (slime-dispatch-event `(:emacs-channel-send ,channel-id ,msg))) + +;;;;; Event logging to *slime-events* +;;; +;;; The *slime-events* buffer logs all protocol messages for debugging +;;; purposes. Optionally you can enable outline-mode in that buffer, +;;; which is convenient but slows things down significantly. + +(defvar slime-log-events t + "*Log protocol events to the *slime-events* buffer.") + +(defvar slime-outline-mode-in-events-buffer nil + "*Non-nil means use outline-mode in *slime-events*.") + +(defvar slime-event-buffer-name (slime-buffer-name :events) + "The name of the slime event buffer.") + +(defun slime-log-event (event) + "Record the fact that EVENT occurred." + (when slime-log-events + (with-current-buffer (slime-events-buffer) + ;; trim? + (when (> (buffer-size) 100000) + (goto-char (/ (buffer-size) 2)) + (re-search-forward "^(" nil t) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (save-excursion + (slime-pprint-event event (current-buffer))) + (when (and (boundp 'outline-minor-mode) + outline-minor-mode) + (hide-entry)) + (goto-char (point-max))))) + +(defun slime-pprint-event (event buffer) + "Pretty print EVENT in BUFFER with limited depth and width." + (let ((print-length 20) + (print-level 6) + (pp-escape-newlines t)) + (pp event buffer))) + +(defun slime-events-buffer () + "Return or create the event log buffer." + (or (get-buffer slime-event-buffer-name) + (let ((buffer (get-buffer-create slime-event-buffer-name))) + (with-current-buffer buffer + (buffer-disable-undo) + (set (make-local-variable 'outline-regexp) "^(") + (set (make-local-variable 'comment-start) ";") + (set (make-local-variable 'comment-end) "") + (when slime-outline-mode-in-events-buffer + (outline-minor-mode))) + buffer))) + + +;;;;; Cleanup after a quit + +(defun slime-restart-inferior-lisp () + "Kill and restart the Lisp subprocess." + (interactive) + (cl-assert (slime-inferior-process) () "No inferior lisp process") + (slime-quit-lisp-internal (slime-connection) 'slime-restart-sentinel t)) + +(defun slime-restart-sentinel (process _message) + "Restart the inferior lisp process. +Also rearrange windows." + (cl-assert (process-status process) 'closed) + (let* ((proc (slime-inferior-process process)) + (args (slime-inferior-lisp-args proc)) + (buffer (buffer-name (process-buffer proc))) + ;;(buffer-window (get-buffer-window buffer)) + (new-proc (slime-start-lisp (plist-get args :program) + (plist-get args :program-args) + (plist-get args :env) + nil + buffer))) + (slime-net-close process) + (slime-inferior-connect new-proc args) + (switch-to-buffer buffer) + (goto-char (point-max)))) + + +;;;; Compilation and the creation of compiler-note annotations + +(defvar slime-highlight-compiler-notes t + "*When non-nil annotate buffers with compilation notes etc.") + +(defvar slime-before-compile-functions nil + "A list of function called before compiling a buffer or region. +The function receive two arguments: the beginning and the end of the +region that will be compiled.") + +;; FIXME: remove some of the options +(defcustom slime-compilation-finished-hook 'slime-maybe-show-compilation-log + "Hook called with a list of compiler notes after a compilation." + :group 'slime-mode + :type 'hook + :options '(slime-maybe-show-compilation-log + slime-create-compilation-log + slime-show-compilation-log + slime-maybe-list-compiler-notes + slime-list-compiler-notes + slime-maybe-show-xrefs-for-notes + slime-goto-first-note)) + +;; FIXME: I doubt that anybody uses this directly and it seems to be +;; only an ugly way to pass arguments. +(defvar slime-compilation-policy nil + "When non-nil compile with these optimization settings.") + +(defun slime-compute-policy (arg) + "Return the policy for the prefix argument ARG." + (let ((between (lambda (min n max) + (cond ((< n min) min) + ((> n max) max) + (t n))))) + (let ((n (prefix-numeric-value arg))) + (cond ((not arg) slime-compilation-policy) + ((cl-plusp n) `((cl:debug . ,(funcall between 0 n 3)))) + ((eq arg '-) `((cl:speed . 3))) + (t `((cl:speed . ,(funcall between 0 (abs n) 3)))))))) + +(cl-defstruct (slime-compilation-result + (:type list) + (:conc-name slime-compilation-result.) + (:constructor nil) + (:copier nil)) + tag notes successp duration loadp faslfile) + +(defvar slime-last-compilation-result nil + "The result of the most recently issued compilation.") + +(defun slime-compiler-notes () + "Return all compiler notes, warnings, and errors." + (slime-compilation-result.notes slime-last-compilation-result)) + +(defun slime-compile-and-load-file (&optional policy) + "Compile and load the buffer's file and highlight compiler notes. + +With (positive) prefix argument the file is compiled with maximal +debug settings (`C-u'). With negative prefix argument it is compiled for +speed (`M--'). If a numeric argument is passed set debug or speed settings +to it depending on its sign. + +Each source location that is the subject of a compiler note is +underlined and annotated with the relevant information. The commands +`slime-next-note' and `slime-previous-note' can be used to navigate +between compiler notes and to display their full details." + (interactive "P") + (slime-compile-file t (slime-compute-policy policy))) + +(defcustom slime-compile-file-options '() + "Plist of additional options that C-c C-k should pass to Lisp. +Currently only :fasl-directory is supported." + :group 'slime-lisp + :type '(plist :key-type symbol :value-type (file :must-match t))) + +(defun slime-compile-file (&optional load policy) + "Compile current buffer's file and highlight resulting compiler notes. + +See `slime-compile-and-load-file' for further details." + (interactive) + (unless buffer-file-name + (error "Buffer %s is not associated with a file." (buffer-name))) + (check-parens) + (slime--maybe-save-buffer) + (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max)) + (let ((file (slime-to-lisp-filename (buffer-file-name))) + (options (slime-simplify-plist `(,@slime-compile-file-options + :policy ,policy)))) + (slime-eval-async + `(swank:compile-file-for-emacs ,file ,(if load t nil) + . ,(slime-hack-quotes options)) + #'slime-compilation-finished) + (message "Compiling %s..." file))) + +;; FIXME: compilation-save-buffers-predicate was introduced in 24.1 +(defun slime--maybe-save-buffer () + (let ((slime--this-buffer (current-buffer))) + (save-some-buffers (not compilation-ask-about-save) + (lambda () (eq (current-buffer) slime--this-buffer))))) + +(defun slime-hack-quotes (arglist) + ;; eval is the wrong primitive, we really want funcall + (cl-loop for arg in arglist collect `(quote ,arg))) + +(defun slime-simplify-plist (plist) + (cl-loop for (key val) on plist by #'cddr + append (cond ((null val) '()) + (t (list key val))))) + +(defun slime-compile-defun (&optional raw-prefix-arg) + "Compile the current toplevel form. + +With (positive) prefix argument the form is compiled with maximal +debug settings (`C-u'). With negative prefix argument it is compiled for +speed (`M--'). If a numeric argument is passed set debug or speed settings +to it depending on its sign." + (interactive "P") + (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) + (if (use-region-p) + (slime-compile-region (region-beginning) (region-end)) + (apply #'slime-compile-region (slime-region-for-defun-at-point))))) + +(defun slime-compile-region (start end) + "Compile the region." + (interactive "r") + ;; Check connection before running hooks things like + ;; slime-flash-region don't make much sense if there's no connection + (slime-connection) + (slime-flash-region start end) + (run-hook-with-args 'slime-before-compile-functions start end) + (slime-compile-string (buffer-substring-no-properties start end) start)) + +(defun slime-flash-region (start end &optional timeout) + "Temporarily highlight region from START to END." + (let ((overlay (make-overlay start end))) + (overlay-put overlay 'face 'secondary-selection) + (run-with-timer (or timeout 0.2) nil 'delete-overlay overlay))) + +(defun slime-compile-string (string start-offset) + (let* ((line (save-excursion + (goto-char start-offset) + (list (line-number-at-pos) (1+ (current-column))))) + (position `((:position ,start-offset) (:line ,@line)))) + (slime-eval-async + `(swank:compile-string-for-emacs + ,string + ,(buffer-name) + ',position + ,(if (buffer-file-name) (slime-to-lisp-filename (buffer-file-name))) + ',slime-compilation-policy) + #'slime-compilation-finished))) + +(defcustom slime-load-failed-fasl 'ask + "Which action to take when COMPILE-FILE set FAILURE-P to T. +NEVER doesn't load the fasl +ALWAYS loads the fasl +ASK asks the user." + :type '(choice (const never) + (const always) + (const ask))) + +(defun slime-load-failed-fasl-p () + (cl-ecase slime-load-failed-fasl + (never nil) + (always t) + (ask (y-or-n-p "Compilation failed. Load fasl file anyway? ")))) + +(defun slime-compilation-finished (result) + (with-struct (slime-compilation-result. notes duration successp + loadp faslfile) result + (setf slime-last-compilation-result result) + (slime-show-note-counts notes duration (cond ((not loadp) successp) + (t (and faslfile successp)))) + (when slime-highlight-compiler-notes + (slime-highlight-notes notes)) + (run-hook-with-args 'slime-compilation-finished-hook notes) + (when (and loadp faslfile + (or successp + (slime-load-failed-fasl-p))) + (slime-eval-async `(swank:load-file ,faslfile))))) + +(defun slime-show-note-counts (notes secs successp) + (message (concat + (cond (successp "Compilation finished") + (t (slime-add-face 'font-lock-warning-face + "Compilation failed"))) + (if (null notes) ". (No warnings)" ": ") + (mapconcat + (lambda (messages) + (cl-destructuring-bind (sev . notes) messages + (let ((len (length notes))) + (format "%d %s%s" len (slime-severity-label sev) + (if (= len 1) "" "s"))))) + (sort (slime-alistify notes #'slime-note.severity #'eq) + (lambda (x y) (slime-severity< (car y) (car x)))) + " ") + (if secs (format " [%.2f secs]" secs))))) + +(defun slime-highlight-notes (notes) + "Highlight compiler notes, warnings, and errors in the buffer." + (interactive (list (slime-compiler-notes))) + (with-temp-message "Highlighting notes..." + (save-excursion + (save-restriction + (widen) ; highlight notes on the whole buffer + (slime-remove-old-overlays) + (mapc #'slime-overlay-note (slime-merge-notes-for-display notes)))))) + +(defvar slime-note-overlays '() + "List of overlays created by `slime-make-note-overlay'") + +(defun slime-remove-old-overlays () + "Delete the existing note overlays." + (mapc #'delete-overlay slime-note-overlays) + (setq slime-note-overlays '())) + +(defun slime-filter-buffers (predicate) + "Return a list of where PREDICATE returns true. +PREDICATE is executed in the buffer to test." + (cl-remove-if-not (lambda (%buffer) + (with-current-buffer %buffer + (funcall predicate))) + (buffer-list))) + +;;;;; Recompilation. + +;; FIXME: This whole idea is questionable since it depends so +;; crucially on precise source-locs. + +(defun slime-recompile-location (location) + (save-excursion + (slime-goto-source-location location) + (slime-compile-defun))) + +(defun slime-recompile-locations (locations cont) + (slime-eval-async + `(swank:compile-multiple-strings-for-emacs + ',(cl-loop for loc in locations collect + (save-excursion + (slime-goto-source-location loc) + (cl-destructuring-bind (start end) + (slime-region-for-defun-at-point) + (list (buffer-substring-no-properties start end) + (buffer-name) + (slime-current-package) + start + (if (buffer-file-name) + (slime-to-lisp-filename (buffer-file-name)) + nil))))) + ',slime-compilation-policy) + cont)) + + +;;;;; Merging together compiler notes in the same location. + +(defun slime-merge-notes-for-display (notes) + "Merge together notes that refer to the same location. +This operation is \"lossy\" in the broad sense but not for display purposes." + (mapcar #'slime-merge-notes + (slime-group-similar 'slime-notes-in-same-location-p notes))) + +(defun slime-merge-notes (notes) + "Merge NOTES together. Keep the highest severity, concatenate the messages." + (let* ((new-severity (cl-reduce #'slime-most-severe notes + :key #'slime-note.severity)) + (new-message (mapconcat #'slime-note.message notes "\n"))) + (let ((new-note (cl-copy-list (car notes)))) + (setf (cl-getf new-note :message) new-message) + (setf (cl-getf new-note :severity) new-severity) + new-note))) + +(defun slime-notes-in-same-location-p (a b) + (equal (slime-note.location a) (slime-note.location b))) + + +;;;;; Compiler notes list + +(defun slime-one-line-ify (string) + "Return a single-line version of STRING. +Each newlines and following indentation is replaced by a single space." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "\n[\n \t]*" nil t) + (replace-match " ")) + (buffer-string))) + +(defun slime-xrefs-for-notes (notes) + (let ((xrefs)) + (dolist (note notes) + (let* ((location (cl-getf note :location)) + (fn (cadr (assq :file (cdr location)))) + (file (assoc fn xrefs)) + (node + (list (format "%s: %s" + (cl-getf note :severity) + (slime-one-line-ify (cl-getf note :message))) + location))) + (when fn + (if file + (push node (cdr file)) + (setf xrefs (cl-acons fn (list node) xrefs)))))) + xrefs)) + +(defun slime-maybe-show-xrefs-for-notes (notes) + "Show the compiler notes NOTES if they come from more than one file." + (let ((xrefs (slime-xrefs-for-notes notes))) + (when (slime-length> xrefs 1) ; >1 file + (slime-show-xrefs + xrefs 'definition "Compiler notes" (slime-current-package))))) + +(defun slime-note-has-location-p (note) + (not (eq ':error (car (slime-note.location note))))) + +(defun slime-redefinition-note-p (note) + (eq (slime-note.severity note) :redefinition)) + +(defun slime-create-compilation-log (notes) + "Create a buffer for `next-error' to use." + (with-current-buffer (get-buffer-create (slime-buffer-name :compilation)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (slime-insert-compilation-log notes) + (compilation-mode))) + +(defun slime-maybe-show-compilation-log (notes) + "Display the log on failed compilations or if NOTES is non-nil." + (slime-create-compilation-log notes) + (with-struct (slime-compilation-result. notes duration successp) + slime-last-compilation-result + (unless successp + (with-current-buffer (slime-buffer-name :compilation) + (let ((inhibit-read-only t)) + (goto-char (point-max)) + (insert "Compilation " (if successp "succeeded." "failed.")) + (goto-char (point-min)) + (display-buffer (current-buffer))))))) + +(defun slime-show-compilation-log (notes) + "Create and display the compilation log buffer." + (interactive (list (slime-compiler-notes))) + (slime-with-popup-buffer ((slime-buffer-name :compilation) + :mode 'compilation-mode) + (slime-insert-compilation-log notes))) + +(defun slime-insert-compilation-log (notes) + "Insert NOTES in format suitable for `compilation-mode'." + (cl-destructuring-bind (grouped-notes canonicalized-locs-table) + (slime-group-and-sort-notes notes) + (with-temp-message "Preparing compilation log..." + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) ; inefficient font-lock-hook + (insert (format "cd %s\n%d compiler notes:\n\n" + default-directory (length notes))) + (dolist (notes grouped-notes) + (let ((loc (gethash (cl-first notes) canonicalized-locs-table)) + (start (point))) + (insert (slime-canonicalized-location-to-string loc) ":") + (slime-insert-note-group notes) + (insert "\n") + (slime-make-note-overlay (cl-first notes) start (1- (point)))))) + (set (make-local-variable 'compilation-skip-threshold) 0) + (setq next-error-last-buffer (current-buffer))))) + +(defun slime-insert-note-group (notes) + "Insert a group of compiler messages." + (insert "\n") + (dolist (note notes) + (insert " " (slime-severity-label (slime-note.severity note)) ": ") + (let ((start (point))) + (insert (slime-note.message note)) + (let ((ctx (slime-note.source-context note))) + (if ctx (insert "\n" ctx))) + (slime-indent-block start 4)) + (insert "\n"))) + +(defun slime-indent-block (start column) + "If the region back to START isn't a one-liner indent it." + (when (< start (line-beginning-position)) + (save-excursion + (goto-char start) + (insert "\n")) + (slime-indent-rigidly start (point) column))) + +(defun slime-canonicalized-location (location) + "Return a list (FILE LINE COLUMN) for slime-location LOCATION. +This is quite an expensive operation so use carefully." + (save-excursion + (slime-goto-location-buffer (slime-location.buffer location)) + (save-excursion + (slime-goto-source-location location) + (list (or (buffer-file-name) (buffer-name)) + (save-restriction + (widen) + (line-number-at-pos)) + (1+ (current-column)))))) + +(defun slime-canonicalized-location-to-string (loc) + (if loc + (cl-destructuring-bind (filename line col) loc + (format "%s:%d:%d" + (cond ((not filename) "") + ((let ((rel (file-relative-name filename))) + (if (< (length rel) (length filename)) + rel))) + (t filename)) + line col)) + (format "Unknown location"))) + +(defun slime-goto-note-in-compilation-log (note) + "Find `note' in the compilation log and display it." + (with-current-buffer (get-buffer (slime-buffer-name :compilation)) + (let ((pos + (save-excursion + (goto-char (point-min)) + (cl-loop for overlay = (slime-find-next-note) + while overlay + for other-note = (overlay-get overlay 'slime-note) + when (slime-notes-in-same-location-p note other-note) + return (overlay-start overlay))))) + (when pos + (slime--display-position pos nil 0))))) + +(defun slime-group-and-sort-notes (notes) + "First sort, then group NOTES according to their canonicalized locs." + (let ((locs (make-hash-table :test #'eq))) + (mapc (lambda (note) + (let ((loc (slime-note.location note))) + (when (slime-location-p loc) + (puthash note (slime-canonicalized-location loc) locs)))) + notes) + (list (slime-group-similar + (lambda (n1 n2) + (equal (gethash n1 locs nil) (gethash n2 locs t))) + (let* ((bottom most-negative-fixnum) + (+default+ (list "" bottom bottom))) + (sort notes + (lambda (n1 n2) + (cl-destructuring-bind ((filename1 line1 col1) + (filename2 line2 col2)) + (list (gethash n1 locs +default+) + (gethash n2 locs +default+)) + (cond ((string-lessp filename1 filename2) t) + ((string-lessp filename2 filename1) nil) + ((< line1 line2) t) + ((> line1 line2) nil) + (t (< col1 col2)))))))) + locs))) + +(defun slime-note.severity (note) + (plist-get note :severity)) + +(defun slime-note.message (note) + (plist-get note :message)) + +(defun slime-note.source-context (note) + (plist-get note :source-context)) + +(defun slime-note.location (note) + (plist-get note :location)) + +(defun slime-severity-label (severity) + (cl-subseq (symbol-name severity) 1)) + + +;;;;; Adding a single compiler note + +(defun slime-overlay-note (note) + "Add a compiler note to the buffer as an overlay. +If an appropriate overlay for a compiler note in the same location +already exists then the new information is merged into it. Otherwise a +new overlay is created." + (cl-multiple-value-bind (start end) (slime-choose-overlay-region note) + (when start + (goto-char start) + (let ((severity (plist-get note :severity)) + (message (plist-get note :message)) + (overlay (slime-note-at-point))) + (if overlay + (slime-merge-note-into-overlay overlay severity message) + (slime-create-note-overlay note start end severity message)))))) + +(defun slime-make-note-overlay (note start end) + (let ((overlay (make-overlay start end))) + (overlay-put overlay 'slime-note note) + (push overlay slime-note-overlays) + overlay)) + +(defun slime-create-note-overlay (note start end severity message) + "Create an overlay representing a compiler note. +The overlay has several properties: + FACE - to underline the relevant text. + SEVERITY - for future reference :NOTE, :STYLE-WARNING, :WARNING, or :ERROR. + MOUSE-FACE - highlight the note when the mouse passes over. + HELP-ECHO - a string describing the note, both for future reference + and for display as a tooltip (due to the special + property name)." + (let ((overlay (slime-make-note-overlay note start end))) + (cl-macrolet ((putp (name value) `(overlay-put overlay ,name ,value))) + (putp 'face (slime-severity-face severity)) + (putp 'severity severity) + (putp 'mouse-face 'highlight) + (putp 'help-echo message) + overlay))) + +;; XXX Obsolete due to `slime-merge-notes-for-display' doing the +;; work already -- unless we decide to put several sets of notes on a +;; buffer without clearing in between, which only this handles. +(defun slime-merge-note-into-overlay (overlay severity message) + "Merge another compiler note into an existing overlay. +The help text describes both notes, and the highest of the severities +is kept." + (cl-macrolet ((putp (name value) `(overlay-put overlay ,name ,value)) + (getp (name) `(overlay-get overlay ,name))) + (putp 'severity (slime-most-severe severity (getp 'severity))) + (putp 'face (slime-severity-face (getp 'severity))) + (putp 'help-echo (concat (getp 'help-echo) "\n" message)))) + +(defun slime-choose-overlay-region (note) + "Choose the start and end points for an overlay over NOTE. +If the location's sexp is a list spanning multiple lines, then the +region around the first element is used. +Return nil if there's no useful source location." + (let ((location (slime-note.location note))) + (when location + (slime-dcase location + ((:error _)) ; do nothing + ((:location file pos _hints) + (cond ((eq (car file) ':source-form) nil) + ((eq (slime-note.severity note) :read-error) + (slime-choose-overlay-for-read-error location)) + ((equal pos '(:eof)) + (cl-values (1- (point-max)) (point-max))) + (t + (slime-choose-overlay-for-sexp location)))))))) + +(defun slime-choose-overlay-for-read-error (location) + (let ((pos (slime-location-offset location))) + (save-excursion + (goto-char pos) + (cond ((slime-symbol-at-point) + ;; package not found, &c. + (cl-values (slime-symbol-start-pos) (slime-symbol-end-pos))) + (t + (cl-values pos (1+ pos))))))) + +(defun slime-choose-overlay-for-sexp (location) + (slime-goto-source-location location) + (skip-chars-forward "'#`") + (let ((start (point))) + (ignore-errors (slime-forward-sexp)) + (if (slime-same-line-p start (point)) + (cl-values start (point)) + (cl-values (1+ start) + (progn (goto-char (1+ start)) + (ignore-errors (forward-sexp 1)) + (point)))))) + +(defun slime-same-line-p (pos1 pos2) + "Return t if buffer positions POS1 and POS2 are on the same line." + (save-excursion (goto-char (min pos1 pos2)) + (<= (max pos1 pos2) (line-end-position)))) + +(defvar slime-severity-face-plist + '(:error slime-error-face + :read-error slime-error-face + :warning slime-warning-face + :redefinition slime-style-warning-face + :style-warning slime-style-warning-face + :early-deprecation-warning slime-early-deprecation-warning-face + :late-deprecation-warning slime-late-deprecation-warning-face + :final-deprecation-warning slime-final-deprecation-warning-face + :note slime-note-face)) + +(defun slime-severity-face (severity) + "Return the name of the font-lock face representing SEVERITY." + (or (plist-get slime-severity-face-plist severity) + (error "No face for: %S" severity))) + +(defvar slime-severity-order + '(:note + :early-deprecation-warning :style-warning :redefinition + :late-deprecation-warning :final-deprecation-warning + :warning :error :read-error)) + +(defun slime-severity< (sev1 sev2) + "Return true if SEV1 is less severe than SEV2." + (< (cl-position sev1 slime-severity-order) + (cl-position sev2 slime-severity-order))) + +(defun slime-most-severe (sev1 sev2) + "Return the most servere of two conditions." + (if (slime-severity< sev1 sev2) sev2 sev1)) + +;; XXX: unused function +(defun slime-visit-source-path (source-path) + "Visit a full source path including the top-level form." + (goto-char (point-min)) + (slime-forward-source-path source-path)) + +(defun slime-forward-positioned-source-path (source-path) + "Move forward through a sourcepath from a fixed position. +The point is assumed to already be at the outermost sexp, making the +first element of the source-path redundant." + (ignore-errors + (slime-forward-sexp) + (beginning-of-defun)) + (let ((source-path (cdr source-path))) + (when source-path + (down-list 1) + (slime-forward-source-path source-path)))) + +(defun slime-forward-source-path (source-path) + (let ((origin (point))) + (condition-case nil + (progn + (cl-loop for (count . more) on source-path + do (progn + (slime-forward-sexp count) + (when more (down-list 1)))) + ;; Align at beginning + (slime-forward-sexp) + (beginning-of-sexp)) + (error (goto-char origin))))) + + +;; FIXME: really fix this mess +;; FIXME: the check shouln't be done here anyway but by M-. itself. + +(defun slime-filesystem-toplevel-directory () + ;; Windows doesn't have a true toplevel root directory, and all + ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs + ;; perspective anyway. + (if (memq system-type '(ms-dos windows-nt)) + "" + (file-name-as-directory "/"))) + +(defun slime-file-name-merge-source-root (target-filename buffer-filename) + "Returns a filename where the source root directory of TARGET-FILENAME +is replaced with the source root directory of BUFFER-FILENAME. + +If no common source root could be determined, return NIL. + +E.g. (slime-file-name-merge-source-root + \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\" + \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\") + + ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\" +" + (let ((target-dirs (split-string (file-name-directory target-filename) + "/" t)) + (buffer-dirs (split-string (file-name-directory buffer-filename) + "/" t))) + ;; Starting from the end, we look if one of the TARGET-DIRS exists + ;; in BUFFER-FILENAME---if so, it and everything left from that dirname + ;; is considered to be the source root directory of BUFFER-FILENAME. + (cl-loop with target-suffix-dirs = nil + with buffer-dirs* = (reverse buffer-dirs) + with target-dirs* = (reverse target-dirs) + for target-dir in target-dirs* + do (let ((concat-dirs (lambda (dirs) + (apply #'concat + (mapcar #'file-name-as-directory + dirs)))) + (pos (cl-position target-dir buffer-dirs* + :test #'equal))) + (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? + (push target-dir target-suffix-dirs) + (let* ((target-suffix + ; PUSH reversed for us! + (funcall concat-dirs target-suffix-dirs)) + (buffer-root + (funcall concat-dirs + (reverse (nthcdr pos buffer-dirs*))))) + (cl-return (concat (slime-filesystem-toplevel-directory) + buffer-root + target-suffix + (file-name-nondirectory + target-filename))))))))) + +(defun slime-highlight-differences-in-dirname (base-dirname contrast-dirname) + "Returns a copy of BASE-DIRNAME where all differences between +BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a +highlighting face." + (setq base-dirname (file-name-as-directory base-dirname)) + (setq contrast-dirname (file-name-as-directory contrast-dirname)) + (let ((base-dirs (split-string base-dirname "/" t)) + (contrast-dirs (split-string contrast-dirname "/" t))) + (with-temp-buffer + (cl-loop initially (insert (slime-filesystem-toplevel-directory)) + for base-dir in base-dirs do + (let ((pos (cl-position base-dir contrast-dirs :test #'equal))) + (cond ((not pos) + (slime-insert-propertized '(face highlight) base-dir) + (insert "/")) + (t + (insert (file-name-as-directory base-dir)) + (setq contrast-dirs + (nthcdr (1+ pos) contrast-dirs)))))) + (buffer-substring (point-min) (point-max))))) + +(defvar slime-warn-when-possibly-tricked-by-M-. t + "When working on multiple source trees simultaneously, the way +`slime-edit-definition' (M-.) works can sometimes be confusing: + +`M-.' visits locations that are present in the current Lisp image, +which works perfectly well as long as the image reflects the source +tree that one is currently looking at. + +In the other case, however, one can easily end up visiting a file +in a different source root directory (cl-the one corresponding to +the Lisp image), and is thus easily tricked to modify the wrong +source files---which can lead to quite some stressfull cursing. + +If this variable is T, a warning message is issued to raise the +user's attention whenever `M-.' is about opening a file in a +different source root that also exists in the source root +directory of the user's current buffer. + +There's no guarantee that all possible cases are covered, but +if you encounter such a warning, it's a strong indication that +you should check twice before modifying.") + +(defun slime-maybe-warn-for-different-source-root (target-filename + buffer-filename) + (let ((guessed-target (slime-file-name-merge-source-root target-filename + buffer-filename))) + (when (and guessed-target + (not (equal guessed-target target-filename)) + (file-exists-p guessed-target)) + (slime-message "Attention: This is `%s'." + (concat (slime-highlight-differences-in-dirname + (file-name-directory target-filename) + (file-name-directory guessed-target)) + (file-name-nondirectory target-filename)))))) + +(defun slime-check-location-filename-sanity (filename) + (when slime-warn-when-possibly-tricked-by-M-. + (cl-macrolet ((truename-safe (file) `(and ,file (file-truename ,file)))) + (let ((target-filename (truename-safe filename)) + (buffer-filename (truename-safe (buffer-file-name)))) + (when (and target-filename + buffer-filename) + (slime-maybe-warn-for-different-source-root + target-filename buffer-filename)))))) + +(defun slime-check-location-buffer-name-sanity (buffer-name) + (slime-check-location-filename-sanity + (buffer-file-name (get-buffer buffer-name)))) + + + +(defun slime-goto-location-buffer (buffer) + (slime-dcase buffer + ((:file filename) + (let ((filename (slime-from-lisp-filename filename))) + (slime-check-location-filename-sanity filename) + (set-buffer (or (get-file-buffer filename) + (let ((find-file-suppress-same-file-warnings t)) + (find-file-noselect filename)))))) + ((:buffer buffer-name) + (slime-check-location-buffer-name-sanity buffer-name) + (set-buffer buffer-name)) + ((:buffer-and-file buffer filename) + (slime-goto-location-buffer + (if (get-buffer buffer) + (list :buffer buffer) + (list :file filename)))) + ((:source-form string) + (set-buffer (get-buffer-create (slime-buffer-name :source))) + (erase-buffer) + (lisp-mode) + (insert string) + (goto-char (point-min))) + ((:zip file entry) + (require 'arc-mode) + (set-buffer (find-file-noselect file t)) + (goto-char (point-min)) + (re-search-forward (concat " " entry "$")) + (let ((buffer (save-window-excursion + (archive-extract) + (current-buffer)))) + (set-buffer buffer) + (goto-char (point-min)))))) + +(defun slime-goto-location-position (position) + (slime-dcase position + ((:position pos) + (goto-char 1) + (forward-char (- (1- pos) (slime-eol-conversion-fixup (1- pos))))) + ((:offset start offset) + (goto-char start) + (forward-char offset)) + ((:line start &optional column) + (goto-char (point-min)) + (beginning-of-line start) + (cond (column (move-to-column column)) + (t (skip-chars-forward " \t")))) + ((:function-name name) + (let ((case-fold-search t) + (name (regexp-quote name))) + (goto-char (point-min)) + (when (or + (re-search-forward + (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" + (regexp-quote name)) nil t) + (re-search-forward + (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)) + (goto-char (match-beginning 0))))) + ((:method name specializers &rest qualifiers) + (slime-search-method-location name specializers qualifiers)) + ((:source-path source-path start-position) + (cond (start-position + (goto-char start-position) + (slime-forward-positioned-source-path source-path)) + (t + (slime-forward-source-path source-path)))) + ((:eof) + (goto-char (point-max))))) + +(defun slime-eol-conversion-fixup (n) + ;; Return the number of \r\n eol markers that we need to cross when + ;; moving N chars forward. N is the number of chars but \r\n are + ;; counted as 2 separate chars. + (cl-case (coding-system-eol-type buffer-file-coding-system) + ((1) + (save-excursion + (cl-do ((pos (+ (point) n)) + (count 0 (1+ count))) + ((>= (point) pos) (1- count)) + (forward-line) + (cl-decf pos)))) + (t 0))) + +(defun slime-search-method-location (name specializers qualifiers) + ;; Look for a sequence of words (def method name + ;; qualifers specializers don't look for "T" since it isn't requires + ;; (arg without t) as class is taken as such. + (let* ((case-fold-search t) + (name (regexp-quote name)) + (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) + qualifiers "")) + (specializers (mapconcat + (lambda (el) + (if (eql (aref el 0) ?\() + (let ((spec (read el))) + (if (eq (car spec) 'EQL) + (concat + ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" + (format "%s" (cl-second spec)) ")") + (error "don't understand specializer: %s,%s" + el (car spec)))) + (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) + (remove "T" specializers) "")) + (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name + qualifiers specializers))) + (or (and (re-search-forward regexp nil t) + (goto-char (match-beginning 0))) + ;; (slime-goto-location-position `(:function-name ,name)) + ))) + +(defun slime-search-call-site (fname) + "Move to the place where FNAME called. +Don't move if there are multiple or no calls in the current defun." + (save-restriction + (narrow-to-defun) + (let ((start (point)) + (regexp (concat "(" fname "[)\n \t]")) + (case-fold-search t)) + (cond ((and (re-search-forward regexp nil t) + (not (re-search-forward regexp nil t))) + (goto-char (match-beginning 0))) + (t (goto-char start)))))) + +(defun slime-search-edit-path (edit-path) + "Move to EDIT-PATH starting at the current toplevel form." + (when edit-path + (unless (and (= (current-column) 0) + (looking-at "(")) + (beginning-of-defun)) + (slime-forward-source-path edit-path))) + +(defun slime-goto-source-location (location &optional noerror) + "Move to the source location LOCATION. Several kinds of locations +are supported: + + ::= (:location ) + | (:error ) + + ::= (:file ) + | (:buffer ) + | (:buffer-and-file ) + | (:source-form ) + | (:zip ) + + ::= (:position ) ; 1 based (for files) + | (:offset ) ; start+offset (for C-c C-c) + | (:line []) + | (:function-name ) + | (:source-path ) + | (:method . )" + (slime-dcase location + ((:location buffer _position _hints) + (slime-goto-location-buffer buffer) + (let ((pos (slime-location-offset location))) + (cond ((and (<= (point-min) pos) (<= pos (point-max)))) + (widen-automatically (widen)) + (t + (error "Location is outside accessible part of buffer"))) + (goto-char pos))) + ((:error message) + (if noerror + (slime-message "%s" message) + (error "%s" message))))) + +(defun slime-location-offset (location) + "Return the position, as character number, of LOCATION." + (save-restriction + (widen) + (condition-case nil + (slime-goto-location-position + (slime-location.position location)) + (error (goto-char 0))) + (cl-destructuring-bind (&key snippet edit-path call-site align) + (slime-location.hints location) + (when snippet (slime-isearch snippet)) + (when edit-path (slime-search-edit-path edit-path)) + (when call-site (slime-search-call-site call-site)) + (when align + (slime-forward-sexp) + (beginning-of-sexp))) + (point))) + + +;;;;; Incremental search +;; +;; Search for the longest match of a string in either direction. +;; +;; This is for locating text that is expected to be near the point and +;; may have been modified (but hopefully not near the beginning!) + +(defun slime-isearch (string) + "Find the longest occurence of STRING either backwards of forwards. +If multiple matches exist the choose the one nearest to point." + (goto-char + (let* ((start (point)) + (len1 (slime-isearch-with-function 'search-forward string)) + (pos1 (point))) + (goto-char start) + (let* ((len2 (slime-isearch-with-function 'search-backward string)) + (pos2 (point))) + (cond ((and len1 len2) + ;; Have a match in both directions + (cond ((= len1 len2) + ;; Both are full matches -- choose the nearest. + (if (< (abs (- start pos1)) + (abs (- start pos2))) + pos1 pos2)) + ((> len1 len2) pos1) + ((> len2 len1) pos2))) + (len1 pos1) + (len2 pos2) + (t start)))))) + +(defun slime-isearch-with-function (search-fn string) + "Search for the longest substring of STRING using SEARCH-FN. +SEARCH-FN is either the symbol `search-forward' or `search-backward'." + (unless (string= string "") + (cl-loop for i from 1 to (length string) + while (funcall search-fn (substring string 0 i) nil t) + for match-data = (match-data) + do (cl-case search-fn + (search-forward (goto-char (match-beginning 0))) + (search-backward (goto-char (1+ (match-end 0))))) + finally (cl-return (if (null match-data) + nil + ;; Finish based on the last successful match + (store-match-data match-data) + (goto-char (match-beginning 0)) + (- (match-end 0) (match-beginning 0))))))) + + +;;;;; Visiting and navigating the overlays of compiler notes + +(defun slime-next-note () + "Go to and describe the next compiler note in the buffer." + (interactive) + (let ((here (point)) + (note (slime-find-next-note))) + (if note + (slime-show-note note) + (goto-char here) + (message "No next note.")))) + +(defun slime-previous-note () + "Go to and describe the previous compiler note in the buffer." + (interactive) + (let ((here (point)) + (note (slime-find-previous-note))) + (if note + (slime-show-note note) + (goto-char here) + (message "No previous note.")))) + +(defun slime-goto-first-note (&rest _) + "Go to the first note in the buffer." + (let ((point (point))) + (goto-char (point-min)) + (cond ((slime-find-next-note) + (slime-show-note (slime-note-at-point))) + (t (goto-char point))))) + +(defun slime-remove-notes () + "Remove compiler-note annotations from the current buffer." + (interactive) + (slime-remove-old-overlays)) + +(defun slime-show-note (overlay) + "Present the details of a compiler note to the user." + (slime-temporarily-highlight-note overlay) + (if (get-buffer-window (slime-buffer-name :compilation) t) + (slime-goto-note-in-compilation-log (overlay-get overlay 'slime-note)) + (let ((message (get-char-property (point) 'help-echo))) + (slime-message "%s" (if (zerop (length message)) "\"\"" message))))) + +;; FIXME: could probably use flash region +(defun slime-temporarily-highlight-note (overlay) + "Temporarily highlight a compiler note's overlay. +The highlighting is designed to both make the relevant source more +visible, and to highlight any further notes that are nested inside the +current one. + +The highlighting is automatically undone with a timer." + (run-with-timer 0.2 nil + #'overlay-put overlay 'face (overlay-get overlay 'face)) + (overlay-put overlay 'face 'slime-highlight-face)) + + +;;;;; Overlay lookup operations + +(defun slime-note-at-point () + "Return the overlay for a note starting at point, otherwise NIL." + (cl-find (point) (slime-note-overlays-at-point) + :key 'overlay-start)) + +(defun slime-note-overlay-p (overlay) + "Return true if OVERLAY represents a compiler note." + (overlay-get overlay 'slime-note)) + +(defun slime-note-overlays-at-point () + "Return a list of all note overlays that are under the point." + (cl-remove-if-not 'slime-note-overlay-p (overlays-at (point)))) + +(defun slime-find-next-note () + "Go to the next position with the `slime-note' text property. +Retuns the note overlay if such a position is found, otherwise nil." + (slime-search-property 'slime-note nil #'slime-note-at-point)) + +(defun slime-find-previous-note () + "Go to the next position with the `slime-note' text property. +Retuns the note overlay if such a position is found, otherwise nil." + (slime-search-property 'slime-note t #'slime-note-at-point)) + + +;;;; Arglist Display + +(defun slime-space (n) + "Insert a space and print some relevant information (function arglist). +Designed to be bound to the SPC key. Prefix argument can be used to insert +more than one space." + (interactive "p") + (self-insert-command n) + (slime-echo-arglist)) + +(put 'slime-space 'delete-selection t) ; for delete-section-mode & CUA + +(defun slime-echo-arglist () + (when (slime-background-activities-enabled-p) + (let ((op (slime-operator-before-point))) + (when op + (slime-eval-async `(swank:operator-arglist ,op + ,(slime-current-package)) + (lambda (arglist) + (when arglist + (slime-message "%s" arglist)))))))) + +(defvar slime-operator-before-point-function 'slime-lisp-operator-before-point) + +(defun slime-operator-before-point () + (funcall slime-operator-before-point-function)) + +(defun slime-lisp-operator-before-point () + (ignore-errors + (save-excursion + (backward-up-list 1) + (down-list 1) + (slime-symbol-at-point)))) + +;;;; Completion + +;; FIXME: use this in Emacs 24 +;;(define-obsolete-function-alias slime-complete-symbol completion-at-point) + +(defalias 'slime-complete-symbol #'completion-at-point) +(make-obsolete 'slime-complete-symbol #'completion-at-point "2015-10-17") + +;; This is the function that we add to +;; `completion-at-point-functions'. For backward-compatibilty we look +;; at `slime-complete-symbol-function' first. The indirection through +;; `slime-completion-at-point-functions' is used so that users don't +;; have to set `completion-at-point-functions' in every slime-like +;; buffer. +(defun slime--completion-at-point () + (cond (slime-complete-symbol-function + slime-complete-symbol-function) + (t + (run-hook-with-args-until-success + 'slime-completion-at-point-functions)))) + +(defun slime-setup-completion () + (add-hook 'completion-at-point-functions #'slime--completion-at-point nil t)) + +(defun slime-simple-completion-at-point () + "Complete the symbol at point. +Perform completion similar to `elisp-completion-at-point'." + (let* ((end (point)) + (beg (slime-symbol-start-pos))) + (list beg end (completion-table-dynamic #'slime-simple-completions)))) + +(defun slime-filename-completion () + "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-filename-completion)))) + +;; FIXME: for backward compatibility. Remove it one day +;; together with slime-complete-symbol-function. +(defun slime-simple-complete-symbol () + (let ((completion-at-point-functions '(slime-maybe-complete-as-filename + slime-simple-completion-at-point))) + (completion-at-point))) + +;; NOTE: the original idea was to bind this to TAB but that no longer +;; works as `completion-at-point' sets a transient keymap that +;; overrides TAB. So this is rather useless now. +(defun slime-indent-and-complete-symbol () + "Indent the current line and perform 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)) + (completion-at-point)) + ((memq (char-before) '(?\t ?\ )) + (slime-echo-arglist)))))) + +(make-obsolete 'slime-indent-and-complete-symbol + "Set tab-always-indent to 'complete." + "2015-10-18") + +(defvar slime-minibuffer-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\t" #'completion-at-point) + (define-key map "\M-\t" #'completion-at-point) + map) + "Minibuffer keymap used for reading CL expressions.") + +(defvar slime-minibuffer-history '() + "History list of expressions read from the minibuffer.") + +(defun slime-minibuffer-setup-hook () + (cons (lexical-let ((package (slime-current-package)) + (connection (slime-connection))) + (lambda () + (setq slime-buffer-package package) + (setq slime-buffer-connection connection) + (set-syntax-table lisp-mode-syntax-table) + (slime-setup-completion))) + minibuffer-setup-hook)) + +(defun slime-read-from-minibuffer (prompt &optional initial-value history) + "Read a string from the minibuffer, prompting with PROMPT. +If INITIAL-VALUE is non-nil, it is inserted into the minibuffer before +reading input. The result is a string (\"\" if no input was given)." + (let ((minibuffer-setup-hook (slime-minibuffer-setup-hook))) + (read-from-minibuffer prompt initial-value slime-minibuffer-map + nil (or history 'slime-minibuffer-history)))) + +(defun slime-bogus-completion-alist (list) + "Make an alist out of list. +The same elements go in the CAR, and nil in the CDR. To support the +apparently very stupid `try-completions' interface, that wants an +alist but ignores CDRs." + (mapcar (lambda (x) (cons x nil)) list)) + +(defun slime-simple-completions (prefix) + (cl-destructuring-bind (completions _partial) + (let ((slime-current-thread t)) + (slime-eval + `(swank:simple-completions ,(substring-no-properties prefix) + ',(slime-current-package)))) + completions)) + + +;;;; Edit definition + +(defun slime-push-definition-stack () + "Add point to find-tag-marker-ring." + (require 'etags) + (ring-insert find-tag-marker-ring (point-marker))) + +(defun slime-pop-find-definition-stack () + "Pop the edit-definition stack and goto the location." + (interactive) + (pop-tag-mark)) + +(cl-defstruct (slime-xref (:conc-name slime-xref.) (:type list)) + dspec location) + +(cl-defstruct (slime-location (:conc-name slime-location.) (:type list) + (:constructor nil) + (:copier nil)) + tag buffer position hints) + +(defun slime-location-p (o) (and (consp o) (eq (car o) :location))) + +(defun slime-xref-has-location-p (xref) + (slime-location-p (slime-xref.location xref))) + +(defun make-slime-buffer-location (buffer-name position &optional hints) + `(:location (:buffer ,buffer-name) (:position ,position) + ,(when hints `(:hints ,hints)))) + +(defun make-slime-file-location (file-name position &optional hints) + `(:location (:file ,file-name) (:position ,position) + ,(when hints `(:hints ,hints)))) + +;;; The hooks are tried in order until one succeeds, otherwise the +;;; default implementation involving `slime-find-definitions-function' +;;; is used. The hooks are called with the same arguments as +;;; `slime-edit-definition'. +(defvar slime-edit-definition-hooks) + +(defun slime-edit-definition (&optional name where) + "Lookup the definition of the name at point. +If there's no name at point, or a prefix argument is given, then the +function name is prompted." + (interactive (list (or (and (not current-prefix-arg) + (slime-symbol-at-point)) + (slime-read-symbol-name "Edit Definition of: ")))) + ;; The hooks might search for a name in a different manner, so don't + ;; ask the user if it's missing before the hooks are run + (or (run-hook-with-args-until-success 'slime-edit-definition-hooks + name where) + (slime-edit-definition-cont (slime-find-definitions name) + name where))) + +(defun slime-edit-definition-cont (xrefs name where) + (cl-destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs) + (cond ((null xrefs) + (error "No known definition for: %s (in %s)" + name (slime-current-package))) + (1loc + (slime-push-definition-stack) + (slime-pop-to-location (slime-xref.location (car xrefs)) where)) + ((slime-length= xrefs 1) ; ((:error "...")) + (error "%s" (cadr (slime-xref.location (car xrefs))))) + (t + (slime-push-definition-stack) + (slime-show-xrefs file-alist 'definition name + (slime-current-package)))))) + +(defvar slime-edit-uses-xrefs + '(:calls :macroexpands :binds :references :sets :specializes)) + +;;; FIXME. TODO: Would be nice to group the symbols (in each +;;; type-group) by their home-package. +(defun slime-edit-uses (symbol) + "Lookup all the uses of SYMBOL." + (interactive (list (slime-read-symbol-name "Edit Uses of: "))) + (slime-xrefs slime-edit-uses-xrefs + symbol + (lambda (xrefs type symbol package) + (cond + ((null xrefs) + (message "No xref information found for %s." symbol)) + ((and (slime-length= xrefs 1) ; one group + (slime-length= (cdar xrefs) 1)) ; one ref in group + (cl-destructuring-bind (_ (_ loc)) (cl-first xrefs) + (slime-push-definition-stack) + (slime-pop-to-location loc))) + (t + (slime-push-definition-stack) + (slime-show-xref-buffer xrefs type symbol package)))))) + +(defun slime-analyze-xrefs (xrefs) + "Find common filenames in XREFS. +Return a list (SINGLE-LOCATION FILE-ALIST). +SINGLE-LOCATION is true if all xrefs point to the same location. +FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)." + (list (and xrefs + (let ((loc (slime-xref.location (car xrefs)))) + (and (slime-location-p loc) + (cl-every (lambda (x) (equal (slime-xref.location x) loc)) + (cdr xrefs))))) + (slime-alistify xrefs #'slime-xref-group #'equal))) + +(defun slime-xref-group (xref) + (cond ((slime-xref-has-location-p xref) + (slime-dcase (slime-location.buffer (slime-xref.location xref)) + ((:file filename) filename) + ((:buffer bufname) + (let ((buffer (get-buffer bufname))) + (if buffer + (format "%S" buffer) ; "#" + (format "%s (previously existing buffer)" bufname)))) + ((:buffer-and-file _buffer filename) filename) + ((:source-form _) "(S-Exp)") + ((:zip _zip entry) entry))) + (t + "(No location)"))) + +(defun slime-pop-to-location (location &optional where) + (slime-goto-source-location location) + (let ((point (point))) + (cl-ecase where + ((nil) (switch-to-buffer (current-buffer))) + (window (pop-to-buffer (current-buffer) t)) + (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t)))) + (goto-char point))) + +(defun slime-postprocess-xref (original-xref) + "Process (for normalization purposes) an Xref comming directly +from SWANK before the rest of Slime sees it. In particular, +convert ETAGS based xrefs to actual file+position based +locations." + (if (not (slime-xref-has-location-p original-xref)) + (list original-xref) + (let ((loc (slime-xref.location original-xref))) + (slime-dcase (slime-location.buffer loc) + ((:etags-file tags-file) + (slime-dcase (slime-location.position loc) + ((:tag &rest tags) + (visit-tags-table tags-file) + (mapcar (lambda (xref) + (let ((old-dspec (slime-xref.dspec original-xref)) + (new-dspec (slime-xref.dspec xref))) + (setf (slime-xref.dspec xref) + (format "%s: %s" old-dspec new-dspec)) + xref)) + (cl-mapcan #'slime-etags-definitions tags))))) + (t + (list original-xref)))))) + +(defun slime-postprocess-xrefs (xrefs) + (cl-mapcan #'slime-postprocess-xref xrefs)) + +(defun slime-find-definitions (name) + "Find definitions for NAME." + (slime-postprocess-xrefs (funcall slime-find-definitions-function name))) + +(defun slime-find-definitions-rpc (name) + (slime-eval `(swank:find-definitions-for-emacs ,name))) + +(defun slime-edit-definition-other-window (name) + "Like `slime-edit-definition' but switch to the other window." + (interactive (list (slime-read-symbol-name "Symbol: "))) + (slime-edit-definition name 'window)) + +(defun slime-edit-definition-other-frame (name) + "Like `slime-edit-definition' but switch to the other window." + (interactive (list (slime-read-symbol-name "Symbol: "))) + (slime-edit-definition name 'frame)) + +(defun slime-edit-definition-with-etags (name) + (interactive (list (slime-read-symbol-name "Symbol: "))) + (let ((xrefs (slime-etags-definitions name))) + (cond (xrefs + (message "Using tag file...") + (slime-edit-definition-cont xrefs name nil)) + (t + (error "No known definition for: %s" name))))) + +(defun slime-etags-to-locations (name) + "Search for definitions matching `name' in the currently active +tags table. Return a possibly empty list of slime-locations." + (let ((locs '())) + (save-excursion + (let ((first-time t)) + (while (visit-tags-table-buffer (not first-time)) + (setq first-time nil) + (goto-char (point-min)) + (while (search-forward name nil t) + (beginning-of-line) + (cl-destructuring-bind (hint line &rest pos) (etags-snarf-tag) + (unless (eq hint t) ; hint==t if we are in a filename line + (push `(:location (:file ,(expand-file-name (file-of-tag))) + (:line ,line) + (:snippet ,hint)) + locs)))))) + (nreverse locs)))) + +(defun slime-etags-definitions (name) + "Search definitions matching NAME in the tags file. +The result is a (possibly empty) list of definitions." + (mapcar (lambda (loc) + (make-slime-xref :dspec (cl-second (slime-location.hints loc)) + :location loc)) + (slime-etags-to-locations name))) + +;;;;; first-change-hook + +(defun slime-first-change-hook () + "Notify Lisp that a source file's buffer has been modified." + ;; Be careful not to disturb anything! + ;; In particular if we muck up the match-data then query-replace + ;; breaks. -luke (26/Jul/2004) + (save-excursion + (save-match-data + (when (and (buffer-file-name) + (file-exists-p (buffer-file-name)) + (slime-background-activities-enabled-p)) + (let ((filename (slime-to-lisp-filename (buffer-file-name)))) + (slime-eval-async `(swank:buffer-first-change ,filename))))))) + +(defun slime-setup-first-change-hook () + (add-hook (make-local-variable 'first-change-hook) + 'slime-first-change-hook)) + +(add-hook 'slime-mode-hook 'slime-setup-first-change-hook) + + +;;;; Eval for Lisp + +(defun slime-lisp-readable-p (x) + (or (stringp x) + (memq x '(nil t)) + (integerp x) + (keywordp x) + (and (consp x) + (let ((l x)) + (while (consp l) + (slime-lisp-readable-p (car x)) + (setq l (cdr l))) + (slime-lisp-readable-p l))))) + +(defun slime--funcall-and-dispatch-result (thread tag fn &rest args) + (let ((ok nil) + (value nil) + (error nil)) + (unwind-protect + (condition-case err + (progn + (setq value (apply fn args)) + (setq ok t)) + ((debug error) + (setq error err))) + (let ((result (cond ((and ok + (not (slime-lisp-readable-p value))) + `(:unreadable ,(slime-prin1-to-string value))) + (ok `(:ok ,value)) + (error `(:error ,(symbol-name (car error)) + . ,(mapcar #'slime-prin1-to-string + (cdr error)))) + (t `(:abort))))) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,result)))))) + +(defun slime-eval-for-lisp (thread tag form-string) + (slime--funcall-and-dispatch-result thread tag + (lambda (s) (eval (read s))) + form-string)) + +(defun slime-check-eval-in-emacs-enabled () + "Raise an error if `slime-enable-evaluate-in-emacs' isn't true." + (unless slime-enable-evaluate-in-emacs + (error (concat "slime-eval-in-emacs disabled for security. " + "Set `slime-enable-evaluate-in-emacs' true to enable it.")))) + + +;;;; RPC from Lisp + +(defmacro defslimefun (name arglist &rest body) + "Define a function via `cl-defun' that can be invoked from SWANK." + `(progn + (put ',name 'slime-rpc t) + (cl-defun ,name ,arglist ,@body))) + +(defun slime-rpc-allowed-p (fn) + (get fn 'slime-rpc)) + +(defun slime-check-rpc-allowed (fn) + "Raise an error if FN does not denote a function defined via +`defslimefun'." + (unless (slime-rpc-allowed-p fn) + (error "Lisp tried to RPC `%s', but it wasn't defined via `defslimefun'." + fn))) + +(defun slime-rpc-from-lisp (thread tag fn args) + (if (not (slime-rpc-allowed-p fn)) + (slime-dispatch-event '(:ed-rpc-forbidden ,thread ,tag ,fn)) + (apply #'slime--funcall-and-dispatch-result thread tag fn args))) + + +;;;; `ED' + +(defvar slime-ed-frame nil + "The frame used by `slime-ed'.") + +(defcustom slime-ed-use-dedicated-frame t + "*When non-nil, `slime-ed' will create and reuse a dedicated frame." + :type 'boolean + :group 'slime-mode) + +(defun slime-ed (what) + "Edit WHAT. + +WHAT can be: + A filename (string), + A list (:filename FILENAME &key LINE COLUMN POSITION), + A function name (:function-name STRING) + nil. + +This is for use in the implementation of COMMON-LISP:ED." + (when slime-ed-use-dedicated-frame + (unless (and slime-ed-frame (frame-live-p slime-ed-frame)) + (setq slime-ed-frame (make-frame))) + (select-frame slime-ed-frame)) + (when what + (slime-dcase what + ((:filename file &key line column position bytep) + (find-file (slime-from-lisp-filename file)) + (when line (slime-goto-line line)) + (when column (move-to-column column)) + (when position + (goto-char (if bytep + (byte-to-position position) + position)))) + ((:function-name name) + (slime-edit-definition name))))) + +(defun slime-goto-line (line-number) + "Move to line LINE-NUMBER (1-based). +This is similar to `goto-line' but without pushing the mark and +the display stuff that we neither need nor want." + (cl-assert (= (buffer-size) (- (point-max) (point-min))) () + "slime-goto-line in narrowed buffer") + (goto-char (point-min)) + (forward-line (1- line-number))) + +(defun slime-y-or-n-p (thread tag question) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,(y-or-n-p question)))) + +(defun slime-read-from-minibuffer-for-swank (thread tag prompt initial-value) + (let ((answer (condition-case nil + (slime-read-from-minibuffer prompt initial-value) + (quit nil)))) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,answer)))) + +;;;; Interactive evaluation. + +(defun slime-interactive-eval (string) + "Read and evaluate STRING and print value in minibuffer. + +Note: If a prefix argument is in effect then the result will be +inserted in the current buffer." + (interactive (list (slime-read-from-minibuffer "Slime Eval: "))) + (cl-case current-prefix-arg + ((nil) + (slime-eval-with-transcript `(swank:interactive-eval ,string))) + ((-) + (slime-eval-save string)) + (t + (slime-eval-print string)))) + +(defvar slime-transcript-start-hook nil + "Hook run before start an evalution.") +(defvar slime-transcript-stop-hook nil + "Hook run after finishing a evalution.") + +(defun slime-display-eval-result (value) + (slime-message "%s" value)) + +(defun slime-eval-with-transcript (form) + "Eval FORM in Lisp. Display output, if any." + (run-hooks 'slime-transcript-start-hook) + (slime-rex () (form) + ((:ok value) + (run-hooks 'slime-transcript-stop-hook) + (slime-display-eval-result value)) + ((:abort condition) + (run-hooks 'slime-transcript-stop-hook) + (message "Evaluation aborted on %s." condition)))) + +(defun slime-eval-print (string) + "Eval STRING in Lisp; insert any output and the result at point." + (slime-eval-async `(swank:eval-and-grab-output ,string) + (lambda (result) + (cl-destructuring-bind (output value) result + (push-mark) + (insert output value))))) + +(defun slime-eval-save (string) + "Evaluate STRING in Lisp and save the result in the kill ring." + (slime-eval-async `(swank:eval-and-grab-output ,string) + (lambda (result) + (cl-destructuring-bind (output value) result + (let ((string (concat output value))) + (kill-new string) + (message "Evaluation finished; pushed result to kill ring.")))))) + +(defun slime-eval-describe (form) + "Evaluate FORM in Lisp and display the result in a new buffer." + (slime-eval-async form (slime-rcurry #'slime-show-description + (slime-current-package)))) + +(defvar slime-description-autofocus nil + "If non-nil select description windows on display.") + +(defun slime-show-description (string package) + ;; So we can have one description buffer open per connection. Useful + ;; for comparing the output of DISASSEMBLE across implementations. + ;; FIXME: could easily be achieved with M-x rename-buffer + (let ((bufname (slime-buffer-name :description))) + (slime-with-popup-buffer (bufname :package package + :connection t + :select slime-description-autofocus) + (princ string) + (goto-char (point-min))))) + +(defun slime-last-expression () + (buffer-substring-no-properties + (save-excursion (backward-sexp) (point)) + (point))) + +(defun slime-eval-last-expression () + "Evaluate the expression preceding point." + (interactive) + (slime-interactive-eval (slime-last-expression))) + +(defun slime-eval-defun () + "Evaluate the current toplevel form. +Use `slime-re-evaluate-defvar' if the from starts with '(defvar'" + (interactive) + (let ((form (slime-defun-at-point))) + (cond ((string-match "^(defvar " form) + (slime-re-evaluate-defvar form)) + (t + (slime-interactive-eval form))))) + +(defun slime-eval-region (start end) + "Evaluate region." + (interactive "r") + (slime-eval-with-transcript + `(swank:interactive-eval-region + ,(buffer-substring-no-properties start end)))) + +(defun slime-pprint-eval-region (start end) + "Evaluate region; pprint the value in a buffer." + (interactive "r") + (slime-eval-describe + `(swank:pprint-eval + ,(buffer-substring-no-properties start end)))) + +(defun slime-eval-buffer () + "Evaluate the current buffer. +The value is printed in the echo area." + (interactive) + (slime-eval-region (point-min) (point-max))) + +(defun slime-re-evaluate-defvar (form) + "Force the re-evaluaton of the defvar form before point. + +First make the variable unbound, then evaluate the entire form." + (interactive (list (slime-last-expression))) + (slime-eval-with-transcript `(swank:re-evaluate-defvar ,form))) + +(defun slime-pprint-eval-last-expression () + "Evaluate the form before point; pprint the value in a buffer." + (interactive) + (slime-eval-describe `(swank:pprint-eval ,(slime-last-expression)))) + +(defun slime-eval-print-last-expression (string) + "Evaluate sexp before point; print value into the current buffer" + (interactive (list (slime-last-expression))) + (insert "\n") + (slime-eval-print string)) + +;;;; Edit Lisp value +;;; +(defun slime-edit-value (form-string) + "\\\ +Edit the value of a setf'able form in a new buffer. +The value is inserted into a temporary buffer for editing and then set +in Lisp when committed with \\[slime-edit-value-commit]." + (interactive + (list (slime-read-from-minibuffer "Edit value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:value-for-editing ,form-string) + (lexical-let ((form-string form-string) + (package (slime-current-package))) + (lambda (result) + (slime-edit-value-callback form-string result + package))))) + +(make-variable-buffer-local + (defvar slime-edit-form-string nil + "The form being edited by `slime-edit-value'.")) + +(define-minor-mode slime-edit-value-mode + "Mode for editing a Lisp value." + nil + " Edit-Value" + '(("\C-c\C-c" . slime-edit-value-commit))) + +(defun slime-edit-value-callback (form-string current-value package) + (let* ((name (generate-new-buffer-name (format "*Edit %s*" form-string))) + (buffer (slime-with-popup-buffer (name :package package + :connection t + :select t + :mode 'lisp-mode) + (slime-popup-buffer-mode -1) ; don't want binding of 'q' + (slime-mode 1) + (slime-edit-value-mode 1) + (setq slime-edit-form-string form-string) + (insert current-value) + (current-buffer)))) + (with-current-buffer buffer + (setq buffer-read-only nil) + (message "Type C-c C-c when done")))) + +(defun slime-edit-value-commit () + "Commit the edited value to the Lisp image. +\\(See `slime-edit-value'.)" + (interactive) + (if (null slime-edit-form-string) + (error "Not editing a value.") + (let ((value (buffer-substring-no-properties (point-min) (point-max)))) + (lexical-let ((buffer (current-buffer))) + (slime-eval-async `(swank:commit-edited-value ,slime-edit-form-string + ,value) + (lambda (_) + (with-current-buffer buffer + (quit-window t)))))))) + +;;;; Tracing + +(defun slime-untrace-all () + "Untrace all functions." + (interactive) + (slime-eval `(swank:untrace-all))) + +(defun slime-toggle-trace-fdefinition (spec) + "Toggle trace." + (interactive (list (slime-read-from-minibuffer + "(Un)trace: " (slime-symbol-at-point)))) + (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec)))) + + + +(defun slime-disassemble-symbol (symbol-name) + "Display the disassembly for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Disassemble: "))) + (slime-eval-describe `(swank:disassemble-form ,(concat "'" symbol-name)))) + +(defun slime-undefine-function (symbol-name) + "Unbind the function slot of SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "fmakunbound: " t))) + (slime-eval-async `(swank:undefine-function ,symbol-name) + (lambda (result) (message "%s" result)))) + +(defun slime-unintern-symbol (symbol-name package) + "Unintern the symbol given with SYMBOL-NAME PACKAGE." + (interactive (list (slime-read-symbol-name "Unintern symbol: " t) + (slime-read-package-name "from package: " + (slime-current-package)))) + (slime-eval-async `(swank:unintern-symbol ,symbol-name ,package) + (lambda (result) (message "%s" result)))) + +(defun slime-delete-package (package-name) + "Delete the package with name PACKAGE-NAME." + (interactive (list (slime-read-package-name "Delete package: " + (slime-current-package)))) + (slime-eval-async `(cl:delete-package + (swank::guess-package ,package-name)))) + +(defun slime-load-file (filename) + "Load the Lisp file FILENAME." + (interactive (list + (read-file-name "Load file: " nil nil + nil (if (buffer-file-name) + (file-name-nondirectory + (buffer-file-name)))))) + (let ((lisp-filename (slime-to-lisp-filename (expand-file-name filename)))) + (slime-eval-with-transcript `(swank:load-file ,lisp-filename)))) + +(defvar slime-change-directory-hooks nil + "Hook run by `slime-change-directory'. +The functions are called with the new (absolute) directory.") + +(defun slime-change-directory (directory) + "Make DIRECTORY become Lisp's current directory. +Return whatever swank:set-default-directory returns." + (let ((dir (expand-file-name directory))) + (prog1 (slime-eval `(swank:set-default-directory + ,(slime-to-lisp-filename dir))) + (slime-with-connection-buffer nil (cd-absolute dir)) + (run-hook-with-args 'slime-change-directory-hooks dir)))) + +(defun slime-cd (directory) + "Make DIRECTORY become Lisp's current directory. +Return whatever swank:set-default-directory returns." + (interactive (list (read-directory-name "Directory: " nil nil t))) + (message "default-directory: %s" (slime-change-directory directory))) + +(defun slime-pwd () + "Show Lisp's default directory." + (interactive) + (message "Directory %s" (slime-eval `(swank:default-directory)))) + + +;;;; Profiling + +(defun slime-toggle-profile-fdefinition (fname-string) + "Toggle profiling for FNAME-STRING." + (interactive (list (slime-read-from-minibuffer + "(Un)Profile: " + (slime-symbol-at-point)))) + (slime-eval-async `(swank:toggle-profile-fdefinition ,fname-string) + (lambda (r) (message "%s" r)))) + +(defun slime-unprofile-all () + "Unprofile all functions." + (interactive) + (slime-eval-async '(swank:unprofile-all) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-report () + "Print profile report." + (interactive) + (slime-eval-with-transcript '(swank:profile-report))) + +(defun slime-profile-reset () + "Reset profile counters." + (interactive) + (slime-eval-async (slime-eval `(swank:profile-reset)) + (lambda (r) (message "%s" r)))) + +(defun slime-profiled-functions () + "Return list of names of currently profiled functions." + (interactive) + (slime-eval-async `(swank:profiled-functions) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-package (package callers methods) + "Profile all functions in PACKAGE. +If CALLER is non-nil names have counts of the most common calling +functions recorded. +If METHODS is non-nil, profile all methods of all generic function +having names in the given package." + (interactive (list (slime-read-package-name "Package: ") + (y-or-n-p "Record the most common callers? ") + (y-or-n-p "Profile methods? "))) + (slime-eval-async `(swank:swank-profile-package ,package ,callers ,methods) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-by-substring (substring &optional package) + "Profile all functions which names contain SUBSTRING. +If PACKAGE is NIL, then search in all packages." + (interactive (list + (slime-read-from-minibuffer + "Profile by matching substring: " + (slime-symbol-at-point)) + (slime-read-package-name "Package (RET for all packages): "))) + (let ((package (unless (equal package "") package))) + (slime-eval-async `(swank:profile-by-substring ,substring ,package) + (lambda (r) (message "%s" r)) ))) + +;;;; Documentation + +(defvar slime-documentation-lookup-function + 'slime-hyperspec-lookup) + +(defun slime-documentation-lookup () + "Generalized documentation lookup. Defaults to hyperspec lookup." + (interactive) + (call-interactively slime-documentation-lookup-function)) + +(defun slime-hyperspec-lookup (symbol-name) + "A wrapper for `hyperspec-lookup'" + (interactive (list (common-lisp-hyperspec-read-symbol-name + (slime-symbol-at-point)))) + (hyperspec-lookup symbol-name)) + +(defun slime-describe-symbol (symbol-name) + "Describe the symbol at point." + (interactive (list (slime-read-symbol-name "Describe symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-symbol ,symbol-name))) + +(defun slime-documentation (symbol-name) + "Display function- or symbol-documentation for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Documentation for symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe + `(swank:documentation-symbol ,symbol-name))) + +(defun slime-describe-function (symbol-name) + (interactive (list (slime-read-symbol-name "Describe symbol's function: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-function ,symbol-name))) + +(defface slime-apropos-symbol + '((t (:inherit bold))) + "Face for the symbol name in Apropos output." + :group 'slime) + +(defface slime-apropos-label + '((t (:inherit italic))) + "Face for label (`Function', `Variable' ...) in Apropos output." + :group 'slime) + +(defun slime-apropos-summary (string case-sensitive-p package only-external-p) + "Return a short description for the performed apropos search." + (concat (if case-sensitive-p "Case-sensitive " "") + "Apropos for " + (format "%S" string) + (if package (format " in package %S" package) "") + (if only-external-p " (external symbols only)" ""))) + +(defun slime-apropos (string &optional only-external-p package + case-sensitive-p) + "Show all bound symbols whose names match STRING. With prefix +arg, you're interactively asked for parameters of the search." + (interactive + (if current-prefix-arg + (list (read-string "SLIME Apropos: ") + (y-or-n-p "External symbols only? ") + (let ((pkg (slime-read-package-name "Package: "))) + (if (string= pkg "") nil pkg)) + (y-or-n-p "Case-sensitive? ")) + (list (read-string "SLIME Apropos: ") t nil nil))) + (let ((buffer-package (or package (slime-current-package)))) + (slime-eval-async + `(swank:apropos-list-for-emacs ,string ,only-external-p + ,case-sensitive-p ',package) + (slime-rcurry #'slime-show-apropos string buffer-package + (slime-apropos-summary string case-sensitive-p + package only-external-p))))) + +(defun slime-apropos-all () + "Shortcut for (slime-apropos nil nil)" + (interactive) + (slime-apropos (read-string "SLIME Apropos: ") nil nil)) + +(defun slime-apropos-package (package &optional internal) + "Show apropos listing for symbols in PACKAGE. +With prefix argument include internal symbols." + (interactive (list (let ((pkg (slime-read-package-name "Package: "))) + (if (string= pkg "") (slime-current-package) pkg)) + current-prefix-arg)) + (slime-apropos "" (not internal) package)) + +(autoload 'apropos-mode "apropos") +(defun slime-show-apropos (plists string package summary) + (if (null plists) + (message "No apropos matches for %S" string) + (slime-with-popup-buffer ((slime-buffer-name :apropos) + :package package :connection t + :mode 'apropos-mode) + (if (boundp 'header-line-format) + (setq header-line-format summary) + (insert summary "\n\n")) + (slime-set-truncate-lines) + (slime-print-apropos plists) + (set-syntax-table lisp-mode-syntax-table) + (goto-char (point-min))))) + +(defvar slime-apropos-namespaces + '((:variable "Variable") + (:function "Function") + (:generic-function "Generic Function") + (:macro "Macro") + (:special-operator "Special Operator") + (:setf "Setf") + (:type "Type") + (:class "Class") + (:alien-type "Alien type") + (:alien-struct "Alien struct") + (:alien-union "Alien type") + (:alien-enum "Alien enum"))) + +(defun slime-print-apropos (plists) + (dolist (plist plists) + (let ((designator (plist-get plist :designator))) + (cl-assert designator) + (slime-insert-propertized `(face slime-apropos-symbol) designator)) + (terpri) + (cl-loop for (prop value) on plist by #'cddr + unless (eq prop :designator) do + (let ((namespace (cadr (or (assq prop slime-apropos-namespaces) + (error "Unknown property: %S" prop)))) + (start (point))) + (princ " ") + (slime-insert-propertized `(face slime-apropos-label) namespace) + (princ ": ") + (princ (cl-etypecase value + (string value) + ((member nil :not-documented) "(not documented)"))) + (add-text-properties + start (point) + (list 'type prop 'action 'slime-call-describer + 'button t 'apropos-label namespace + 'item (plist-get plist :designator))) + (terpri))))) + +(defun slime-call-describer (arg) + (let* ((pos (if (markerp arg) arg (point))) + (type (get-text-property pos 'type)) + (item (get-text-property pos 'item))) + (slime-eval-describe `(swank:describe-definition-for-emacs ,item ,type)))) + +(defun slime-info () + "Open Slime manual" + (interactive) + (let ((file (expand-file-name "doc/slime.info" slime-path))) + (if (file-exists-p file) + (info file) + (message "No slime.info, run `make slime.info' in %s" + (expand-file-name "doc/" slime-path))))) + + +;;;; XREF: cross-referencing + +(defvar slime-xref-mode-map) + +(define-derived-mode slime-xref-mode lisp-mode "Xref" + "slime-xref-mode: Major mode for cross-referencing. +\\\ +The most important commands: +\\[slime-xref-quit] - Dismiss buffer. +\\[slime-show-xref] - Display referenced source and keep xref window. +\\[slime-goto-xref] - Jump to referenced source and dismiss xref window. + +\\{slime-xref-mode-map} +\\{slime-popup-buffer-mode-map} +" + (slime-popup-buffer-mode) + (setq font-lock-defaults nil) + (setq delayed-mode-hooks nil) + (slime-mode -1)) + +(slime-define-keys slime-xref-mode-map + ((kbd "RET") 'slime-goto-xref) + ((kbd "SPC") 'slime-goto-xref) + ("v" 'slime-show-xref) + ("n" 'slime-xref-next-line) + ("p" 'slime-xref-prev-line) + ("." 'slime-xref-next-line) + ("," 'slime-xref-prev-line) + ("\C-c\C-c" 'slime-recompile-xref) + ("\C-c\C-k" 'slime-recompile-all-xrefs) + ("\M-," 'slime-xref-retract) + ([remap next-line] 'slime-xref-next-line) + ([remap previous-line] 'slime-xref-prev-line) + ) + + +;;;;; XREF results buffer and window management + +(cl-defmacro slime-with-xref-buffer ((_xref-type _symbol &optional package) + &body body) + "Execute BODY in a xref buffer, then show that buffer." + (declare (indent 1)) + `(slime-with-popup-buffer ((slime-buffer-name :xref) + :package ,package + :connection t + :select t + :mode 'slime-xref-mode) + (slime-set-truncate-lines) + ,@body)) + +(defun slime-insert-xrefs (xref-alist) + "Insert XREF-ALIST in the current-buffer. +XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). +GROUP and LABEL are for decoration purposes. LOCATION is a +source-location." + (cl-loop for (group . refs) in xref-alist do + (slime-insert-propertized '(face bold) group "\n") + (cl-loop for (label location) in refs do + (slime-insert-propertized + (list 'slime-location location + 'face 'font-lock-keyword-face) + " " (slime-one-line-ify label) "\n"))) + ;; Remove the final newline to prevent accidental window-scrolling + (backward-delete-char 1)) + +(defun slime-xref-next-line () + (interactive) + (slime-xref-show-location (slime-search-property 'slime-location))) + +(defun slime-xref-prev-line () + (interactive) + (slime-xref-show-location (slime-search-property 'slime-location t))) + +(defun slime-xref-show-location (loc) + (cl-ecase (car loc) + (:location (slime-show-source-location loc nil 1)) + (:error (message "%s" (cadr loc))) + ((nil)))) + +(defvar slime-next-location-function nil + "Function to call for going to the next location.") + +(defvar slime-previous-location-function nil + "Function to call for going to the previous location.") + +(defvar slime-xref-last-buffer nil + "The most recent XREF results buffer. +This is used by `slime-goto-next-xref'") + +(defun slime-show-xref-buffer (xrefs _type _symbol package) + (slime-with-xref-buffer (_type _symbol package) + (slime-insert-xrefs xrefs) + (setq slime-next-location-function 'slime-goto-next-xref) + (setq slime-previous-location-function 'slime-goto-previous-xref) + (setq slime-xref-last-buffer (current-buffer)) + (goto-char (point-min)))) + +(defun slime-show-xrefs (xrefs type symbol package) + "Show the results of an XREF query." + (if (null xrefs) + (message "No references found for %s." symbol) + (slime-show-xref-buffer xrefs type symbol package))) + + +;;;;; XREF commands + +(defun slime-who-calls (symbol) + "Show all known callers of the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref :calls symbol)) + +(defun slime-calls-who (symbol) + "Show all known functions called by the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref :calls-who symbol)) + +(defun slime-who-references (symbol) + "Show all known referrers of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who references: " t))) + (slime-xref :references symbol)) + +(defun slime-who-binds (symbol) + "Show all known binders of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who binds: " t))) + (slime-xref :binds symbol)) + +(defun slime-who-sets (symbol) + "Show all known setters of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who sets: " t))) + (slime-xref :sets symbol)) + +(defun slime-who-macroexpands (symbol) + "Show all known expanders of the macro SYMBOL." + (interactive (list (slime-read-symbol-name "Who macroexpands: " t))) + (slime-xref :macroexpands symbol)) + +(defun slime-who-specializes (symbol) + "Show all known methods specialized on class SYMBOL." + (interactive (list (slime-read-symbol-name "Who specializes: " t))) + (slime-xref :specializes symbol)) + +(defun slime-list-callers (symbol-name) + "List the callers of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callers: "))) + (slime-xref :callers symbol-name)) + +(defun slime-list-callees (symbol-name) + "List the callees of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callees: "))) + (slime-xref :callees symbol-name)) + +;; FIXME: whats the call (slime-postprocess-xrefs result) good for? +(defun slime-xref (type symbol &optional continuation) + "Make an XREF request to Lisp." + (slime-eval-async + `(swank:xref ',type ',symbol) + (slime-rcurry (lambda (result type symbol package cont) + (slime-check-xref-implemented type result) + (let* ((_xrefs (slime-postprocess-xrefs result)) + (file-alist (cadr (slime-analyze-xrefs result)))) + (funcall (or cont 'slime-show-xrefs) + file-alist type symbol package))) + type + symbol + (slime-current-package) + continuation))) + +(defun slime-check-xref-implemented (type xrefs) + (when (eq xrefs :not-implemented) + (error "%s is not implemented yet on %s." + (slime-xref-type type) + (slime-lisp-implementation-name)))) + +(defun slime-xref-type (type) + (format "who-%s" (slime-cl-symbol-name type))) + +(defun slime-xrefs (types symbol &optional continuation) + "Make multiple XREF requests at once." + (slime-eval-async + `(swank:xrefs ',types ',symbol) + #'(lambda (result) + (funcall (or continuation + #'slime-show-xrefs) + (cl-loop for (key . val) in result + collect (cons (slime-xref-type key) val)) + types symbol (slime-current-package))))) + + +;;;;; XREF navigation + +(defun slime-xref-location-at-point () + (save-excursion + ;; When the end of the last line is at (point-max) we can't find + ;; the text property there. Going to bol avoids this problem. + (beginning-of-line 1) + (or (get-text-property (point) 'slime-location) + (error "No reference at point.")))) + +(defun slime-xref-dspec-at-point () + (save-excursion + (beginning-of-line 1) + (with-syntax-table lisp-mode-syntax-table + (forward-sexp) ; skip initial whitespaces + (backward-sexp) + (slime-sexp-at-point)))) + +(defun slime-all-xrefs () + (let ((xrefs nil)) + (save-excursion + (goto-char (point-min)) + (while (zerop (forward-line 1)) + (let ((loc (get-text-property (point) 'slime-location))) + (when loc + (let* ((dspec (slime-xref-dspec-at-point)) + (xref (make-slime-xref :dspec dspec :location loc))) + (push xref xrefs)))))) + (nreverse xrefs))) + +(defun slime-goto-xref () + "Goto the cross-referenced location at point." + (interactive) + (slime-show-xref) + (quit-window)) + +(defun slime-show-xref () + "Display the xref at point in the other window." + (interactive) + (let ((location (slime-xref-location-at-point))) + (slime-show-source-location location t 1))) + +(defun slime-goto-next-xref (&optional backward) + "Goto the next cross-reference location." + (if (not (buffer-live-p slime-xref-last-buffer)) + (error "No XREF buffer alive.") + (cl-destructuring-bind (location pos) + (with-current-buffer slime-xref-last-buffer + (list (slime-search-property 'slime-location backward) + (point))) + (cond ((slime-location-p location) + (slime-pop-to-location location) + ;; We do this here because changing the location can take + ;; a while when Emacs needs to read a file from disk. + (with-current-buffer slime-xref-last-buffer + (goto-char pos) + (slime-highlight-line 0.35))) + ((null location) + (message (if backward "No previous xref" "No next xref."))) + (t ; error location + (slime-goto-next-xref backward)))))) + +(defun slime-goto-previous-xref () + "Goto the previous cross-reference location." + (slime-goto-next-xref t)) + +(defun slime-search-property (prop &optional backward prop-value-fn) + "Search the next text range where PROP is non-nil. +Return the value of PROP. +If BACKWARD is non-nil, search backward. +If PROP-VALUE-FN is non-nil use it to extract PROP's value." + (let ((next-candidate (if backward + #'previous-single-char-property-change + #'next-single-char-property-change)) + (prop-value-fn (or prop-value-fn + (lambda () + (get-text-property (point) prop)))) + (start (point)) + (prop-value)) + (while (progn + (goto-char (funcall next-candidate (point) prop)) + (not (or (setq prop-value (funcall prop-value-fn)) + (eobp) + (bobp))))) + (cond (prop-value) + (t (goto-char start) nil)))) + +(defun slime-next-location () + "Go to the next location, depending on context. +When displaying XREF information, this goes to the next reference." + (interactive) + (when (null slime-next-location-function) + (error "No context for finding locations.")) + (funcall slime-next-location-function)) + +(defun slime-previous-location () + "Go to the previous location, depending on context. +When displaying XREF information, this goes to the previous reference." + (interactive) + (when (null slime-previous-location-function) + (error "No context for finding locations.")) + (funcall slime-previous-location-function)) + +(defun slime-recompile-xref (&optional raw-prefix-arg) + (interactive "P") + (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) + (let ((location (slime-xref-location-at-point)) + (dspec (slime-xref-dspec-at-point))) + (slime-recompile-locations + (list location) + (slime-rcurry #'slime-xref-recompilation-cont + (list dspec) (current-buffer)))))) + +(defun slime-recompile-all-xrefs (&optional raw-prefix-arg) + (interactive "P") + (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) + (let ((dspecs) (locations)) + (dolist (xref (slime-all-xrefs)) + (when (slime-xref-has-location-p xref) + (push (slime-xref.dspec xref) dspecs) + (push (slime-xref.location xref) locations))) + (slime-recompile-locations + locations + (slime-rcurry #'slime-xref-recompilation-cont + dspecs (current-buffer)))))) + +(defun slime-xref-recompilation-cont (results dspecs buffer) + ;; Extreme long-windedness to insert status of recompilation; + ;; sometimes Elisp resembles more of an Ewwlisp. + + ;; FIXME: Should probably throw out the whole recompilation cruft + ;; anyway. -- helmut + ;; TODO: next iteration of fixme cleanup this is going in a contrib -- jt + (with-current-buffer buffer + (slime-compilation-finished (slime-aggregate-compilation-results results)) + (save-excursion + (slime-xref-insert-recompilation-flags + dspecs (cl-loop for r in results collect + (or (slime-compilation-result.successp r) + (and (slime-compilation-result.notes r) + :complained))))))) + +(defun slime-aggregate-compilation-results (results) + `(:compilation-result + ,(cl-reduce #'append (mapcar #'slime-compilation-result.notes results)) + ,(cl-every #'slime-compilation-result.successp results) + ,(cl-reduce #'+ (mapcar #'slime-compilation-result.duration results)))) + +(defun slime-xref-insert-recompilation-flags (dspecs compilation-results) + (let* ((buffer-read-only nil) + (max-column (slime-column-max))) + (goto-char (point-min)) + (cl-loop for dspec in dspecs + for result in compilation-results + do (save-excursion + (cl-loop for dspec2 = (progn (search-forward dspec) + (slime-xref-dspec-at-point)) + until (equal dspec2 dspec)) + (end-of-line) ; skip old status information. + (insert-char ?\ (1+ (- max-column (current-column)))) + (insert (format "[%s]" + (cl-case result + ((t) :success) + ((nil) :failure) + (t result)))))))) + + +;;;; Macroexpansion + +(define-minor-mode slime-macroexpansion-minor-mode + "SLIME mode for macroexpansion" + nil + " Macroexpand" + '(("g" . slime-macroexpand-again))) + +(cl-macrolet ((remap (from to) + `(dolist (mapping + (where-is-internal ,from slime-mode-map)) + (define-key slime-macroexpansion-minor-mode-map + mapping ,to)))) + (remap 'slime-macroexpand-1 'slime-macroexpand-1-inplace) + (remap 'slime-macroexpand-all 'slime-macroexpand-all-inplace) + (remap 'slime-compiler-macroexpand-1 'slime-compiler-macroexpand-1-inplace) + (remap 'slime-expand-1 + 'slime-expand-1-inplace) + (remap 'advertised-undo 'slime-macroexpand-undo) + (remap 'undo 'slime-macroexpand-undo)) + +(defun slime-macroexpand-undo (&optional arg) + (interactive) + ;; Emacs 22.x introduced `undo-only' which + ;; works by binding `undo-no-redo' to t. We do + ;; it this way so we don't break prior Emacs + ;; versions. + (cl-macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg)))) + (let ((inhibit-read-only t)) + (when (fboundp 'slime-remove-edits) + (slime-remove-edits (point-min) (point-max))) + (undo-only arg)))) + +(defvar slime-eval-macroexpand-expression nil + "Specifies the last macroexpansion preformed. +This variable specifies both what was expanded and how.") + +(defun slime-eval-macroexpand (expander &optional string) + (let ((string (or string (slime-sexp-at-point-or-error)))) + (setq slime-eval-macroexpand-expression `(,expander ,string)) + (slime-eval-async slime-eval-macroexpand-expression + #'slime-initialize-macroexpansion-buffer))) + +(defun slime-macroexpand-again () + "Reperform the last macroexpansion." + (interactive) + (slime-eval-async slime-eval-macroexpand-expression + (slime-rcurry #'slime-initialize-macroexpansion-buffer + (current-buffer)))) + +(defun slime-initialize-macroexpansion-buffer (expansion &optional buffer) + (pop-to-buffer (or buffer (slime-create-macroexpansion-buffer))) + (setq buffer-undo-list nil) ; Get rid of undo information from + ; previous expansions. + (let ((inhibit-read-only t) + (buffer-undo-list t)) ; Make the initial insertion not be undoable. + (erase-buffer) + (insert expansion) + (goto-char (point-min)) + (font-lock-fontify-buffer))) + +(defun slime-create-macroexpansion-buffer () + (let ((name (slime-buffer-name :macroexpansion))) + (slime-with-popup-buffer (name :package t :connection t + :mode 'lisp-mode) + (slime-mode 1) + (slime-macroexpansion-minor-mode 1) + (setq font-lock-keywords-case-fold-search t) + (current-buffer)))) + +(defun slime-eval-macroexpand-inplace (expander) + "Substitute the sexp at point with its macroexpansion. + +NB: Does not affect slime-eval-macroexpand-expression" + (interactive) + (let* ((bounds (or (slime-bounds-of-sexp-at-point) + (user-error "No sexp at point")))) + (lexical-let* ((start (copy-marker (car bounds))) + (end (copy-marker (cdr bounds))) + (point (point)) + (package (slime-current-package)) + (buffer (current-buffer))) + (slime-eval-async + `(,expander ,(buffer-substring-no-properties start end)) + (lambda (expansion) + (with-current-buffer buffer + (let ((buffer-read-only nil)) + (when (fboundp 'slime-remove-edits) + (slime-remove-edits (point-min) (point-max))) + (goto-char start) + (delete-region start end) + (slime-insert-indented expansion) + (goto-char point)))))))) + +(defun slime-macroexpand-1 (&optional repeatedly) + "Display the macro expansion of the form starting at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND." + (interactive "P") + (slime-eval-macroexpand + (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1))) + +(defun slime-macroexpand-1-inplace (&optional repeatedly) + (interactive "P") + (slime-eval-macroexpand-inplace + (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1))) + +(defun slime-macroexpand-all () + "Display the recursively macro expanded sexp starting at +point." + (interactive) + (slime-eval-macroexpand 'swank:swank-macroexpand-all)) + +(defun slime-macroexpand-all-inplace () + "Display the recursively macro expanded sexp starting at point." + (interactive) + (slime-eval-macroexpand-inplace 'swank:swank-macroexpand-all)) + +(defun slime-compiler-macroexpand-1 (&optional repeatedly) + "Display the compiler-macro expansion of sexp starting at point." + (interactive "P") + (slime-eval-macroexpand + (if repeatedly + 'swank:swank-compiler-macroexpand + 'swank:swank-compiler-macroexpand-1))) + +(defun slime-compiler-macroexpand-1-inplace (&optional repeatedly) + "Display the compiler-macro expansion of sexp starting at point." + (interactive "P") + (slime-eval-macroexpand-inplace + (if repeatedly + 'swank:swank-compiler-macroexpand + 'swank:swank-compiler-macroexpand-1))) + +(defun slime-expand-1 (&optional repeatedly) + "Display the macro expansion of the form starting at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND. If the form denotes a +compiler macro, SWANK/BACKEND:COMPILER-MACROEXPAND or +SWANK/BACKEND:COMPILER-MACROEXPAND-1 are used instead." + (interactive "P") + (slime-eval-macroexpand + (if repeatedly + 'swank:swank-expand + 'swank:swank-expand-1))) + +(defun slime-expand-1-inplace (&optional repeatedly) + "Display the macro expansion of the form at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND." + (interactive "P") + (slime-eval-macroexpand-inplace + (if repeatedly + 'swank:swank-expand + 'swank:swank-expand-1))) + +(defun slime-format-string-expand (&optional string) + "Expand the format-string at point and display it." + (interactive (list (or (and (not current-prefix-arg) + (slime-string-at-point)) + (slime-read-from-minibuffer "Expand format: " + (slime-string-at-point))))) + (slime-eval-macroexpand 'swank:swank-format-string-expand string)) + + +;;;; Subprocess control + +(defun slime-interrupt () + "Interrupt Lisp." + (interactive) + (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint)) + (t (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread))))) + +(defun slime-quit () + (error "Not implemented properly. Use `slime-interrupt' instead.")) + +(defun slime-quit-lisp (&optional kill) + "Quit lisp, kill the inferior process and associated buffers." + (interactive "P") + (slime-quit-lisp-internal (slime-connection) 'slime-quit-sentinel kill)) + +(defun slime-quit-lisp-internal (connection sentinel kill) + (let ((slime-dispatching-connection connection)) + (slime-eval-async '(swank:quit-lisp)) + (let* ((process (slime-inferior-process connection))) + (set-process-filter connection nil) + (set-process-sentinel connection sentinel) + (when (and kill process) + (sleep-for 0.2) + (unless (memq (process-status process) '(exit signal)) + (kill-process process)))))) + +(defun slime-quit-sentinel (process _message) + (cl-assert (process-status process) 'closed) + (let* ((inferior (slime-inferior-process process)) + (inferior-buffer (if inferior (process-buffer inferior)))) + (when inferior (delete-process inferior)) + (when inferior-buffer (kill-buffer inferior-buffer)) + (slime-net-close process) + (message "Connection closed."))) + + +;;;; Debugger (SLDB) + +(defvar sldb-hook nil + "Hook run on entry to the debugger.") + +(defcustom sldb-initial-restart-limit 6 + "Maximum number of restarts to display initially." + :group 'slime-debugger + :type 'integer) + + +;;;;; Local variables in the debugger buffer + +;; Small helper. +(defun slime-make-variables-buffer-local (&rest variables) + (mapcar #'make-variable-buffer-local variables)) + +(slime-make-variables-buffer-local + (defvar sldb-condition nil + "A list (DESCRIPTION TYPE) describing the condition being debugged.") + + (defvar sldb-restarts nil + "List of (NAME DESCRIPTION) for each available restart.") + + (defvar sldb-level nil + "Current debug level (recursion depth) displayed in buffer.") + + (defvar sldb-backtrace-start-marker nil + "Marker placed at the first frame of the backtrace.") + + (defvar sldb-restart-list-start-marker nil + "Marker placed at the first restart in the restart list.") + + (defvar sldb-continuations nil + "List of ids for pending continuation.")) + +;;;;; SLDB macros + +;; some macros that we need to define before the first use + +(defmacro sldb-in-face (name string) + "Return STRING propertised with face sldb-NAME-face." + (declare (indent 1)) + (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))) + (var (cl-gensym "string"))) + `(let ((,var ,string)) + (slime-add-face ',facename ,var) + ,var))) + + +;;;;; sldb-mode + +(defvar sldb-mode-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 enables autodoc-mode to match + ;; # actual arguments in the backtraces with formal + ;; arguments of the function. (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 SLDB mode.") + +(define-derived-mode sldb-mode fundamental-mode "sldb" + "Superior lisp debugger mode. +In addition to ordinary SLIME commands, the following are +available:\\ + +Commands to examine the selected frame: + \\[sldb-toggle-details] - toggle details (local bindings, CATCH tags) + \\[sldb-show-source] - view source for the frame + \\[sldb-eval-in-frame] - eval in frame + \\[sldb-pprint-eval-in-frame] - eval in frame, pretty-print result + \\[sldb-disassemble] - disassemble + \\[sldb-inspect-in-frame] - inspect + +Commands to invoke restarts: + \\[sldb-quit] - quit + \\[sldb-abort] - abort + \\[sldb-continue] - continue + \\[sldb-invoke-restart-0]-\\[sldb-invoke-restart-9] - restart shortcuts + \\[sldb-invoke-restart-by-name] - invoke restart by name + +Commands to navigate frames: + \\[sldb-down] - down + \\[sldb-up] - up + \\[sldb-details-down] - down, with details + \\[sldb-details-up] - up, with details + \\[sldb-cycle] - cycle between restarts & backtrace + \\[sldb-beginning-of-backtrace] - beginning of backtrace + \\[sldb-end-of-backtrace] - end of backtrace + +Miscellaneous commands: + \\[sldb-restart-frame] - restart frame + \\[sldb-return-from-frame] - return from frame + \\[sldb-step] - step + \\[sldb-break-with-default-debugger] - switch to native debugger + \\[sldb-break-with-system-debugger] - switch to system debugger (gdb) + \\[slime-interactive-eval] - eval + \\[sldb-inspect-condition] - inspect signalled condition + +Full list of commands: + +\\{sldb-mode-map}" + (erase-buffer) + (set-syntax-table sldb-mode-syntax-table) + (slime-set-truncate-lines) + ;; Make original slime-connection "sticky" for SLDB commands in this buffer + (setq slime-buffer-connection (slime-connection))) + +(set-keymap-parent sldb-mode-map slime-parent-map) + +(slime-define-keys sldb-mode-map + + ((kbd "RET") 'sldb-default-action) + ("\C-m" 'sldb-default-action) + ([return] 'sldb-default-action) + ([mouse-2] 'sldb-default-action/mouse) + ([follow-link] 'mouse-face) + ("\C-i" 'sldb-cycle) + ("h" 'describe-mode) + ("v" 'sldb-show-source) + ("e" 'sldb-eval-in-frame) + ("d" 'sldb-pprint-eval-in-frame) + ("D" 'sldb-disassemble) + ("i" 'sldb-inspect-in-frame) + ("n" 'sldb-down) + ("p" 'sldb-up) + ("\M-n" 'sldb-details-down) + ("\M-p" 'sldb-details-up) + ("<" 'sldb-beginning-of-backtrace) + (">" 'sldb-end-of-backtrace) + ("t" 'sldb-toggle-details) + ("r" 'sldb-restart-frame) + ("I" 'sldb-invoke-restart-by-name) + ("R" 'sldb-return-from-frame) + ("c" 'sldb-continue) + ("s" 'sldb-step) + ("x" 'sldb-next) + ("o" 'sldb-out) + ("b" 'sldb-break-on-return) + ("a" 'sldb-abort) + ("q" 'sldb-quit) + ("A" 'sldb-break-with-system-debugger) + ("B" 'sldb-break-with-default-debugger) + ("P" 'sldb-print-condition) + ("C" 'sldb-inspect-condition) + (":" 'slime-interactive-eval) + ("\C-c\C-c" 'sldb-recompile-frame-source)) + +;; Keys 0-9 are shortcuts to invoke particular restarts. +(dotimes (number 10) + (let ((fname (intern (format "sldb-invoke-restart-%S" number))) + (docstring (format "Invoke restart numbered %S." number))) + (eval `(defun ,fname () + ,docstring + (interactive) + (sldb-invoke-restart ,number))) + (define-key sldb-mode-map (number-to-string number) fname))) + + +;;;;; SLDB buffer creation & update + +(defun sldb-buffers (&optional connection) + "Return a list of all sldb buffers (belonging to CONNECTION.)" + (if connection + (slime-filter-buffers (lambda () + (and (eq slime-buffer-connection connection) + (eq major-mode 'sldb-mode)))) + (slime-filter-buffers (lambda () (eq major-mode 'sldb-mode))))) + +(defun sldb-find-buffer (thread &optional connection) + (let ((connection (or connection (slime-connection)))) + (cl-find-if (lambda (buffer) + (with-current-buffer buffer + (and (eq slime-buffer-connection connection) + (eq slime-current-thread thread)))) + (sldb-buffers)))) + +(defun sldb-get-default-buffer () + "Get a sldb buffer. +The chosen buffer the default connection's it if exists." + (car (sldb-buffers slime-default-connection))) + +(defun sldb-get-buffer (thread &optional connection) + "Find or create a sldb-buffer for THREAD." + (let ((connection (or connection (slime-connection)))) + (or (sldb-find-buffer thread connection) + (let ((name (format "*sldb %s/%s*" (slime-connection-name) thread))) + (with-current-buffer (generate-new-buffer name) + (setq slime-buffer-connection connection + slime-current-thread thread) + (current-buffer)))))) + +(defun sldb-debugged-continuations (connection) + "Return the all debugged continuations for CONNECTION across SLDB buffers." + (cl-loop for b in (sldb-buffers) + append (with-current-buffer b + (and (eq slime-buffer-connection connection) + sldb-continuations)))) + +(defun sldb--display-buffer-reuse-last-window (buffer _alist) + (let ((window + (get-window-with-predicate (lambda (w) + (window-parameter w 'sldb-last-window))))) + (when (and window + (not (with-current-buffer (window-buffer window) + (derived-mode-p 'sldb-mode)))) + (display-buffer-record-window 'reuse window buffer) + (set-window-buffer window buffer) + window))) + +(defun sldb-display-buffer (buffer) + "Pop to BUFFER reusing the last SLDB window, if any." + (pop-to-buffer buffer '(sldb--display-buffer-reuse-last-window))) + +(defun sldb-setup (thread level condition restarts frames conts) + "Setup a new SLDB buffer. +CONDITION is a string describing the condition to debug. +RESTARTS is a list of strings (NAME DESCRIPTION) for each available restart. +FRAMES is a list (NUMBER DESCRIPTION &optional PLIST) describing the initial +portion of the backtrace. Frames are numbered from 0. +CONTS is a list of pending Emacs continuations." + (with-current-buffer (sldb-get-buffer thread) + (cl-assert (if (equal sldb-level level) + (equal sldb-condition condition) + t) + () "Bug: sldb-level is equal but condition differs\n%s\n%s" + sldb-condition condition) + (unless (equal sldb-level level) + (setq buffer-read-only nil) + (sldb-mode) + (setq slime-current-thread thread) + (setq sldb-level level) + (setq mode-name (format "sldb[%d]" sldb-level)) + (setq sldb-condition condition) + (setq sldb-restarts restarts) + (setq sldb-continuations conts) + (sldb-insert-condition condition) + (insert "\n\n" (sldb-in-face section "Restarts:") "\n") + (setq sldb-restart-list-start-marker (point-marker)) + (sldb-insert-restarts restarts 0 sldb-initial-restart-limit) + (insert "\n" (sldb-in-face section "Backtrace:") "\n") + (setq sldb-backtrace-start-marker (point-marker)) + (save-excursion + (if frames + (sldb-insert-frames (sldb-prune-initial-frames frames) t) + (insert "[No backtrace]"))) + (run-hooks 'sldb-hook) + (set-syntax-table lisp-mode-syntax-table)) + ;; FIXME: remove when dropping Emacs23 support + (let ((saved (selected-window))) + (sldb-display-buffer (current-buffer)) + (set-window-parameter (selected-window) 'sldb-restore saved)) + (unless noninteractive ; needed for tests in batch-mode + (slime--display-region (point-min) (point))) + (setq buffer-read-only t) + (when (and slime-stack-eval-tags + ;; (y-or-n-p "Enter recursive edit? ") + ) + (message "Entering recursive edit..") + (recursive-edit)))) + +(defun sldb-activate (thread level select) + "Display the debugger buffer for THREAD. +If LEVEL isn't the same as in the buffer reinitialize the buffer." + (or (let ((buffer (sldb-find-buffer thread))) + (when buffer + (with-current-buffer buffer + (when (equal sldb-level level) + (when select (pop-to-buffer (current-buffer))) + t)))) + (sldb-reinitialize thread level))) + +(defun sldb-reinitialize (thread level) + (slime-rex (thread level) + ('(swank:debugger-info-for-emacs 0 10) + nil thread) + ((:ok result) + (apply #'sldb-setup thread level result)))) + +(defun sldb--mark-last-window (window) + (dolist (window (window-list)) + (when (window-parameter window 'sldb-last-window) + (set-window-parameter window 'sldb-last-window nil))) + (set-window-parameter (selected-window) 'sldb-last-window t)) + +(defun sldb-exit (thread _level &optional stepping) + "Exit from the debug level LEVEL." + (let ((sldb (sldb-find-buffer thread))) + (when sldb + (with-current-buffer sldb + (cond (stepping + (setq sldb-level nil) + (run-with-timer 0.4 nil 'sldb-close-step-buffer sldb)) + ((not (eq sldb (window-buffer (selected-window)))) + ;; A different window selection means an indirect, + ;; non-interactive exit, we just kill the sldb buffer. + (kill-buffer)) + (t + (sldb--mark-last-window (selected-window)) + ;; An interactive exit should restore configuration per + ;; `quit-window's protocol. FIXME: remove + ;; `previous-window' hack when dropping Emacs23 support + (let ((previous-window (window-parameter (selected-window) + 'sldb-restore))) + (quit-window t) + (if (and (not (>= emacs-major-version 24)) + (window-live-p previous-window)) + (select-window previous-window))))))))) + +(defun sldb-close-step-buffer (buffer) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when (not sldb-level) + (quit-window t))))) + + +;;;;;; SLDB buffer insertion + +(defun sldb-insert-condition (condition) + "Insert the text for CONDITION. +CONDITION should be a list (MESSAGE TYPE EXTRAS). +EXTRAS is currently used for the stepper." + (cl-destructuring-bind (message type extras) condition + (slime-insert-propertized '(sldb-default-action sldb-inspect-condition) + (sldb-in-face topline message) + "\n" + (sldb-in-face condition type)) + (sldb-dispatch-extras extras))) + +(defvar sldb-extras-hooks) + +(defun sldb-dispatch-extras (extras) + ;; this is (mis-)used for the stepper + (dolist (extra extras) + (slime-dcase extra + ((:show-frame-source n) + (sldb-show-frame-source n)) + (t + (or (run-hook-with-args-until-success 'sldb-extras-hooks extra) + ;;(error "Unhandled extra element:" extra) + ))))) + +(defun sldb-insert-restarts (restarts start count) + "Insert RESTARTS and add the needed text props +RESTARTS should be a list ((NAME DESCRIPTION) ...)." + (let* ((len (length restarts)) + (end (if count (min (+ start count) len) len))) + (cl-loop for (name string) in (cl-subseq restarts start end) + for number from start + do (slime-insert-propertized + `(,@nil restart ,number + sldb-default-action sldb-invoke-restart + mouse-face highlight) + " " (sldb-in-face restart-number (number-to-string number)) + ": [" (sldb-in-face restart-type name) "] " + (sldb-in-face restart string)) + (insert "\n")) + (when (< end len) + (let ((pos (point))) + (slime-insert-propertized + (list 'sldb-default-action + (slime-rcurry #'sldb-insert-more-restarts restarts pos end)) + " --more--\n"))))) + +(defun sldb-insert-more-restarts (restarts position start) + (goto-char position) + (let ((inhibit-read-only t)) + (delete-region position (1+ (line-end-position))) + (sldb-insert-restarts restarts start nil))) + +(defun sldb-frame.string (frame) + (cl-destructuring-bind (_ str &optional _) frame str)) + +(defun sldb-frame.number (frame) + (cl-destructuring-bind (n _ &optional _) frame n)) + +(defun sldb-frame.plist (frame) + (cl-destructuring-bind (_ _ &optional plist) frame plist)) + +(defun sldb-frame-restartable-p (frame) + (and (plist-get (sldb-frame.plist frame) :restartable) t)) + +(defun sldb-prune-initial-frames (frames) + "Return the prefix of FRAMES to initially present to the user. +Regexp heuristics are used to avoid showing SWANK-internal frames." + (let* ((case-fold-search t) + (rx "^\\([() ]\\|lambda\\)*swank\\>")) + (or (cl-loop for frame in frames + until (string-match rx (sldb-frame.string frame)) + collect frame) + frames))) + +(defun sldb-insert-frames (frames more) + "Insert FRAMES into buffer. +If MORE is non-nil, more frames are on the Lisp stack." + (mapc #'sldb-insert-frame frames) + (when more + (slime-insert-propertized + `(,@nil sldb-default-action sldb-fetch-more-frames + sldb-previous-frame-number + ,(sldb-frame.number (cl-first (last frames))) + point-entered sldb-fetch-more-frames + start-open t + face sldb-section-face + mouse-face highlight) + " --more--") + (insert "\n"))) + +(defun sldb-compute-frame-face (frame) + (if (sldb-frame-restartable-p frame) + 'sldb-restartable-frame-line-face + 'sldb-frame-line-face)) + +(defun sldb-insert-frame (frame &optional face) + "Insert FRAME with FACE at point. +If FACE is nil, `sldb-compute-frame-face' is used to determine the face." + (setq face (or face (sldb-compute-frame-face frame))) + (let ((number (sldb-frame.number frame)) + (string (sldb-frame.string frame)) + (props `(frame ,frame sldb-default-action sldb-toggle-details))) + (slime-propertize-region props + (slime-propertize-region '(mouse-face highlight) + (insert " " (sldb-in-face frame-label (format "%2d:" number)) " ") + (slime-insert-indented + (slime-add-face face string))) + (insert "\n")))) + +(defun sldb-fetch-more-frames (&rest _) + "Fetch more backtrace frames. +Called on the `point-entered' text-property hook." + (let ((inhibit-point-motion-hooks t) + (inhibit-read-only t) + (prev (get-text-property (point) 'sldb-previous-frame-number))) + ;; we may be called twice, PREV is nil the second time + (when prev + (let* ((count 40) + (from (1+ prev)) + (to (+ from count)) + (frames (slime-eval `(swank:backtrace ,from ,to))) + (more (slime-length= frames count)) + (pos (point))) + (delete-region (line-beginning-position) (point-max)) + (sldb-insert-frames frames more) + (goto-char pos))))) + + +;;;;;; SLDB examining text props + +(defun sldb-restart-at-point () + (or (get-text-property (point) 'restart) + (error "No restart at point"))) + +(defun sldb-frame-number-at-point () + (let ((frame (get-text-property (point) 'frame))) + (cond (frame (car frame)) + (t (error "No frame at point"))))) + +(defun sldb-var-number-at-point () + (let ((var (get-text-property (point) 'var))) + (cond (var var) + (t (error "No variable at point"))))) + +(defun sldb-previous-frame-number () + (save-excursion + (sldb-backward-frame) + (sldb-frame-number-at-point))) + +(defun sldb-frame-details-visible-p () + (and (get-text-property (point) 'frame) + (get-text-property (point) 'details-visible-p))) + +(defun sldb-frame-region () + (slime-property-bounds 'frame)) + +(defun sldb-forward-frame () + (goto-char (next-single-char-property-change (point) 'frame))) + +(defun sldb-backward-frame () + (when (> (point) sldb-backtrace-start-marker) + (goto-char (previous-single-char-property-change + (if (get-text-property (point) 'frame) + (car (sldb-frame-region)) + (point)) + 'frame + nil sldb-backtrace-start-marker)))) + +(defun sldb-goto-last-frame () + (goto-char (point-max)) + (while (not (get-text-property (point) 'frame)) + (goto-char (previous-single-property-change (point) 'frame)) + ;; Recenter to bottom of the window; -2 to account for the + ;; empty last line displayed in sldb buffers. + (recenter -2))) + +(defun sldb-beginning-of-backtrace () + "Goto the first frame." + (interactive) + (goto-char sldb-backtrace-start-marker)) + + +;;;;;; SLDB recenter & redisplay +;; not sure yet, whether this is a good idea. +;; +;; jt: seconded. Only `sldb-show-frame-details' and +;; `sldb-hide-frame-details' use this. They could avoid it by not +;; removing and reinserting the frame's name line. +(defmacro slime-save-coordinates (origin &rest body) + "Restore line and column relative to ORIGIN, after executing BODY. + +This is useful if BODY deletes and inserts some text but we want to +preserve the current row and column as closely as possible." + (let ((base (make-symbol "base")) + (goal (make-symbol "goal")) + (mark (make-symbol "mark"))) + `(let* ((,base ,origin) + (,goal (slime-coordinates ,base)) + (,mark (point-marker))) + (set-marker-insertion-type ,mark t) + (prog1 (save-excursion ,@body) + (slime-restore-coordinate ,base ,goal ,mark))))) + +(put 'slime-save-coordinates 'lisp-indent-function 1) + +(defun slime-coordinates (origin) + ;; Return a pair (X . Y) for the column and line distance to ORIGIN. + (let ((y (slime-count-lines origin (point))) + (x (save-excursion + (- (current-column) + (progn (goto-char origin) (current-column)))))) + (cons x y))) + +(defun slime-restore-coordinate (base goal limit) + ;; Move point to GOAL. Coordinates are relative to BASE. + ;; Don't move beyond LIMIT. + (save-restriction + (narrow-to-region base limit) + (goto-char (point-min)) + (let ((col (current-column))) + (forward-line (cdr goal)) + (when (and (eobp) (bolp) (not (bobp))) + (backward-char)) + (move-to-column (+ col (car goal)))))) + +(defun slime-count-lines (start end) + "Return the number of lines between START and END. +This is 0 if START and END at the same line." + (- (count-lines start end) + (if (save-excursion (goto-char end) (bolp)) 0 1))) + + +;;;;; SLDB commands + +(defun sldb-default-action () + "Invoke the action at point." + (interactive) + (let ((fn (get-text-property (point) 'sldb-default-action))) + (if fn (funcall fn)))) + +(defun sldb-default-action/mouse (event) + "Invoke the action pointed at by the mouse." + (interactive "e") + (cl-destructuring-bind (_mouse-1 (_w pos &rest ignore)) event + (save-excursion + (goto-char pos) + (let ((fn (get-text-property (point) 'sldb-default-action))) + (if fn (funcall fn)))))) + +(defun sldb-cycle () + "Cycle between restart list and backtrace." + (interactive) + (let ((pt (point))) + (cond ((< pt sldb-restart-list-start-marker) + (goto-char sldb-restart-list-start-marker)) + ((< pt sldb-backtrace-start-marker) + (goto-char sldb-backtrace-start-marker)) + (t + (goto-char sldb-restart-list-start-marker))))) + +(defun sldb-end-of-backtrace () + "Fetch the entire backtrace and go to the last frame." + (interactive) + (sldb-fetch-all-frames) + (sldb-goto-last-frame)) + +(defun sldb-fetch-all-frames () + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (sldb-goto-last-frame) + (let ((last (sldb-frame-number-at-point))) + (goto-char (next-single-char-property-change (point) 'frame)) + (delete-region (point) (point-max)) + (save-excursion + (sldb-insert-frames (slime-eval `(swank:backtrace ,(1+ last) nil)) + nil))))) + + +;;;;;; SLDB show source + +(defun sldb-show-source () + "Highlight the frame at point's expression in a source code buffer." + (interactive) + (sldb-show-frame-source (sldb-frame-number-at-point))) + +(defun sldb-show-frame-source (frame-number) + (slime-eval-async + `(swank:frame-source-location ,frame-number) + (lambda (source-location) + (slime-dcase source-location + ((:error message) + (message "%s" message) + (ding)) + (t + (slime-show-source-location source-location t nil)))))) + +(defun slime-show-source-location (source-location + &optional highlight recenter-arg) + "Go to SOURCE-LOCATION and display the buffer in the other window." + (slime-goto-source-location source-location) + ;; show the location, but don't hijack focus. + (slime--display-position (point) t recenter-arg) + (when highlight (slime-highlight-sexp))) + +(defun slime--display-position (pos other-window recenter-arg) + (with-selected-window (display-buffer (current-buffer) other-window) + (goto-char pos) + (recenter recenter-arg))) + +;; Set window-start so that the region from START to END becomes visible. +;; START is inclusive; END is exclusive. +(defun slime--adjust-window-start (start end) + (let* ((last (max start (1- end))) + (window-height (window-text-height)) + (region-height (count-screen-lines start last t))) + ;; if needed, make the region visible + (when (or (not (pos-visible-in-window-p start)) + (not (pos-visible-in-window-p last))) + (let* ((nlines (cond ((or (< start (window-start)) + (>= region-height window-height)) + 0) + (t + (- region-height))))) + (goto-char start) + (recenter nlines))) + (cl-assert (pos-visible-in-window-p start)) + (cl-assert (or (pos-visible-in-window-p last) + (> region-height window-height))) + (cl-assert (pos-visible-in-window-p (1- (window-end nil t)) nil t)))) + +;; move POS to visible region +(defun slime--adjust-window-point (pos) + (cond ((pos-visible-in-window-p pos) + (goto-char pos)) + ((< pos (window-start)) + (goto-char (window-start))) + (t + (goto-char (1- (window-end nil t))) + (move-to-column 0))) + (cl-assert (pos-visible-in-window-p (point) nil t))) + +(defun slime--display-region (start end) + "Make the region from START to END visible. +Minimize point motion." + (cl-assert (<= start end)) + (cl-assert (eq (window-buffer (selected-window)) + (current-buffer))) + (let ((pos (point))) + (slime--adjust-window-start start end) + (slime--adjust-window-point pos))) + +(defun slime-highlight-sexp (&optional start end) + "Highlight the first sexp after point." + (let ((start (or start (point))) + (end (or end (save-excursion (ignore-errors (forward-sexp)) (point))))) + (slime-flash-region start end))) + +(defun slime-highlight-line (&optional timeout) + (slime-flash-region (+ (line-beginning-position) (current-indentation)) + (line-end-position) + timeout)) + + +;;;;;; SLDB toggle details + +(defun sldb-toggle-details (&optional on) + "Toggle display of details for the current frame. +The details include local variable bindings and CATCH-tags." + (interactive) + (cl-assert (sldb-frame-number-at-point)) + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (if (or on (not (sldb-frame-details-visible-p))) + (sldb-show-frame-details) + (sldb-hide-frame-details)))) + +(defun sldb-show-frame-details () + ;; fetch and display info about local variables and catch tags + (cl-destructuring-bind (start end frame locals catches) (sldb-frame-details) + (slime-save-coordinates start + (delete-region start end) + (slime-propertize-region `(frame ,frame details-visible-p t) + (sldb-insert-frame frame (if (sldb-frame-restartable-p frame) + 'sldb-restartable-frame-line-face + ;; FIXME: can we somehow merge the two? + 'sldb-detailed-frame-line-face)) + (let ((indent1 " ") + (indent2 " ")) + (insert indent1 (sldb-in-face section + (if locals "Locals:" "[No Locals]")) "\n") + (sldb-insert-locals locals indent2 frame) + (when catches + (insert indent1 (sldb-in-face section "Catch-tags:") "\n") + (dolist (tag catches) + (slime-propertize-region `(catch-tag ,tag) + (insert indent2 (sldb-in-face catch-tag (format "%s" tag)) + "\n")))) + (setq end (point))))) + (slime--display-region (point) end))) + +(defun sldb-frame-details () + ;; Return a list (START END FRAME LOCALS CATCHES) for frame at point. + (let* ((frame (get-text-property (point) 'frame)) + (num (car frame))) + (cl-destructuring-bind (start end) (sldb-frame-region) + (cl-list* start end frame + (slime-eval `(swank:frame-locals-and-catch-tags ,num)))))) + +(defvar sldb-insert-frame-variable-value-function + 'sldb-insert-frame-variable-value) + +(defun sldb-insert-locals (vars prefix frame) + "Insert VARS and add PREFIX at the beginning of each inserted line. +VAR should be a plist with the keys :name, :id, and :value." + (cl-loop for i from 0 + for var in vars do + (cl-destructuring-bind (&key name id value) var + (slime-propertize-region + (list 'sldb-default-action 'sldb-inspect-var 'var i) + (insert prefix + (sldb-in-face local-name + (concat name (if (zerop id) "" (format "#%d" id)))) + " = ") + (funcall sldb-insert-frame-variable-value-function + value frame i) + (insert "\n"))))) + +(defun sldb-insert-frame-variable-value (value _frame _index) + (insert (sldb-in-face local-value value))) + +(defun sldb-hide-frame-details () + ;; delete locals and catch tags, but keep the function name and args. + (cl-destructuring-bind (start end) (sldb-frame-region) + (let ((frame (get-text-property (point) 'frame))) + (slime-save-coordinates start + (delete-region start end) + (slime-propertize-region '(details-visible-p nil) + (sldb-insert-frame frame)))))) + +(defun sldb-disassemble () + "Disassemble the code for the current frame." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-disassemble ,frame) + (lambda (result) + (slime-show-description result nil))))) + + +;;;;;; SLDB eval and inspect + +(defun sldb-eval-in-frame (frame string package) + "Prompt for an expression and evaluate it in the selected frame." + (interactive (sldb-read-form-for-frame "Eval in frame (%s)> ")) + (slime-eval-async `(swank:eval-string-in-frame ,string ,frame ,package) + (if current-prefix-arg + 'slime-write-string + 'slime-display-eval-result))) + +(defun sldb-pprint-eval-in-frame (frame string package) + "Prompt for an expression, evaluate in selected frame, pretty-print result." + (interactive (sldb-read-form-for-frame "Eval in frame (%s)> ")) + (slime-eval-async + `(swank:pprint-eval-string-in-frame ,string ,frame ,package) + (lambda (result) + (slime-show-description result nil)))) + +(defun sldb-read-form-for-frame (fstring) + (let* ((frame (sldb-frame-number-at-point)) + (pkg (slime-eval `(swank:frame-package-name ,frame)))) + (list frame + (let ((slime-buffer-package pkg)) + (slime-read-from-minibuffer (format fstring pkg))) + pkg))) + +(defun sldb-inspect-in-frame (string) + "Prompt for an expression and inspect it in the selected frame." + (interactive (list (slime-read-from-minibuffer + "Inspect in frame (evaluated): " + (slime-sexp-at-point)))) + (let ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:inspect-in-frame ,string ,number) + 'slime-open-inspector))) + +(defun sldb-inspect-var () + (let ((frame (sldb-frame-number-at-point)) + (var (sldb-var-number-at-point))) + (slime-eval-async `(swank:inspect-frame-var ,frame ,var) + 'slime-open-inspector))) + +(defun sldb-inspect-condition () + "Inspect the current debugger condition." + (interactive) + (slime-eval-async '(swank:inspect-current-condition) + 'slime-open-inspector)) + +(defun sldb-print-condition () + (interactive) + (slime-eval-describe `(swank:sdlb-print-condition))) + + +;;;;;; SLDB movement + +(defun sldb-down () + "Select next frame." + (interactive) + (sldb-forward-frame)) + +(defun sldb-up () + "Select previous frame." + (interactive) + (sldb-backward-frame) + (when (= (point) sldb-backtrace-start-marker) + (recenter (1+ (count-lines (point-min) (point)))))) + +(defun sldb-sugar-move (move-fn) + (let ((inhibit-read-only t)) + (when (sldb-frame-details-visible-p) (sldb-hide-frame-details)) + (funcall move-fn) + (sldb-show-source) + (sldb-toggle-details t))) + +(defun sldb-details-up () + "Select previous frame and show details." + (interactive) + (sldb-sugar-move 'sldb-up)) + +(defun sldb-details-down () + "Select next frame and show details." + (interactive) + (sldb-sugar-move 'sldb-down)) + + +;;;;;; SLDB restarts + +(defun sldb-quit () + "Quit to toplevel." + (interactive) + (cl-assert sldb-restarts () "sldb-quit called outside of sldb buffer") + (slime-rex () ('(swank:throw-to-toplevel)) + ((:ok x) (error "sldb-quit returned [%s]" x)) + ((:abort _)))) + +(defun sldb-continue () + "Invoke the \"continue\" restart." + (interactive) + (cl-assert sldb-restarts () "sldb-continue called outside of sldb buffer") + (slime-rex () + ('(swank:sldb-continue)) + ((:ok _) + (message "No restart named continue") + (ding)) + ((:abort _)))) + +(defun sldb-abort () + "Invoke the \"abort\" restart." + (interactive) + (slime-eval-async '(swank:sldb-abort) + (lambda (v) (message "Restart returned: %S" v)))) + +(defun sldb-invoke-restart (&optional number) + "Invoke a restart. +Optional NUMBER (index into `sldb-restarts') specifies the +restart to invoke, otherwise use the restart at point." + (interactive) + (let ((restart (or number (sldb-restart-at-point)))) + (slime-rex () + ((list 'swank:invoke-nth-restart-for-emacs sldb-level restart)) + ((:ok value) (message "Restart returned: %s" value)) + ((:abort _))))) + +(defun sldb-invoke-restart-by-name (restart-name) + (interactive (list (let ((completion-ignore-case t)) + (completing-read "Restart: " sldb-restarts nil t + "" + 'sldb-invoke-restart-by-name)))) + (sldb-invoke-restart (cl-position restart-name sldb-restarts + :test 'string= :key 'first))) + +(defun sldb-break-with-default-debugger (&optional dont-unwind) + "Enter default debugger." + (interactive "P") + (slime-rex () + ((list 'swank:sldb-break-with-default-debugger + (not (not dont-unwind))) + nil slime-current-thread) + ((:abort _)))) + +(defun sldb-break-with-system-debugger (&optional lightweight) + "Enter system debugger (gdb)." + (interactive "P") + (slime-attach-gdb slime-buffer-connection lightweight)) + +(defun slime-attach-gdb (connection &optional lightweight) + "Run `gud-gdb'on the connection with PID `pid'. + +If `lightweight' is given, do not send any request to the +inferior Lisp (e.g. to obtain default gdb config) but only +operate from the Emacs side; intended for cases where the Lisp is +truly screwed up." + (interactive + (list (slime-read-connection "Attach gdb to: " (slime-connection)) "P")) + (let ((pid (slime-pid connection)) + (file (slime-lisp-implementation-program connection)) + (commands (unless lightweight + (let ((slime-dispatching-connection connection)) + (slime-eval `(swank:gdb-initial-commands)))))) + (gud-gdb (format "gdb -p %d %s" pid (or file ""))) + (with-current-buffer gud-comint-buffer + (dolist (cmd commands) + ;; First wait until gdb was initialized, then wait until current + ;; command was processed. + (while (not (looking-back comint-prompt-regexp nil)) + (sit-for 0.01)) + ;; We do not use `gud-call' because we want the initial commands + ;; to be displayed by the user so he knows what he's got. + (insert cmd) + (comint-send-input))))) + +(defun slime-read-connection (prompt &optional initial-value) + "Read a connection from the minibuffer. +Return the net process, or nil." + (cl-assert (memq initial-value slime-net-processes)) + (let* ((to-string (lambda (p) + (format "%s (pid %d)" + (slime-connection-name p) (slime-pid p)))) + (candidates (mapcar (lambda (p) (cons (funcall to-string p) p)) + slime-net-processes))) + (cdr (assoc (completing-read prompt candidates + nil t (funcall to-string initial-value)) + candidates)))) + +(defun sldb-step () + "Step to next basic-block boundary." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-step ,frame)))) + +(defun sldb-next () + "Step over call." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-next ,frame)))) + +(defun sldb-out () + "Resume stepping after returning from this function." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-out ,frame)))) + +(defun sldb-break-on-return () + "Set a breakpoint at the current frame. +The debugger is entered when the frame exits." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-break-on-return ,frame) + (lambda (msg) (message "%s" msg))))) + +(defun sldb-break (name) + "Set a breakpoint at the start of the function NAME." + (interactive (list (slime-read-symbol-name "Function: " t))) + (slime-eval-async `(swank:sldb-break ,name) + (lambda (msg) (message "%s" msg)))) + +(defun sldb-return-from-frame (string) + "Reads an expression in the minibuffer and causes the function to +return that value, evaluated in the context of the frame." + (interactive (list (slime-read-from-minibuffer "Return from frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-rex () + ((list 'swank:sldb-return-from-frame number string)) + ((:ok value) (message "%s" value)) + ((:abort _))))) + +(defun sldb-restart-frame () + "Causes the frame to restart execution with the same arguments as it +was called originally." + (interactive) + (let* ((number (sldb-frame-number-at-point))) + (slime-rex () + ((list 'swank:restart-frame number)) + ((:ok value) (message "%s" value)) + ((:abort _))))) + +(defun slime-toggle-break-on-signals () + "Toggle the value of *break-on-signals*." + (interactive) + (slime-eval-async `(swank:toggle-break-on-signals) + (lambda (msg) (message "%s" msg)))) + + +;;;;;; SLDB recompilation commands + +(defun sldb-recompile-frame-source (&optional raw-prefix-arg) + (interactive "P") + (slime-eval-async + `(swank:frame-source-location ,(sldb-frame-number-at-point)) + (lexical-let ((policy (slime-compute-policy raw-prefix-arg))) + (lambda (source-location) + (slime-dcase source-location + ((:error message) + (message "%s" message) + (ding)) + (t + (let ((slime-compilation-policy policy)) + (slime-recompile-location source-location)))))))) + + +;;;; Thread control panel + +(defvar slime-threads-buffer-name (slime-buffer-name :threads)) +(defvar slime-threads-buffer-timer nil) + +(defcustom slime-threads-update-interval nil + "Interval at which the list of threads will be updated." + :type '(choice + (number :value 0.5) + (const nil)) + :group 'slime-ui) + +(defun slime-list-threads () + "Display a list of threads." + (interactive) + (let ((name slime-threads-buffer-name)) + (slime-with-popup-buffer (name :connection t + :mode 'slime-thread-control-mode) + (slime-update-threads-buffer) + (goto-char (point-min)) + (when slime-threads-update-interval + (when slime-threads-buffer-timer + (cancel-timer slime-threads-buffer-timer)) + (setq slime-threads-buffer-timer + (run-with-timer + slime-threads-update-interval + slime-threads-update-interval + 'slime-update-threads-buffer)))))) + +(defun slime-quit-threads-buffer () + (when slime-threads-buffer-timer + (cancel-timer slime-threads-buffer-timer)) + (quit-window t) + (slime-eval-async `(swank:quit-thread-browser))) + +(defun slime-update-threads-buffer () + (interactive) + (with-current-buffer slime-threads-buffer-name + (slime-eval-async '(swank:list-threads) + 'slime-display-threads))) + +(defun slime-move-point (position) + "Move point in the current buffer and in the window the buffer is displayed." + (let ((window (get-buffer-window (current-buffer) t))) + (goto-char position) + (when window + (set-window-point window position)))) + +(defun slime-display-threads (threads) + (with-current-buffer slime-threads-buffer-name + (let* ((inhibit-read-only t) + (old-thread-id (get-text-property (point) 'thread-id)) + (old-line (line-number-at-pos)) + (old-column (current-column))) + (erase-buffer) + (slime-insert-threads threads) + (let ((new-position (cl-position old-thread-id (cdr threads) + :key #'car :test #'equal))) + (goto-char (point-min)) + (forward-line (or new-position (1- old-line))) + (move-to-column old-column) + (slime-move-point (point)))))) + +(defun slime-transpose-lists (list-of-lists) + (let ((ncols (length (car list-of-lists)))) + (cl-loop for col-index below ncols + collect (cl-loop for row in list-of-lists + collect (elt row col-index))))) + +(defun slime-insert-table-row (line line-props col-props col-widths) + (slime-propertize-region line-props + (cl-loop for string in line + for col-prop in col-props + for width in col-widths do + (slime-insert-propertized col-prop string) + (insert-char ?\ (- width (length string)))))) + +(defun slime-insert-table (rows header row-properties column-properties) + "Insert a \"table\" so that the columns are nicely aligned." + (let* ((ncols (length header)) + (lines (cons header rows)) + (widths (cl-loop for columns in (slime-transpose-lists lines) + collect (1+ (cl-loop for cell in columns + maximize (length cell))))) + (header-line (with-temp-buffer + (slime-insert-table-row + header nil (make-list ncols nil) widths) + (buffer-string)))) + (cond ((boundp 'header-line-format) + (setq header-line-format header-line)) + (t (insert header-line "\n"))) + (cl-loop for line in rows for line-props in row-properties do + (slime-insert-table-row line line-props column-properties widths) + (insert "\n")))) + +(defvar slime-threads-table-properties + '(nil (face bold))) + +(defun slime-insert-threads (threads) + (let* ((labels (car threads)) + (threads (cdr threads)) + (header (cl-loop for label in labels collect + (capitalize (substring (symbol-name label) 1)))) + (rows (cl-loop for thread in threads collect + (cl-loop for prop in thread collect + (format "%s" prop)))) + (line-props (cl-loop for (id) in threads for i from 0 + collect `(thread-index ,i thread-id ,id))) + (col-props (cl-loop for nil in labels for i from 0 collect + (nth i slime-threads-table-properties)))) + (slime-insert-table rows header line-props col-props))) + + +;;;;; Major mode + +(define-derived-mode slime-thread-control-mode fundamental-mode + "Threads" + "SLIME Thread Control Panel Mode. + +\\{slime-thread-control-mode-map} +\\{slime-popup-buffer-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t)) + (setq buffer-undo-list t)) + +(slime-define-keys slime-thread-control-mode-map + ("a" 'slime-thread-attach) + ("d" 'slime-thread-debug) + ("g" 'slime-update-threads-buffer) + ("k" 'slime-thread-kill) + ("q" 'slime-quit-threads-buffer)) + +(defun slime-thread-kill () + (interactive) + (slime-eval `(cl:mapc 'swank:kill-nth-thread + ',(slime-get-properties 'thread-index))) + (call-interactively 'slime-update-threads-buffer)) + +(defun slime-get-region-properties (prop start end) + (cl-loop for position = (if (get-text-property start prop) + start + (next-single-property-change start prop)) + then (next-single-property-change position prop) + while (<= position end) + collect (get-text-property position prop))) + +(defun slime-get-properties (prop) + (if (use-region-p) + (slime-get-region-properties prop + (region-beginning) + (region-end)) + (let ((value (get-text-property (point) prop))) + (when value + (list value))))) + +(defun slime-thread-attach () + (interactive) + (let ((id (get-text-property (point) 'thread-index)) + (file (slime-swank-port-file))) + (slime-eval-async `(swank:start-swank-server-in-thread ,id ,file))) + (slime-read-port-and-connect nil)) + +(defun slime-thread-debug () + (interactive) + (let ((id (get-text-property (point) 'thread-index))) + (slime-eval-async `(swank:debug-nth-thread ,id)))) + + +;;;;; Connection listing + +(define-derived-mode slime-connection-list-mode fundamental-mode + "Slime-Connections" + "SLIME Connection List Mode. + +\\{slime-connection-list-mode-map} +\\{slime-popup-buffer-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +(slime-define-keys slime-connection-list-mode-map + ("d" 'slime-connection-list-make-default) + ("g" 'slime-update-connection-list) + ((kbd "C-k") 'slime-quit-connection-at-point) + ("R" 'slime-restart-connection-at-point)) + +(defun slime-connection-at-point () + (or (get-text-property (point) 'slime-connection) + (error "No connection at point"))) + +(defun slime-quit-connection-at-point (connection) + (interactive (list (slime-connection-at-point))) + (let ((slime-dispatching-connection connection) + (end (time-add (current-time) (seconds-to-time 3)))) + (slime-quit-lisp t) + (while (memq connection slime-net-processes) + (when (time-less-p end (current-time)) + (message "Quit timeout expired. Disconnecting.") + (delete-process connection)) + (sit-for 0 100))) + (slime-update-connection-list)) + +(defun slime-restart-connection-at-point (connection) + (interactive (list (slime-connection-at-point))) + (let ((slime-dispatching-connection connection)) + (slime-restart-inferior-lisp))) + +(defun slime-connection-list-make-default () + "Make the connection at point the default connection." + (interactive) + (slime-select-connection (slime-connection-at-point)) + (slime-update-connection-list)) + +(defvar slime-connections-buffer-name (slime-buffer-name :connections)) + +(defun slime-list-connections () + "Display a list of all connections." + (interactive) + (slime-with-popup-buffer (slime-connections-buffer-name + :mode 'slime-connection-list-mode) + (slime-draw-connection-list))) + +(defun slime-update-connection-list () + "Display a list of all connections." + (interactive) + (let ((pos (point)) + (inhibit-read-only t)) + (erase-buffer) + (slime-draw-connection-list) + (goto-char pos))) + +(defun slime-draw-connection-list () + (let ((default-pos nil) + (default slime-default-connection) + (fstring "%s%2s %-10s %-17s %-7s %-s\n")) + (insert (format fstring " " "Nr" "Name" "Port" "Pid" "Type") + (format fstring " " "--" "----" "----" "---" "----")) + (dolist (p (reverse slime-net-processes)) + (when (eq default p) (setf default-pos (point))) + (slime-insert-propertized + (list 'slime-connection p) + (format fstring + (if (eq default p) "*" " ") + (slime-connection-number p) + (slime-connection-name p) + (or (process-id p) (process-contact p)) + (slime-pid p) + (slime-lisp-implementation-type p)))) + (when default-pos + (goto-char default-pos)))) + + +;;;; Inspector + +(defgroup slime-inspector nil + "Inspector faces." + :prefix "slime-inspector-" + :group 'slime) + +(defface slime-inspector-topline-face + '((t ())) + "Face for top line describing object." + :group 'slime-inspector) + +(defface slime-inspector-label-face + '((t (:inherit font-lock-constant-face))) + "Face for labels in the inspector." + :group 'slime-inspector) + +(defface slime-inspector-value-face + '((t (:inherit font-lock-builtin-face))) + "Face for things which can themselves be inspected." + :group 'slime-inspector) + +(defface slime-inspector-action-face + '((t (:inherit font-lock-warning-face))) + "Face for labels of inspector actions." + :group 'slime-inspector) + +(defface slime-inspector-type-face + '((t (:inherit font-lock-type-face))) + "Face for type description in inspector." + :group 'slime-inspector) + +(defvar slime-inspector-mark-stack '()) + +(defun slime-inspect (string) + "Eval an expression and inspect the result." + (interactive + (list (slime-read-from-minibuffer "Inspect value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:init-inspector ,string) 'slime-open-inspector)) + +(define-derived-mode slime-inspector-mode fundamental-mode + "Slime-Inspector" + " +\\{slime-inspector-mode-map} +\\{slime-popup-buffer-mode-map}" + (set-syntax-table lisp-mode-syntax-table) + (slime-set-truncate-lines) + (setq buffer-read-only t)) + +(defun slime-inspector-buffer () + (or (get-buffer (slime-buffer-name :inspector)) + (slime-with-popup-buffer ((slime-buffer-name :inspector) + :mode 'slime-inspector-mode) + (setq slime-inspector-mark-stack '()) + (buffer-disable-undo) + (current-buffer)))) + +(defmacro slime-inspector-fontify (face string) + `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) ,string)) + +(defvar slime-inspector-insert-ispec-function 'slime-inspector-insert-ispec) + +(defun slime-open-inspector (inspected-parts &optional point hook) + "Display INSPECTED-PARTS in a new inspector window. +Optionally set point to POINT. If HOOK is provided, it is added to local +KILL-BUFFER hooks for the inspector buffer." + (with-current-buffer (slime-inspector-buffer) + (when hook + (add-hook 'kill-buffer-hook hook t t)) + (setq slime-buffer-connection (slime-current-connection)) + (let ((inhibit-read-only t)) + (erase-buffer) + (pop-to-buffer (current-buffer)) + (cl-destructuring-bind (&key id title content) inspected-parts + (cl-macrolet ((fontify (face string) + `(slime-inspector-fontify ,face ,string))) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-value-face) + (insert title)) + (while (eq (char-before) ?\n) + (backward-delete-char 1)) + (insert "\n" (fontify label "--------------------") "\n") + (save-excursion + (slime-inspector-insert-content content)) + (when point + (cl-check-type point cons) + (ignore-errors + (goto-char (point-min)) + (forward-line (1- (car point))) + (move-to-column (cdr point))))))))) + +(defvar slime-inspector-limit 500) + +(defun slime-inspector-insert-content (content) + (slime-inspector-fetch-chunk + content nil + (lambda (chunk) + (let ((inhibit-read-only t)) + (slime-inspector-insert-chunk chunk t t))))) + +(defun slime-inspector-insert-chunk (chunk prev next) + "Insert CHUNK at point. +If PREV resp. NEXT are true insert more-buttons as needed." + (cl-destructuring-bind (ispecs len start end) chunk + (when (and prev (> start 0)) + (slime-inspector-insert-more-button start t)) + (mapc slime-inspector-insert-ispec-function ispecs) + (when (and next (< end len)) + (slime-inspector-insert-more-button end nil)))) + +(defun slime-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) + (insert string))) + ((: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-inspector-position () + "Return a pair (Y-POSITION X-POSITION) representing the +position of point in the current buffer." + ;; We make sure we return absolute coordinates even if the user has + ;; narrowed the buffer. + ;; FIXME: why would somebody narrow the buffer? + (save-restriction + (widen) + (cons (line-number-at-pos) + (current-column)))) + +(defun slime-inspector-property-at-point () + (let* ((properties '(slime-part-number slime-range-button + slime-action-number)) + (find-property + (lambda (point) + (cl-loop for property in properties + for value = (get-text-property point property) + when value + return (list property value))))) + (or (funcall find-property (point)) + (funcall find-property (1- (point)))))) + +(defun slime-inspector-operate-on-point () + "Invoke the command for the text at point. +1. If point is on a value then recursivly call the inspector on +that value. +2. If point is on an action then call that action. +3. If point is on a range-button fetch and insert the range." + (interactive) + (let ((opener (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (when parts + (slime-open-inspector parts point))))) + (new-opener (lambda (parts) + (when parts + (slime-open-inspector parts))))) + (cl-destructuring-bind (&optional property value) + (slime-inspector-property-at-point) + (cl-case property + (slime-part-number + (slime-eval-async `(swank:inspect-nth-part ,value) + new-opener) + (push (slime-inspector-position) slime-inspector-mark-stack)) + (slime-range-button + (slime-inspector-fetch-more value)) + (slime-action-number + (slime-eval-async `(swank:inspector-call-nth-action ,value) + opener)) + (t (error "No object at point")))))) + +(defun slime-inspector-operate-on-click (event) + "Move to events' position and operate the part." + (interactive "@e") + (let ((point (posn-point (event-end event)))) + (cond ((and point + (or (get-text-property point 'slime-part-number) + (get-text-property point 'slime-range-button) + (get-text-property point 'slime-action-number))) + (goto-char point) + (slime-inspector-operate-on-point)) + (t + (error "No clickable part here"))))) + +(defun slime-inspector-pop () + "Reinspect the previous object." + (interactive) + (slime-eval-async + `(swank:inspector-pop) + (lambda (result) + (cond (result + (slime-open-inspector result (pop slime-inspector-mark-stack))) + (t + (message "No previous object") + (ding)))))) + +(defun slime-inspector-next () + "Inspect the next object in the history." + (interactive) + (let ((result (slime-eval `(swank:inspector-next)))) + (cond (result + (push (slime-inspector-position) slime-inspector-mark-stack) + (slime-open-inspector result)) + (t (message "No next object") + (ding))))) + +(defun slime-inspector-quit () + "Quit the inspector and kill the buffer." + (interactive) + (slime-eval-async `(swank:quit-inspector)) + (quit-window t)) + +;; FIXME: first return value is just point. +;; FIXME: could probably use slime-search-property. +(defun slime-find-inspectable-object (direction limit) + "Find the next/previous inspectable object. +DIRECTION can be either 'next or 'prev. +LIMIT is the maximum or minimum position in the current buffer. + +Return a list of two values: If an object could be found, the +starting position of the found object and T is returned; +otherwise LIMIT and NIL is returned." + (let ((finder (cl-ecase direction + (next 'next-single-property-change) + (prev 'previous-single-property-change)))) + (let ((prop nil) (curpos (point))) + (while (and (not prop) (not (= curpos limit))) + (let ((newpos (funcall finder curpos 'slime-part-number nil limit))) + (setq prop (get-text-property newpos 'slime-part-number)) + (setq curpos newpos))) + (list curpos (and prop t))))) + +(defun slime-inspector-next-inspectable-object (arg) + "Move point to the next inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move backwards." + (interactive "p") + (let ((maxpos (point-max)) (minpos (point-min)) + (previously-wrapped-p nil)) + ;; Forward. + (while (> arg 0) + (cl-destructuring-bind (pos foundp) + (slime-find-inspectable-object 'next maxpos) + (if foundp + (progn (goto-char pos) (setq arg (1- arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char minpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))) + ;; Backward. + (while (< arg 0) + (cl-destructuring-bind (pos foundp) + (slime-find-inspectable-object 'prev minpos) + ;; SLIME-OPEN-INSPECTOR inserts the title of an inspector page + ;; as a presentation at the beginning of the buffer; skip + ;; that. (Notice how this problem can not arise in ``Forward.'') + (if (and foundp (/= pos minpos)) + (progn (goto-char pos) (setq arg (1+ arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char maxpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))))) + +(defun slime-inspector-previous-inspectable-object (arg) + "Move point to the previous inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move forwards." + (interactive "p") + (slime-inspector-next-inspectable-object (- arg))) + +(defun slime-inspector-describe () + (interactive) + (slime-eval-describe `(swank:describe-inspectee))) + +(defun slime-inspector-pprint (part) + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-eval-describe `(swank:pprint-inspector-part ,part))) + +(defun slime-inspector-eval (string) + "Eval an expression in the context of the inspected object. +The `*' variable will be bound to the inspected object." + (interactive (list (slime-read-from-minibuffer "Inspector eval: "))) + (slime-eval-with-transcript `(swank:inspector-eval ,string))) + +(defun slime-inspector-history () + "Show the previously inspected objects." + (interactive) + (slime-eval-describe `(swank:inspector-history))) + +(defun slime-inspector-show-source (part) + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-eval-async + `(swank:find-source-location-for-emacs '(:inspector ,part)) + #'slime-show-source-location)) + +(defun slime-inspector-reinspect () + (interactive) + (slime-eval-async `(swank:inspector-reinspect) + (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (slime-open-inspector parts point))))) + +(defun slime-inspector-toggle-verbose () + (interactive) + (slime-eval-async `(swank:inspector-toggle-verbose) + (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (slime-open-inspector parts point))))) + +(defun slime-inspector-insert-more-button (index previous) + (slime-insert-propertized + (list 'slime-range-button (list index previous) + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + (if previous " [--more--]\n" " [--more--]"))) + +(defun slime-inspector-fetch-all () + "Fetch all inspector contents and go to the end." + (interactive) + (goto-char (1- (point-max))) + (let ((button (get-text-property (point) 'slime-range-button))) + (when button + (let (slime-inspector-limit) + (slime-inspector-fetch-more button))))) + +(defun slime-inspector-fetch-more (button) + (cl-destructuring-bind (index prev) button + (slime-inspector-fetch-chunk + (list '() (1+ index) index index) prev + (slime-rcurry + (lambda (chunk prev) + (let ((inhibit-read-only t)) + (apply #'delete-region (slime-property-bounds 'slime-range-button)) + (slime-inspector-insert-chunk chunk prev (not prev)))) + prev)))) + +(defun slime-inspector-fetch-chunk (chunk prev cont) + (slime-inspector-fetch chunk slime-inspector-limit prev cont)) + +(defun slime-inspector-fetch (chunk limit prev cont) + (cl-destructuring-bind (from to) + (slime-inspector-next-range chunk limit prev) + (cond ((and from to) + (slime-eval-async + `(swank:inspector-range ,from ,to) + (slime-rcurry (lambda (chunk2 chunk1 limit prev cont) + (slime-inspector-fetch + (slime-inspector-join-chunks chunk1 chunk2) + limit prev cont)) + chunk limit prev cont))) + (t (funcall cont chunk))))) + +(defun slime-inspector-next-range (chunk limit prev) + (cl-destructuring-bind (_ len start end) chunk + (let ((count (- end start))) + (cond ((and prev (< 0 start) (or (not limit) (< count limit))) + (list (if limit (max (- end limit) 0) 0) start)) + ((and (not prev) (< end len) (or (not limit) (< count limit))) + (list end (if limit (+ start limit) most-positive-fixnum))) + (t '(nil nil)))))) + +(defun slime-inspector-join-chunks (chunk1 chunk2) + (cl-destructuring-bind (i1 _l1 s1 e1) chunk1 + (cl-destructuring-bind (i2 l2 s2 e2) chunk2 + (cond ((= e1 s2) + (list (append i1 i2) l2 s1 e2)) + ((= e2 s1) + (list (append i2 i1) l2 s2 e1)) + (t (error "Invalid chunks")))))) + +(set-keymap-parent slime-inspector-mode-map slime-parent-map) + +(slime-define-keys slime-inspector-mode-map + ([return] 'slime-inspector-operate-on-point) + ("\C-m" 'slime-inspector-operate-on-point) + ([mouse-1] 'slime-inspector-operate-on-click) + ([mouse-2] 'slime-inspector-operate-on-click) + ([mouse-6] 'slime-inspector-pop) + ([mouse-7] 'slime-inspector-next) + ("l" 'slime-inspector-pop) + ("n" 'slime-inspector-next) + (" " 'slime-inspector-next) + ("d" 'slime-inspector-describe) + ("p" 'slime-inspector-pprint) + ("e" 'slime-inspector-eval) + ("h" 'slime-inspector-history) + ("g" 'slime-inspector-reinspect) + ("v" 'slime-inspector-toggle-verbose) + ("\C-i" 'slime-inspector-next-inspectable-object) + ([(shift tab)] + 'slime-inspector-previous-inspectable-object) ; Emacs translates S-TAB + ([backtab] 'slime-inspector-previous-inspectable-object) ; to BACKTAB on X. + ("." 'slime-inspector-show-source) + (">" 'slime-inspector-fetch-all) + ("q" 'slime-inspector-quit)) + + +;;;; Buffer selector + +(defvar slime-selector-methods nil + "List of buffer-selection methods for the `slime-select' command. +Each element is a list (KEY DESCRIPTION FUNCTION). +DESCRIPTION is a one-line description of what the key selects.") + +(defvar slime-selector-other-window nil + "If non-nil use switch-to-buffer-other-window.") + +(defun slime-selector (&optional other-window) + "Select a new buffer by type, indicated by a single character. +The user is prompted for a single character indicating the method by +which to choose a new buffer. The `?' character describes the +available methods. + +See `def-slime-selector-method' for defining new methods." + (interactive) + (message "Select [%s]: " + (apply #'string (mapcar #'car slime-selector-methods))) + (let* ((slime-selector-other-window other-window) + (sequence (save-window-excursion + (select-window (minibuffer-window)) + (key-description (read-key-sequence nil)))) + (ch (cond ((equal sequence "C-g") + (keyboard-quit)) + ((equal sequence "TAB") + ?i) + ((= (length sequence) 1) + (elt sequence 0)) + ((= (length sequence) 3) + (elt sequence 2)))) + (method (cl-find ch slime-selector-methods :key #'car))) + (cond (method + (funcall (cl-third method))) + (t + (message "No method for character: ?\\%c" ch) + (ding) + (sleep-for 1) + (discard-input) + (slime-selector))))) + +(defmacro def-slime-selector-method (key description &rest body) + "Define a new `slime-select' buffer selection method. + +KEY is the key the user will enter to choose this method. + +DESCRIPTION is a one-line sentence describing how the method +selects a buffer. + +BODY is a series of forms which are evaluated when the selector +is chosen. The returned buffer is selected with +switch-to-buffer." + (let ((method `(lambda () + (let ((buffer (progn ,@body))) + (cond ((not (get-buffer buffer)) + (message "No such buffer: %S" buffer) + (ding)) + ((get-buffer-window buffer) + (select-window (get-buffer-window buffer))) + (slime-selector-other-window + (switch-to-buffer-other-window buffer)) + (t + (switch-to-buffer buffer))))))) + `(setq slime-selector-methods + (cl-sort (cons (list ,key ,description ,method) + (cl-remove ,key slime-selector-methods :key #'car)) + #'< :key #'car)))) + +(def-slime-selector-method ?? "Selector help buffer." + (ignore-errors (kill-buffer "*Select Help*")) + (with-current-buffer (get-buffer-create "*Select Help*") + (insert "Select Methods:\n\n") + (cl-loop for (key line nil) in slime-selector-methods + do (insert (format "%c:\t%s\n" key line))) + (goto-char (point-min)) + (help-mode) + (display-buffer (current-buffer) t)) + (slime-selector) + (current-buffer)) + +(cl-pushnew (list ?4 "Select in other window" (lambda () (slime-selector t))) + slime-selector-methods :key #'car) + +(def-slime-selector-method ?q "Abort." + (top-level)) + +(def-slime-selector-method ?i + "*inferior-lisp* buffer." + (cond ((and (slime-connected-p) (slime-process)) + (process-buffer (slime-process))) + (t + "*inferior-lisp*"))) + +(def-slime-selector-method ?v + "*slime-events* buffer." + slime-event-buffer-name) + +(def-slime-selector-method ?l + "most recently visited lisp-mode buffer." + (slime-recently-visited-buffer 'lisp-mode)) + +(def-slime-selector-method ?d + "*sldb* buffer for the current connection." + (or (sldb-get-default-buffer) + (error "No debugger buffer"))) + +(def-slime-selector-method ?e + "most recently visited emacs-lisp-mode buffer." + (slime-recently-visited-buffer 'emacs-lisp-mode)) + +(def-slime-selector-method ?c + "SLIME connections buffer." + (slime-list-connections) + slime-connections-buffer-name) + +(def-slime-selector-method ?n + "Cycle to the next Lisp connection." + (slime-next-connection) + (concat "*slime-repl " + (slime-connection-name (slime-current-connection)) + "*")) + +(def-slime-selector-method ?p + "Cycle to the previous Lisp connection." + (slime-prev-connection) + (concat "*slime-repl " + (slime-connection-name (slime-current-connection)) + "*")) + +(def-slime-selector-method ?t + "SLIME threads buffer." + (slime-list-threads) + slime-threads-buffer-name) + +(defun slime-recently-visited-buffer (mode) + "Return the most recently visited buffer whose major-mode is MODE. +Only considers buffers that are not already visible." + (cl-loop for buffer in (buffer-list) + when (and (with-current-buffer buffer (eq major-mode mode)) + (not (string-match "^ " (buffer-name buffer))) + (null (get-buffer-window buffer 'visible))) + return buffer + finally (error "Can't find unshown buffer in %S" mode))) + + +;;;; Indentation + +(defun slime-update-indentation () + "Update indentation for all macros defined in the Lisp system." + (interactive) + (slime-eval-async '(swank:update-indentation-information))) + +(defvar slime-indentation-update-hooks) + +(defun slime-intern-indentation-spec (spec) + (cond ((consp spec) + (cons (slime-intern-indentation-spec (car spec)) + (slime-intern-indentation-spec (cdr spec)))) + ((stringp spec) + (intern spec)) + (t + spec))) + +;; FIXME: restore the old version without per-package +;; stuff. slime-indentation.el should be able tho disable the simple +;; version if needed. +(defun slime-handle-indentation-update (alist) + "Update Lisp indent information. + +ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation +settings for `common-lisp-indent-function'. The appropriate property +is setup, unless the user already set one explicitly." + (dolist (info alist) + (let ((symbol (intern (car info))) + (indent (slime-intern-indentation-spec (cl-second info))) + (packages (cl-third info))) + (if (and (boundp 'common-lisp-system-indentation) + (fboundp 'slime-update-system-indentation)) + ;; A table provided by slime-cl-indent.el. + (funcall #'slime-update-system-indentation symbol indent packages) + ;; Does the symbol have an indentation value that we set? + (when (equal (get symbol 'common-lisp-indent-function) + (get symbol 'slime-indent)) + (put symbol 'common-lisp-indent-function indent) + (put symbol 'slime-indent indent))) + (run-hook-with-args 'slime-indentation-update-hooks + symbol indent packages)))) + + +;;;; Contrib modules + +(defun slime-require (module) + (cl-pushnew module slime-required-modules) + (when (slime-connected-p) + (slime-load-contribs))) + +(defun slime-load-contribs () + (let ((needed (cl-remove-if (lambda (s) + (member (cl-subseq (symbol-name s) 1) + (mapcar #'downcase + (slime-lisp-modules)))) + slime-required-modules))) + (when needed + ;; No asynchronous request because with :SPAWN that could result + ;; in the attempt to load modules concurrently which may not be + ;; supported by the host Lisp. + (setf (slime-lisp-modules) + (slime-eval `(swank:swank-require ',needed)))))) + +(cl-defstruct slime-contrib + name + slime-dependencies + swank-dependencies + enable + disable + authors + license) + +(defun slime-contrib--enable-fun (name) + (intern (concat (symbol-name name) "-init"))) + +(defun slime-contrib--disable-fun (name) + (intern (concat (symbol-name name) "-unload"))) + +(defmacro define-slime-contrib (name _docstring &rest clauses) + (declare (indent 1)) + (cl-destructuring-bind (&key slime-dependencies + swank-dependencies + on-load + on-unload + authors + license) + (cl-loop for (key . value) in clauses append `(,key ,value)) + `(progn + ,@(mapcar (lambda (d) `(require ',d)) slime-dependencies) + (defun ,(slime-contrib--enable-fun name) () + (mapc #'funcall ',(mapcar + #'slime-contrib--enable-fun + slime-dependencies)) + (mapc #'slime-require ',swank-dependencies) + ,@on-load) + (defun ,(slime-contrib--disable-fun name) () + ,@on-unload + (mapc #'funcall ',(mapcar + #'slime-contrib--disable-fun + slime-dependencies))) + (put 'slime-contribs ',name + (make-slime-contrib + :name ',name :authors ',authors :license ',license + :slime-dependencies ',slime-dependencies + :swank-dependencies ',swank-dependencies + :enable ',(slime-contrib--enable-fun name) + :disable ',(slime-contrib--disable-fun name)))))) + +(defun slime-all-contribs () + (cl-loop for (nil val) on (symbol-plist 'slime-contribs) by #'cddr + when (slime-contrib-p val) + collect val)) + +(defun slime-contrib-all-dependencies (contrib) + "List all contribs recursively needed by CONTRIB, including self." + (cons contrib + (cl-mapcan #'slime-contrib-all-dependencies + (slime-contrib-slime-dependencies + (slime-find-contrib contrib))))) + +(defun slime-find-contrib (name) + (get 'slime-contribs name)) + +(defun slime-read-contrib-name () + (let ((names (cl-loop for c in (slime-all-contribs) collect + (symbol-name (slime-contrib-name c))))) + (intern (completing-read "Contrib: " names nil t)))) + +(defun slime-enable-contrib (name) + (interactive (list (slime-read-contrib-name))) + (let ((c (or (slime-find-contrib name) + (error "Unknown contrib: %S" name)))) + (funcall (slime-contrib-enable c)))) + +(defun slime-disable-contrib (name) + (interactive (list (slime-read-contrib-name))) + (let ((c (or (slime-find-contrib name) + (error "Unknown contrib: %S" name)))) + (funcall (slime-contrib-disable c)))) + + +;;;;; Pull-down menu + +(defvar slime-easy-menu + (let ((C '(slime-connected-p))) + `("SLIME" + [ "Edit Definition..." slime-edit-definition ,C ] + [ "Return From Definition" slime-pop-find-definition-stack ,C ] + [ "Complete Symbol" completion-at-point ,C ] + "--" + ("Evaluation" + [ "Eval Defun" slime-eval-defun ,C ] + [ "Eval Last Expression" slime-eval-last-expression ,C ] + [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ] + [ "Eval Region" slime-eval-region ,C ] + [ "Eval Region And Pretty-Print" slime-pprint-eval-region ,C ] + [ "Interactive Eval..." slime-interactive-eval ,C ] + [ "Edit Lisp Value..." slime-edit-value ,C ] + [ "Call Defun" slime-call-defun ,C ]) + ("Debugging" + [ "Macroexpand Once..." slime-macroexpand-1 ,C ] + [ "Macroexpand All..." slime-macroexpand-all ,C ] + [ "Create Trace Buffer" slime-redirect-trace-output ,C ] + [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ] + [ "Untrace All" slime-untrace-all ,C] + [ "Disassemble..." slime-disassemble-symbol ,C ] + [ "Inspect..." slime-inspect ,C ]) + ("Compilation" + [ "Compile Defun" slime-compile-defun ,C ] + [ "Compile/Load File" slime-compile-and-load-file ,C ] + [ "Compile File" slime-compile-file ,C ] + [ "Compile Region" slime-compile-region ,C ] + "--" + [ "Next Note" slime-next-note t ] + [ "Previous Note" slime-previous-note t ] + [ "Remove Notes" slime-remove-notes t ] + [ "List Notes" slime-list-compiler-notes ,C ]) + ("Cross Reference" + [ "Who Calls..." slime-who-calls ,C ] + [ "Who References... " slime-who-references ,C ] + [ "Who Sets..." slime-who-sets ,C ] + [ "Who Binds..." slime-who-binds ,C ] + [ "Who Macroexpands..." slime-who-macroexpands ,C ] + [ "Who Specializes..." slime-who-specializes ,C ] + [ "List Callers..." slime-list-callers ,C ] + [ "List Callees..." slime-list-callees ,C ] + [ "Next Location" slime-next-location t ]) + ("Editing" + [ "Check Parens" check-parens t] + [ "Update Indentation" slime-update-indentation ,C] + [ "Select Buffer" slime-selector t]) + ("Profiling" + [ "Toggle Profiling..." slime-toggle-profile-fdefinition ,C ] + [ "Profile Package" slime-profile-package ,C] + [ "Profile by Substring" slime-profile-by-substring ,C ] + [ "Unprofile All" slime-unprofile-all ,C ] + [ "Show Profiled" slime-profiled-functions ,C ] + "--" + [ "Report" slime-profile-report ,C ] + [ "Reset Counters" slime-profile-reset ,C ]) + ("Documentation" + [ "Describe Symbol..." slime-describe-symbol ,C ] + [ "Lookup Documentation..." slime-documentation-lookup t ] + [ "Apropos..." slime-apropos ,C ] + [ "Apropos all..." slime-apropos-all ,C ] + [ "Apropos Package..." slime-apropos-package ,C ] + [ "Hyperspec..." slime-hyperspec-lookup t ]) + "--" + [ "Interrupt Command" slime-interrupt ,C ] + [ "Abort Async. Command" slime-quit ,C ] + [ "Sync Package & Directory" slime-sync-package-and-default-directory ,C] + ))) + +(defvar slime-sldb-easy-menu + (let ((C '(slime-connected-p))) + `("SLDB" + [ "Next Frame" sldb-down t ] + [ "Previous Frame" sldb-up t ] + [ "Toggle Frame Details" sldb-toggle-details t ] + [ "Next Frame (Details)" sldb-details-down t ] + [ "Previous Frame (Details)" sldb-details-up t ] + "--" + [ "Eval Expression..." slime-interactive-eval ,C ] + [ "Eval in Frame..." sldb-eval-in-frame ,C ] + [ "Eval in Frame (pretty print)..." sldb-pprint-eval-in-frame ,C ] + [ "Inspect In Frame..." sldb-inspect-in-frame ,C ] + [ "Inspect Condition Object" sldb-inspect-condition ,C ] + "--" + [ "Restart Frame" sldb-restart-frame ,C ] + [ "Return from Frame..." sldb-return-from-frame ,C ] + ("Invoke Restart" + [ "Continue" sldb-continue ,C ] + [ "Abort" sldb-abort ,C ] + [ "Step" sldb-step ,C ] + [ "Step next" sldb-next ,C ] + [ "Step out" sldb-out ,C ] + ) + "--" + [ "Quit (throw)" sldb-quit ,C ] + [ "Break With Default Debugger" sldb-break-with-default-debugger ,C ]))) + +(easy-menu-define menubar-slime slime-mode-map "SLIME" slime-easy-menu) + +(defun slime-add-easy-menu () + (easy-menu-add slime-easy-menu 'slime-mode-map)) + +(add-hook 'slime-mode-hook 'slime-add-easy-menu) + +(defun slime-sldb-add-easy-menu () + (easy-menu-define menubar-slime-sldb + sldb-mode-map "SLDB" slime-sldb-easy-menu) + (easy-menu-add slime-sldb-easy-menu 'sldb-mode-map)) + +(add-hook 'sldb-mode-hook 'slime-sldb-add-easy-menu) + + +;;;; Cheat Sheet + +(defvar + slime-cheat-sheet-table + '((:title + "Editing lisp code" + :map slime-mode-map + :bindings ((slime-eval-defun "Evaluate current top level form") + (slime-compile-defun "Compile current top level form") + (slime-interactive-eval "Prompt for form and eval it") + (slime-compile-and-load-file "Compile and load current file") + (slime-sync-package-and-default-directory + "Synch default package and directory with current buffer") + (slime-next-note "Next compiler note") + (slime-previous-note "Previous compiler note") + (slime-remove-notes "Remove notes") + slime-documentation-lookup)) + (:title "Completion" + :map slime-mode-map + :bindings (slime-indent-and-complete-symbol + slime-fuzzy-complete-symbol)) + (:title + "Within SLDB buffers" + :map sldb-mode-map + :bindings ((sldb-default-action "Do 'whatever' with thing at point") + (sldb-toggle-details "Toggle frame details visualization") + (sldb-quit "Quit to REPL") + (sldb-abort "Invoke ABORT restart") + (sldb-continue "Invoke CONTINUE restart (if available)") + (sldb-show-source "Jump to frame's source code") + (sldb-eval-in-frame "Evaluate in frame at point") + (sldb-inspect-in-frame + "Evaluate in frame at point and inspect result"))) + (:title + "Within the Inspector" + :map slime-inspector-mode-map + :bindings ((slime-inspector-next-inspectable-object + "Jump to next inspectable object") + (slime-inspector-operate-on-point + "Inspect object or execute action at point") + (slime-inspector-reinspect "Reinspect current object") + (slime-inspector-pop "Return to previous object") + ;;(slime-inspector-copy-down "Send object at point to REPL") + (slime-inspector-toggle-verbose "Toggle verbose mode") + (slime-inspector-quit "Quit"))) + (:title + "Finding Definitions" + :map slime-mode-map + :bindings (slime-edit-definition + slime-pop-find-definition-stack)))) + +(defun slime-cheat-sheet () + (interactive) + (switch-to-buffer-other-frame + (get-buffer-create (slime-buffer-name :cheat-sheet))) + (setq buffer-read-only nil) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert + "SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).\n\n") + (dolist (mode slime-cheat-sheet-table) + (let ((title (cl-getf mode :title)) + (mode-map (cl-getf mode :map)) + (mode-keys (cl-getf mode :bindings))) + (insert title) + (insert ":\n") + (insert (make-string (1+ (length title)) ?-)) + (insert "\n") + (let ((keys '()) + (descriptions '())) + (dolist (func mode-keys) + ;; func is eithor the function name or a list (NAME DESCRIPTION) + (push (if (symbolp func) + (prin1-to-string func) + (cl-second func)) + descriptions) + (let ((all-bindings (where-is-internal (if (symbolp func) + func + (cl-first func)) + (symbol-value mode-map))) + (key-bindings '())) + (dolist (binding all-bindings) + (when (and (vectorp binding) + (integerp (aref binding 0))) + (push binding key-bindings))) + (push (mapconcat 'key-description key-bindings " or ") keys))) + (cl-loop with desc-length = (apply 'max (mapcar 'length descriptions)) + for key in (nreverse keys) + for desc in (nreverse descriptions) + do (insert desc) + do (insert (make-string (- desc-length (length desc)) ? )) + do (insert " => ") + do (insert (if (string= "" key) + "" + key)) + do (insert "\n") + finally do (insert "\n"))))) + (setq buffer-read-only t) + (goto-char (point-min))) + + +;;;; Utilities (no not Paul Graham style) + +;; XXX: unused function +(defun slime-intersperse (element list) + "Intersperse ELEMENT between each element of LIST." + (if (null list) + '() + (cons (car list) + (cl-mapcan (lambda (x) (list element x)) (cdr list))))) + +;;; FIXME: this looks almost slime `slime-alistify', perhaps the two +;;; functions can be merged. +(defun slime-group-similar (similar-p list) + "Return the list of lists of 'similar' adjacent elements of LIST. +The function SIMILAR-P is used to test for similarity. +The order of the input list is preserved." + (if (null list) + nil + (let ((accumulator (list (list (car list))))) + (dolist (x (cdr list)) + (if (funcall similar-p x (caar accumulator)) + (push x (car accumulator)) + (push (list x) accumulator))) + (reverse (mapcar #'reverse accumulator))))) + +(defun slime-alistify (list key test) + "Partition the elements of LIST into an alist. +KEY extracts the key from an element and TEST is used to compare +keys." + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (cl-assoc k alist :test test))) + (if probe + (push e (cdr probe)) + (push (cons k (list e)) alist)))) + ;; Put them back in order. + (cl-loop for (key . value) in (reverse alist) + collect (cons key (reverse value))))) + +;;;;; Misc. + +(defun slime-length= (seq n) + "Return (= (length SEQ) N)." + (cl-etypecase seq + (list + (cond ((zerop n) (null seq)) + ((let ((tail (nthcdr (1- n) seq))) + (and tail (null (cdr tail))))))) + (sequence + (= (length seq) n)))) + +(defun slime-length> (seq n) + "Return (> (length SEQ) N)." + (cl-etypecase seq + (list (nthcdr n seq)) + (sequence (> (length seq) n)))) + +(defun slime-trim-whitespace (str) + (let ((start (cl-position-if-not (lambda (x) + (memq x '(?\t ?\n ?\s ?\r))) + str)) + + (end (cl-position-if-not (lambda (x) + (memq x '(?\t ?\n ?\s ?\r))) + str + :from-end t))) + (if start + (substring str start (1+ end)) + ""))) + +;;;;; Buffer related + +(defun slime-buffer-narrowed-p (&optional buffer) + "Returns T if BUFFER (or the current buffer respectively) is narrowed." + (with-current-buffer (or buffer (current-buffer)) + (let ((beg (point-min)) + (end (point-max)) + (total (buffer-size))) + (or (/= beg 1) (/= end (1+ total)))))) + +(defun slime-column-max () + (save-excursion + (goto-char (point-min)) + (cl-loop for column = (prog2 (end-of-line) (current-column) (forward-line)) + until (= (point) (point-max)) + maximizing column))) + +;;;;; CL symbols vs. Elisp symbols. + +(defun slime-cl-symbol-name (symbol) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match ":\\([^:]*\\)$" n) + (let ((symbol-part (match-string 1 n))) + (if (string-match "^|\\(.*\\)|$" symbol-part) + (match-string 1 symbol-part) + symbol-part)) + n))) + +(defun slime-cl-symbol-package (symbol &optional default) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match "^\\([^:]*\\):" n) + (match-string 1 n) + default))) + +(defun slime-qualify-cl-symbol-name (symbol-or-name) + "Return a package-qualified string for SYMBOL-OR-NAME. +If SYMBOL-OR-NAME doesn't already have a package prefix the +current package is used." + (let ((s (if (stringp symbol-or-name) + symbol-or-name + (symbol-name symbol-or-name)))) + (if (slime-cl-symbol-package s) + s + (format "%s::%s" + (let* ((package (slime-current-package))) + ;; package is a string like ":cl-user" + ;; or "CL-USER", or "\"CL-USER\"". + (if package + (slime-pretty-package-name package) + "CL-USER")) + (slime-cl-symbol-name s))))) + +;;;;; Moving, CL idiosyncracies aware (reader conditionals &c.) + +(defmacro slime-point-moves-p (&rest body) + "Execute BODY and return true if the current buffer's point moved." + (declare (indent 0)) + (let ((pointvar (cl-gensym "point-"))) + `(let ((,pointvar (point))) + (save-current-buffer ,@body) + (/= ,pointvar (point))))) + +(defun slime-forward-sexp (&optional count) + "Like `forward-sexp', but understands reader-conditionals (#- and #+), +and skips comments." + (dotimes (_i (or count 1)) + (slime-forward-cruft) + (forward-sexp))) + +(defconst slime-reader-conditionals-regexp + ;; #!+, #!- are SBCL specific reader-conditional syntax. + ;; We need this for the source files of SBCL itself. + (regexp-opt '("#+" "#-" "#!+" "#!-"))) + +(defun slime-forward-reader-conditional () + "Move past any reader conditional (#+ or #-) at point." + (when (looking-at slime-reader-conditionals-regexp) + (goto-char (match-end 0)) + (let* ((plus-conditional-p (eq (char-before) ?+)) + (result (slime-eval-feature-expression + (condition-case e + (read (current-buffer)) + (invalid-read-syntax + (signal 'slime-unknown-feature-expression (cdr e))))))) + (unless (if plus-conditional-p result (not result)) + ;; skip this sexp + (slime-forward-sexp))))) + +(defun slime-forward-cruft () + "Move forward over whitespace, comments, reader conditionals." + (while (slime-point-moves-p (skip-chars-forward " \t\n") + (forward-comment (buffer-size)) + (inline (slime-forward-reader-conditional))))) + +(defun slime-keywordify (symbol) + "Make a keyword out of the symbol SYMBOL." + (let ((name (downcase (symbol-name symbol)))) + (intern (if (eq ?: (aref name 0)) + name + (concat ":" name))))) + +(put 'slime-incorrect-feature-expression + 'error-conditions '(slime-incorrect-feature-expression error)) + +(put 'slime-unknown-feature-expression + 'error-conditions '(slime-unknown-feature-expression + slime-incorrect-feature-expression + error)) + +;; FIXME: let it crash +;; FIXME: the length=1 constraint is bogus +(defun slime-eval-feature-expression (e) + "Interpret a reader conditional expression." + (cond ((symbolp e) + (memq (slime-keywordify e) (slime-lisp-features))) + ((and (consp e) (symbolp (car e))) + (funcall (let ((head (slime-keywordify (car e)))) + (cl-case head + (:and #'cl-every) + (:or #'cl-some) + (:not + (lexical-let ((feature-expression e)) + (lambda (f l) + (cond + ((slime-length= l 0) t) + ((slime-length= l 1) (not (apply f l))) + (t (signal 'slime-incorrect-feature-expression + feature-expression)))))) + (t (signal 'slime-unknown-feature-expression head)))) + #'slime-eval-feature-expression + (cdr e))) + (t (signal 'slime-incorrect-feature-expression e)))) + +;;;;; Extracting Lisp forms from the buffer or user + +(defun slime-defun-at-point () + "Return the text of the defun at point." + (apply #'buffer-substring-no-properties + (slime-region-for-defun-at-point))) + +(defun slime-region-for-defun-at-point () + "Return the start and end position of defun at point." + (save-excursion + (save-match-data + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (list (point) end))))) + +(defun slime-beginning-of-symbol () + "Move to the beginning of the CL-style symbol at point." + (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\=" + (when (> (point) 2000) (- (point) 2000)) + t)) + (re-search-forward "\\=#[-+.<|]" nil t) + (when (and (looking-at "@") (eq (char-before) ?\,)) + (forward-char))) + +(defun slime-end-of-symbol () + "Move to the end of the CL-style symbol at point." + (re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|#:\\|[@|]\\)*")) + +(put 'slime-symbol 'end-op 'slime-end-of-symbol) +(put 'slime-symbol 'beginning-op 'slime-beginning-of-symbol) + +(defun slime-symbol-start-pos () + "Return the starting position of the symbol under point. +The result is unspecified if there isn't a symbol under the point." + (save-excursion (slime-beginning-of-symbol) (point))) + +(defun slime-symbol-end-pos () + (save-excursion (slime-end-of-symbol) (point))) + +(defun slime-bounds-of-symbol-at-point () + "Return the bounds of the symbol around point. +The returned bounds are either nil or non-empty." + (let ((bounds (bounds-of-thing-at-point 'slime-symbol))) + (if (and bounds + (< (car bounds) + (cdr bounds))) + bounds))) + +(defun slime-symbol-at-point () + "Return the name of the symbol at point, otherwise nil." + ;; (thing-at-point 'symbol) returns "" in empty buffers + (let ((bounds (slime-bounds-of-symbol-at-point))) + (if bounds + (buffer-substring-no-properties (car bounds) + (cdr bounds))))) + +(defun slime-bounds-of-sexp-at-point () + "Return the bounds sexp at point as a pair (or nil)." + (or (slime-bounds-of-symbol-at-point) + (and (equal (char-after) ?\() + (member (char-before) '(?\' ?\, ?\@)) + ;; hide stuff before ( to avoid quirks with '( etc. + (save-restriction + (narrow-to-region (point) (point-max)) + (bounds-of-thing-at-point 'sexp))) + (bounds-of-thing-at-point 'sexp))) + +(defun slime-sexp-at-point () + "Return the sexp at point as a string, otherwise nil." + (let ((bounds (slime-bounds-of-sexp-at-point))) + (if bounds + (buffer-substring-no-properties (car bounds) + (cdr bounds))))) + +(defun slime-sexp-at-point-or-error () + "Return the sexp at point as a string, othwise signal an error." + (or (slime-sexp-at-point) (user-error "No expression at point"))) + +(defun slime-string-at-point () + "Returns the string at point as a string, otherwise nil." + (let ((sexp (slime-sexp-at-point))) + (if (and sexp + (eql (char-syntax (aref sexp 0)) ?\")) + sexp + nil))) + +(defun slime-string-at-point-or-error () + "Return the sexp at point as a string, othwise signal an error." + (or (slime-string-at-point) (error "No string at point."))) + +(defun slime-input-complete-p (start end) + "Return t if the region from START to END contains a complete sexp." + (save-excursion + (goto-char start) + (cond ((looking-at "\\s *['`#]?[(\"]") + (ignore-errors + (save-restriction + (narrow-to-region start end) + ;; Keep stepping over blanks and sexps until the end of + ;; buffer is reached or an error occurs. Tolerate extra + ;; close parens. + (cl-loop do (skip-chars-forward " \t\r\n)") + until (eobp) + do (forward-sexp)) + t))) + (t t)))) + + +;;;; slime.el in pretty colors + +(cl-loop for sym in (list 'slime-def-connection-var + 'slime-define-channel-type + 'slime-define-channel-method + 'define-slime-contrib + 'slime-defun-if-undefined + 'slime-defmacro-if-undefined) + for regexp = (format "(\\(%S\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" + sym) + do (font-lock-add-keywords + 'emacs-lisp-mode + `((,regexp (1 font-lock-keyword-face) + (2 font-lock-variable-name-face))))) + +;;;; target manipulation (used by slime-presentations, slime-media, +;;;; slime-repl and slime-buffer-streams, at +;;;; least) + +(defvar slime-output-target-to-marker + (make-hash-table) + "Map from TARGET ids to Emacs markers. +The markers indicate where output should be inserted.") + +(defun slime-output-target-marker (target) + "Return the marker where output for TARGET should be inserted." + (gethash target slime-output-target-to-marker)) + +(defun slime-emit-to-target (string target) + "Insert STRING at target TARGET. +See `slime-output-target-to-marker'." + (let* ((marker (slime-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (when buffer + (with-current-buffer buffer + (save-excursion + ;; Insert STRING at MARKER, then move MARKER behind + ;; the insertion. + (goto-char marker) + (insert-before-markers string) + (set-marker marker (point))))))) + +;;;; Finishing up + +(eval-when-compile + (require 'bytecomp)) + +(defun slime--byte-compile (symbol) + (require 'bytecomp) ;; tricky interaction between autoload and let. + (let ((byte-compile-warnings '())) + (byte-compile symbol))) + +(defun slime--compile-hotspots () + (mapc (lambda (sym) + (cond ((fboundp sym) + (unless (byte-code-function-p (symbol-function sym)) + (slime--byte-compile sym))) + (t (error "%S is not fbound" sym)))) + '(slime-alistify + slime-log-event + slime-events-buffer + slime-process-available-input + slime-dispatch-event + slime-net-filter + slime-net-have-input-p + slime-net-decode-length + slime-net-read + slime-print-apropos + slime-insert-propertized + slime-beginning-of-symbol + slime-end-of-symbol + slime-eval-feature-expression + slime-forward-sexp + slime-forward-cruft + slime-forward-reader-conditional))) + +(slime--compile-hotspots) + +(add-to-list 'load-path (expand-file-name "contrib" slime-path)) + +(run-hooks 'slime-load-hook) +(provide 'slime) + +(slime-setup) + +;; Local Variables: +;; outline-regexp: ";;;;+" +;; indent-tabs-mode: nil +;; coding: latin-1-unix +;; End: +;;; slime.el ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/start-swank.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/start-swank.lisp new file mode 100644 index 0000000..340606c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/start-swank.lisp @@ -0,0 +1,20 @@ +;;; This file is intended to be loaded by an implementation to +;;; get a running swank server +;;; e.g. sbcl --load start-swank.lisp +;;; +;;; Default port is 4005 + +;;; For additional swank-side configurations see +;;; 6.2 section of the Slime user manual. + +(load (merge-pathnames "swank-loader.lisp" *load-truename*)) + +(swank-loader:init + :delete nil ; delete any existing SWANK packages + :reload nil ; reload SWANK, even if the SWANK package already exists + :load-contribs nil) ; load all contribs + +(swank:create-server :port 4005 + ;; if non-nil the connection won't be closed + ;; after connecting + :dont-close nil) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank-loader.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank-loader.lisp new file mode 100644 index 0000000..ec89e67 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank-loader.lisp @@ -0,0 +1,376 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-loader.lisp --- Compile and load the Slime backend. +;;; +;;; Created 2003, James Bielman +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;; If you want customize the source- or fasl-directory you can set +;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory* +;; before loading this files. +;; E.g.: +;; +;; (load ".../swank-loader.lisp") +;; (setq swank-loader::*fasl-directory* "/tmp/fasl/") +;; (swank-loader:init) + +(cl:defpackage :swank-loader + (:use :cl) + (:export :init + :dump-image + :list-fasls + :*source-directory* + :*fasl-directory* + :*started-from-emacs*)) + +(cl:in-package :swank-loader) + +(defvar *started-from-emacs* nil) + +(defvar *source-directory* + (make-pathname :name nil :type nil + :defaults (or *load-pathname* *default-pathname-defaults*)) + "The directory where to look for the source.") + +(defparameter *sysdep-files* + #+cmu '((swank source-path-parser) (swank source-file-cache) (swank cmucl) + (swank gray)) + #+scl '((swank source-path-parser) (swank source-file-cache) (swank scl) + (swank gray)) + #+sbcl '((swank source-path-parser) (swank source-file-cache) (swank sbcl) + (swank gray)) + #+clozure '(metering (swank ccl) (swank gray)) + #+lispworks '((swank lispworks) (swank gray)) + #+allegro '((swank allegro) (swank gray)) + #+clisp '(xref metering (swank clisp) (swank gray)) + #+armedbear '((swank abcl)) + #+cormanlisp '((swank corman) (swank gray)) + #+ecl '((swank ecl) (swank gray)) + #+clasp '((swank clasp) (swank gray)) + #+mkcl '((swank mkcl) (swank gray)) + #+mezzano '((swank mezzano) (swank gray)) + ) + +(defparameter *implementation-features* + '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp + :armedbear :gcl :ecl :scl :mkcl :clasp :mezzano)) + +(defparameter *os-features* + '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux + :unix :mezzano)) + +(defparameter *architecture-features* + '(:powerpc :ppc :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 + :sparc64 :sparc :hppa64 :hppa :arm :armv5l :armv6l :armv7l :arm64 :aarch64 + :pentium3 :pentium4 + :mips :mipsel + :java-1.4 :java-1.5 :java-1.6 :java-1.7)) + +(defun q (s) (read-from-string s)) + +#+ecl +(defun ecl-version-string () + (format nil "~A~@[-~A~]" + (lisp-implementation-version) + (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) + (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id")))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))))) + +#+clasp +(defun clasp-version-string () + (format nil "~A~@[-~A~]" + (lisp-implementation-version) + (core:lisp-implementation-id))) + +(defun lisp-version-string () + #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /")) + (lisp-implementation-version)) + #+(or cormanlisp scl mkcl) (lisp-implementation-version) + #+sbcl (format nil "~a~:[~;-no-threads~]" + (lisp-implementation-version) + #+sb-thread nil + #-sb-thread t) + #+lispworks (lisp-implementation-version) + #+allegro (format nil "~@{~a~}" + excl::*common-lisp-version-number* + (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn + (if (member :smp *features*) "s" "") + (if (member :64bit *features*) "-64bit" "") + (excl:ics-target-case + (:-ics "") + (:+ics "-ics"))) + #+clisp (let ((s (lisp-implementation-version))) + (subseq s 0 (position #\space s))) + #+armedbear (lisp-implementation-version) + #+ecl (ecl-version-string) + #+clasp (clasp-version-string) + #+mezzano (let ((s (lisp-implementation-version))) + (subseq s 0 (position #\space s)))) + +(defun unique-dir-name () + "Return a name that can be used as a directory name that is +unique to a Lisp implementation, Lisp implementation version, +operating system, and hardware architecture." + (flet ((first-of (features) + (loop for f in features + when (find f *features*) return it)) + (maybe-warn (value fstring &rest args) + (cond (value) + (t (apply #'warn fstring args) + "unknown")))) + (let ((lisp (maybe-warn (first-of *implementation-features*) + "No implementation feature found in ~a." + *implementation-features*)) + (os (maybe-warn (first-of *os-features*) + "No os feature found in ~a." *os-features*)) + (arch (maybe-warn (first-of *architecture-features*) + "No architecture feature found in ~a." + *architecture-features*)) + (version (maybe-warn (lisp-version-string) + "Don't know how to get Lisp ~ + implementation version."))) + (format nil "~(~@{~a~^-~}~)" lisp version os arch)))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun string-starts-with (string prefix) + (string-equal string prefix :end1 (min (length string) (length prefix)))) + +(defun slime-version-string () + "Return a string identifying the SLIME version. +Return nil if nothing appropriate is available." + (with-open-file (s (merge-pathnames "slime.el" *source-directory*) + :if-does-not-exist nil) + (when s + (loop with prefix = ";; Version: " + for line = (read-line s nil :eof) + until (eq line :eof) + when (string-starts-with line prefix) + return (subseq line (length prefix)))))) + +(defun default-fasl-dir () + (merge-pathnames + (make-pathname + :directory `(:relative ".slime" "fasl" + ,@(if (slime-version-string) (list (slime-version-string))) + ,(unique-dir-name))) + (user-homedir-pathname))) + +(defvar *fasl-directory* (default-fasl-dir) + "The directory where fasl files should be placed.") + +(defun binary-pathname (src-pathname binary-dir) + "Return the pathname where SRC-PATHNAME's binary should be compiled." + (let ((cfp (compile-file-pathname src-pathname))) + (merge-pathnames (make-pathname :name (pathname-name cfp) + :type (pathname-type cfp)) + binary-dir))) + +(defun handle-swank-load-error (condition context pathname) + (fresh-line *error-output*) + (pprint-logical-block (*error-output* () :per-line-prefix ";; ") + (format *error-output* + "~%Error ~A ~A:~% ~A~%" + context pathname condition))) + +(defun compile-files (files fasl-dir load quiet) + "Compile each file in FILES if the source is newer than its +corresponding binary, or the file preceding it was recompiled. +If LOAD is true, load the fasl file." + (let ((needs-recompile nil) + (state :unknown)) + (dolist (src files) + (let ((dest (binary-pathname src fasl-dir))) + (handler-bind + ((error (lambda (c) + (ecase state + (:compile (handle-swank-load-error c "compiling" src)) + (:load (handle-swank-load-error c "loading" dest)) + (:unknown (handle-swank-load-error c "???ing" src)))))) + (when (or needs-recompile + (not (probe-file dest)) + (file-newer-p src dest)) + (ensure-directories-exist dest) + ;; need to recompile SRC, so we'll need to recompile + ;; everything after this too. + (setf needs-recompile t + state :compile) + (or (compile-file src :output-file dest :print nil + :verbose (not quiet)) + ;; An implementation may not necessarily signal a + ;; condition itself when COMPILE-FILE fails (e.g. ECL) + (error "COMPILE-FILE returned NIL."))) + (when load + (setf state :load) + (load dest :verbose (not quiet)))))))) + +#+cormanlisp +(defun compile-files (files fasl-dir load quiet) + "Corman Lisp has trouble with compiled files." + (declare (ignore fasl-dir)) + (when load + (dolist (file files) + (load file :verbose (not quiet) + (force-output))))) + +(defun load-user-init-file () + "Load the user init file, return NIL if it does not exist." + (load (merge-pathnames (user-homedir-pathname) + (make-pathname :name ".swank" :type "lisp")) + :if-does-not-exist nil)) + +(defun load-site-init-file (dir) + (load (make-pathname :name "site-init" :type "lisp" + :defaults dir) + :if-does-not-exist nil)) + +(defun src-files (names src-dir) + (mapcar (lambda (name) + (multiple-value-bind (dirs name) + (etypecase name + (symbol (values '() name)) + (cons (values (butlast name) (car (last name))))) + (make-pathname + :directory (append (or (pathname-directory src-dir) + '(:relative)) + (mapcar #'string-downcase dirs)) + :name (string-downcase name) + :type "lisp" + :defaults src-dir))) + names)) + +(defvar *swank-files* + `(packages + (swank backend) ,@*sysdep-files* (swank match) (swank rpc) + swank)) + +(defvar *contribs* + '(swank-util swank-repl + swank-c-p-c swank-arglists swank-fuzzy + swank-fancy-inspector + swank-presentations swank-presentation-streams + #+(or asdf2 asdf3 sbcl ecl) swank-asdf + swank-package-fu + swank-hyperdoc + #+sbcl swank-sbcl-exts + swank-mrepl + swank-trace-dialog + swank-macrostep + swank-quicklisp) + "List of names for contrib modules.") + +(defun append-dir (absolute name) + (merge-pathnames + (make-pathname :directory `(:relative ,name) :defaults absolute) + absolute)) + +(defun contrib-dir (base-dir) + (append-dir base-dir "contrib")) + +(defun load-swank (&key (src-dir *source-directory*) + (fasl-dir *fasl-directory*) + quiet) + (with-compilation-unit () + (compile-files (src-files *swank-files* src-dir) fasl-dir t quiet)) + (funcall (q "swank::before-init") + (slime-version-string) + (list (contrib-dir fasl-dir) + (contrib-dir src-dir)))) + +(defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir) + (let ((newest (reduce #'max (mapcar #'file-write-date swank-files)))) + (dolist (src contrib-files) + (let ((fasl (binary-pathname src fasl-dir))) + (when (and (probe-file fasl) + (<= (file-write-date fasl) newest)) + (delete-file fasl)))))) + +(defun compile-contribs (&key (src-dir (contrib-dir *source-directory*)) + (fasl-dir (contrib-dir *fasl-directory*)) + (swank-src-dir *source-directory*) + load quiet) + (let* ((swank-src-files (src-files *swank-files* swank-src-dir)) + (contrib-src-files (src-files *contribs* src-dir))) + (delete-stale-contrib-fasl-files swank-src-files contrib-src-files + fasl-dir) + (compile-files contrib-src-files fasl-dir load quiet))) + +(defun loadup () + (load-swank) + (compile-contribs :load t)) + +(defun setup () + (load-site-init-file *source-directory*) + (load-user-init-file) + (when (#-clisp probe-file + #+clisp ext:probe-directory + (contrib-dir *source-directory*)) + (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))) + (funcall (q "swank::init"))) + +(defun list-swank-packages () + (remove-if-not (lambda (package) + (let ((name (package-name package))) + (and (string-not-equal name "swank-loader") + (string-starts-with name "swank")))) + (list-all-packages))) + +(defun delete-packages (packages) + (dolist (package packages) + (flet ((handle-package-error (c) + (let ((pkgs (set-difference (package-used-by-list package) + packages))) + (when pkgs + (warn "deleting ~a which is used by ~{~a~^, ~}." + package pkgs)) + (continue c)))) + (handler-bind ((package-error #'handle-package-error)) + (delete-package package))))) + +(defun init (&key delete reload load-contribs (setup t) + (quiet (not *load-verbose*)) + from-emacs) + "Load SWANK and initialize some global variables. +If DELETE is true, delete any existing SWANK packages. +If RELOAD is true, reload SWANK, even if the SWANK package already exists. +If LOAD-CONTRIBS is true, load all contribs +If SETUP is true, load user init files and initialize some +global variabes in SWANK." + (when from-emacs + (setf *started-from-emacs* t)) + (when (and delete (find-package :swank)) + (delete-packages (list-swank-packages))) + (cond ((or (not (find-package :swank)) reload) + (load-swank :quiet quiet)) + (t + (warn "Not reloading SWANK. Package already exists."))) + (when load-contribs + (compile-contribs :load t :quiet quiet)) + (when setup + (setup))) + +(defun dump-image (filename) + (init :setup nil) + (funcall (q "swank/backend:save-image") filename)) + +(defun list-fasls (&key (include-contribs t) (compile t) + (quiet (not *compile-verbose*))) + "List up SWANK's fasls along with their dependencies." + (flet ((collect-fasls (files fasl-dir) + (when compile + (compile-files files fasl-dir nil quiet)) + (loop for src in files + when (probe-file (binary-pathname src fasl-dir)) + collect it))) + (append (collect-fasls (src-files *swank-files* *source-directory*) + *fasl-directory*) + (when include-contribs + (collect-fasls (src-files *contribs* + (contrib-dir *source-directory*)) + (contrib-dir *fasl-directory*)))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank.asd b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank.asd new file mode 100644 index 0000000..d9a7627 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank.asd @@ -0,0 +1,37 @@ +;;; -*- lisp -*- + +;; ASDF system definition for loading the Swank server independently +;; of Emacs. +;; +;; This is only useful if you want to start a Swank server in a Lisp +;; processes that doesn't run under Emacs. Lisp processes created by +;; `M-x slime' automatically start the server. + +;; Usage: +;; +;; (require :swank) +;; (swank:create-swank-server PORT) => ACTUAL-PORT +;; +;; (PORT can be zero to mean "any available port".) +;; Then the Swank server is running on localhost:ACTUAL-PORT. You can +;; use `M-x slime-connect' to connect Emacs to it. +;; +;; This code has been placed in the Public Domain. All warranties +;; are disclaimed. + +(defpackage :swank-loader + (:use :cl)) + +(in-package :swank-loader) + +(defclass swank-loader-file (asdf:cl-source-file) ()) + +;;;; after loading run init + +(defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file)) + (load (asdf::component-pathname f)) + (funcall (read-from-string "swank-loader::init") :reload t)) + +(asdf:defsystem :swank + :default-component-class swank-loader-file + :components ((:file "swank-loader"))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank.lisp new file mode 100644 index 0000000..d0ba81b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank.lisp @@ -0,0 +1,3795 @@ +;;;; swank.lisp --- Server for SLIME commands. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; +;;; This file defines the "Swank" TCP server for Emacs to talk to. The +;;; code in this file is purely portable Common Lisp. We do require a +;;; smattering of non-portable functions in order to write the server, +;;; so we have defined them in `swank/backend.lisp' and implemented +;;; them separately for each Lisp implementation. These extensions are +;;; available to us here via the `SWANK/BACKEND' package. + +(in-package :swank) +;;;; Top-level variables, constants, macros + +(defconstant cl-package (find-package :cl) + "The COMMON-LISP package.") + +(defconstant keyword-package (find-package :keyword) + "The KEYWORD package.") + +(defconstant default-server-port 4005 + "The default TCP port for the server (when started manually).") + +(defvar *swank-debug-p* t + "When true, print extra debugging information.") + +(defvar *backtrace-pprint-dispatch-table* + (let ((table (copy-pprint-dispatch nil))) + (flet ((print-string (stream string) + (cond (*print-escape* + (escape-string string stream + :map '((#\" . "\\\"") + (#\\ . "\\\\") + (#\newline . "\\n") + (#\return . "\\r")))) + (t (write-string string stream))))) + (set-pprint-dispatch 'string #'print-string 0 table) + table))) + +(defvar *backtrace-printer-bindings* + `((*print-pretty* . t) + (*print-readably* . nil) + (*print-level* . 4) + (*print-length* . 6) + (*print-lines* . 1) + (*print-right-margin* . 200) + (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*)) + "Pretter settings for printing backtraces.") + +(defvar *default-worker-thread-bindings* '() + "An alist to initialize dynamic variables in worker threads. +The list has the form ((VAR . VALUE) ...). Each variable VAR will be +bound to the corresponding VALUE.") + +(defun call-with-bindings (alist fun) + "Call FUN with variables bound according to ALIST. +ALIST is a list of the form ((VAR . VAL) ...)." + (if (null alist) + (funcall fun) + (let* ((rlist (reverse alist)) + (vars (mapcar #'car rlist)) + (vals (mapcar #'cdr rlist))) + (progv vars vals + (funcall fun))))) + +(defmacro with-bindings (alist &body body) + "See `call-with-bindings'." + `(call-with-bindings ,alist (lambda () ,@body))) + +;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via +;;; RPC. + +(defmacro defslimefun (name arglist &body rest) + "A DEFUN for functions that Emacs can call by RPC." + `(progn + (defun ,name ,arglist ,@rest) + ;; see + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name (symbol-package ',name))))) + +(defun missing-arg () + "A function that the compiler knows will never to return a value. +You can use (MISSING-ARG) as the initform for defstruct slots that +must always be supplied. This way the :TYPE slot option need not +include some arbitrary initial value like NIL." + (error "A required &KEY or &OPTIONAL argument was not supplied.")) + + +;;;; Hooks +;;; +;;; We use Emacs-like `add-hook' and `run-hook' utilities to support +;;; simple indirection. The interface is more CLish than the Emacs +;;; Lisp one. + +(defmacro add-hook (place function) + "Add FUNCTION to the list of values on PLACE." + `(pushnew ,function ,place)) + +(defun run-hook (functions &rest arguments) + "Call each of FUNCTIONS with ARGUMENTS." + (dolist (function functions) + (apply function arguments))) + +(defun run-hook-until-success (functions &rest arguments) + "Call each of FUNCTIONS with ARGUMENTS, stop if any function returns +a truthy value" + (loop for hook in functions + thereis (apply hook arguments))) + +(defvar *new-connection-hook* '() + "This hook is run each time a connection is established. +The connection structure is given as the argument. +Backend code should treat the connection structure as opaque.") + +(defvar *connection-closed-hook* '() + "This hook is run when a connection is closed. +The connection as passed as an argument. +Backend code should treat the connection structure as opaque.") + +(defvar *pre-reply-hook* '() + "Hook run (without arguments) immediately before replying to an RPC.") + +(defvar *after-init-hook* '() + "Hook run after user init files are loaded.") + + +;;;; Connections +;;; +;;; Connection structures represent the network connections between +;;; Emacs and Lisp. Each has a socket stream, a set of user I/O +;;; streams that redirect to Emacs, and optionally a second socket +;;; used solely to pipe user-output to Emacs (an optimization). This +;;; is also the place where we keep everything that needs to be +;;; freed/closed/killed when we disconnect. + +(defstruct (connection + (:constructor %make-connection) + (:conc-name connection.) + (:print-function print-connection)) + ;; The listening socket. (usually closed) + (socket (missing-arg) :type t :read-only t) + ;; Character I/O stream of socket connection. Read-only to avoid + ;; race conditions during initialization. + (socket-io (missing-arg) :type stream :read-only t) + ;; Optional dedicated output socket (backending `user-output' slot). + ;; Has a slot so that it can be closed with the connection. + (dedicated-output nil :type (or stream null)) + ;; Streams that can be used for user interaction, with requests + ;; redirected to Emacs. + (user-input nil :type (or stream null)) + (user-output nil :type (or stream null)) + (user-io nil :type (or stream null)) + ;; Bindings used for this connection (usually streams) + (env '() :type list) + ;; A stream that we use for *trace-output*; if nil, we user user-output. + (trace-output nil :type (or stream null)) + ;; A stream where we send REPL results. + (repl-results nil :type (or stream null)) + ;; Cache of macro-indentation information that has been sent to Emacs. + ;; This is used for preparing deltas to update Emacs's knowledge. + ;; Maps: symbol -> indentation-specification + (indentation-cache (make-hash-table :test 'eq) :type hash-table) + ;; The list of packages represented in the cache: + (indentation-cache-packages '()) + ;; The communication style used. + (communication-style nil :type (member nil :spawn :sigio :fd-handler)) + ) + +(defun print-connection (conn stream depth) + (declare (ignore depth)) + (print-unreadable-object (conn stream :type t :identity t))) + +(defstruct (singlethreaded-connection (:include connection) + (:conc-name sconn.)) + ;; The SIGINT handler we should restore when the connection is + ;; closed. + saved-sigint-handler + ;; A queue of events. Not all events can be processed in order and + ;; we need a place to stored them. + (event-queue '() :type list) + ;; A counter that is incremented whenever an event is added to the + ;; queue. This is used to detected modifications to the event queue + ;; by interrupts. The counter wraps around. + (events-enqueued 0 :type fixnum)) + +(defstruct (multithreaded-connection (:include connection) + (:conc-name mconn.)) + ;; In multithreaded systems we delegate certain tasks to specific + ;; threads. The `reader-thread' is responsible for reading network + ;; requests from Emacs and sending them to the `control-thread'; the + ;; `control-thread' is responsible for dispatching requests to the + ;; threads that should handle them; the `repl-thread' is the one + ;; that evaluates REPL expressions. The control thread dispatches + ;; all REPL evaluations to the REPL thread and for other requests it + ;; spawns new threads. + reader-thread + control-thread + repl-thread + auto-flush-thread + indentation-cache-thread + ;; List of threads that are currently processing requests. We use + ;; this to find the newest/current thread for an interrupt. In the + ;; future we may store here (thread . request-tag) pairs so that we + ;; can interrupt specific requests. + (active-threads '() :type list) + ) + +(defvar *emacs-connection* nil + "The connection to Emacs currently in use.") + +(defun make-connection (socket stream style) + (let ((conn (funcall (ecase style + (:spawn + #'make-multithreaded-connection) + ((:sigio nil :fd-handler) + #'make-singlethreaded-connection)) + :socket socket + :socket-io stream + :communication-style style))) + (run-hook *new-connection-hook* conn) + (send-to-sentinel `(:add-connection ,conn)) + conn)) + +(defslimefun ping (tag) + tag) + +(defun safe-backtrace () + (ignore-errors + (call-with-debugging-environment + (lambda () (backtrace 0 nil))))) + +(define-condition swank-error (error) + ((backtrace :initarg :backtrace :reader swank-error.backtrace) + (condition :initarg :condition :reader swank-error.condition)) + (:report (lambda (c s) (princ (swank-error.condition c) s))) + (:documentation "Condition which carries a backtrace.")) + +(defun signal-swank-error (condition &optional (backtrace (safe-backtrace))) + (error 'swank-error :condition condition :backtrace backtrace)) + +(defvar *debug-on-swank-protocol-error* nil + "When non-nil invoke the system debugger on errors that were +signalled during decoding/encoding the wire protocol. Do not set this +to T unless you want to debug swank internals.") + +(defmacro with-swank-error-handler ((connection) &body body) + "Close the connection on internal `swank-error's." + (let ((conn (gensym))) + `(let ((,conn ,connection)) + (handler-case + (handler-bind ((swank-error + (lambda (condition) + (when *debug-on-swank-protocol-error* + (invoke-default-debugger condition))))) + (progn . ,body)) + (swank-error (condition) + (close-connection ,conn + (swank-error.condition condition) + (swank-error.backtrace condition))))))) + +(defmacro with-panic-handler ((connection) &body body) + "Close the connection on unhandled `serious-condition's." + (let ((conn (gensym))) + `(let ((,conn ,connection)) + (handler-bind ((serious-condition + (lambda (condition) + (close-connection ,conn condition (safe-backtrace)) + (abort condition)))) + . ,body)))) + +(add-hook *new-connection-hook* 'notify-backend-of-connection) +(defun notify-backend-of-connection (connection) + (declare (ignore connection)) + (emacs-connected)) + + +;;;; Utilities + + +;;;;; Logging + +(defvar *swank-io-package* + (let ((package (make-package :swank-io-package :use '()))) + (import '(nil t quote) package) + package)) + +(defvar *log-events* nil) + +(defun init-log-output () + (unless *log-output* + (setq *log-output* (real-output-stream *error-output*)))) + +(add-hook *after-init-hook* 'init-log-output) + +(defun real-input-stream (stream) + (typecase stream + (synonym-stream + (real-input-stream (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (real-input-stream (two-way-stream-input-stream stream))) + (t stream))) + +(defun real-output-stream (stream) + (typecase stream + (synonym-stream + (real-output-stream (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (real-output-stream (two-way-stream-output-stream stream))) + (t stream))) + +(defvar *event-history* (make-array 40 :initial-element nil) + "A ring buffer to record events for better error messages.") +(defvar *event-history-index* 0) +(defvar *enable-event-history* t) + +(defun log-event (format-string &rest args) + "Write a message to *terminal-io* when *log-events* is non-nil. +Useful for low level debugging." + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-pretty* nil) + (*package* *swank-io-package*)) + (when *enable-event-history* + (setf (aref *event-history* *event-history-index*) + (format nil "~?" format-string args)) + (setf *event-history-index* + (mod (1+ *event-history-index*) (length *event-history*)))) + (when *log-events* + (write-string (escape-non-ascii (format nil "~?" format-string args)) + *log-output*) + (force-output *log-output*))))) + +(defun event-history-to-list () + "Return the list of events (older events first)." + (let ((arr *event-history*) + (idx *event-history-index*)) + (concatenate 'list (subseq arr idx) (subseq arr 0 idx)))) + +(defun clear-event-history () + (fill *event-history* nil) + (setq *event-history-index* 0)) + +(defun dump-event-history (stream) + (dolist (e (event-history-to-list)) + (dump-event e stream))) + +(defun dump-event (event stream) + (cond ((stringp event) + (write-string (escape-non-ascii event) stream)) + ((null event)) + (t + (write-string + (escape-non-ascii (format nil "Unexpected event: ~A~%" event)) + stream)))) + +(defun escape-non-ascii (string) + "Return a string like STRING but with non-ascii chars escaped." + (cond ((ascii-string-p string) string) + (t (with-output-to-string (out) + (loop for c across string do + (cond ((ascii-char-p c) (write-char c out)) + (t (format out "\\x~4,'0X" (char-code c))))))))) + +(defun ascii-string-p (o) + (and (stringp o) + (every #'ascii-char-p o))) + +(defun ascii-char-p (c) + (<= (char-code c) 127)) + + +;;;;; Helper macros + +(defmacro dcase (value &body patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(loop for (pattern . body) in patterns collect + (if (eq pattern t) + `(t ,@body) + (destructuring-bind (op &rest rands) pattern + `(,op (destructuring-bind ,rands ,operands + ,@body))))) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "dcase failed: ~S" ,tmp)))))))) + + +;;;; Interrupt handling + +;; Usually we'd like to enter the debugger when an interrupt happens. +;; But for some operations, in particular send&receive, it's crucial +;; that those are not interrupted when the mailbox is in an +;; inconsistent/locked state. Obviously, if send&receive don't work we +;; can't communicate and the debugger will not work. To solve that +;; problem, we try to handle interrupts only at certain safe-points. +;; +;; Whenever an interrupt happens we call the function +;; INVOKE-OR-QUEUE-INTERRUPT. Usually this simply invokes the +;; debugger, but if interrupts are disabled the interrupt is put in a +;; queue for later processing. At safe-points, we call +;; CHECK-SLIME-INTERRUPTS which looks at the queue and invokes the +;; debugger if needed. +;; +;; The queue for interrupts is stored in a thread local variable. +;; WITH-CONNECTION sets it up. WITH-SLIME-INTERRUPTS allows +;; interrupts, i.e. the debugger is entered immediately. When we call +;; "user code" or non-problematic code we allow interrupts. When +;; inside WITHOUT-SLIME-INTERRUPTS, interrupts are queued. When we +;; switch from "user code" to more delicate operations we need to +;; disable interrupts. In particular, interrupts should be disabled +;; for SEND and RECEIVE-IF. + +;; If true execute interrupts, otherwise queue them. +;; Note: `with-connection' binds *pending-slime-interrupts*. +(defvar *slime-interrupts-enabled*) + +(defmacro with-interrupts-enabled% (flag body) + `(progn + ,@(if flag '((check-slime-interrupts))) + (multiple-value-prog1 + (let ((*slime-interrupts-enabled* ,flag)) + ,@body) + ,@(if flag '((check-slime-interrupts)))))) + +(defmacro with-slime-interrupts (&body body) + `(with-interrupts-enabled% t ,body)) + +(defmacro without-slime-interrupts (&body body) + `(with-interrupts-enabled% nil ,body)) + +(defun queue-thread-interrupt (thread function) + (interrupt-thread thread + (lambda () + ;; safely interrupt THREAD + (when (invoke-or-queue-interrupt function) + (wake-thread thread))))) + +(defun invoke-or-queue-interrupt (function) + (log-event "invoke-or-queue-interrupt: ~a~%" function) + (cond ((not (boundp '*slime-interrupts-enabled*)) + (without-slime-interrupts + (funcall function))) + (*slime-interrupts-enabled* + (log-event "interrupts-enabled~%") + (funcall function)) + (t + (setq *pending-slime-interrupts* + (nconc *pending-slime-interrupts* + (list function))) + (cond ((cdr *pending-slime-interrupts*) + (log-event "too many queued interrupts~%") + (with-simple-restart (continue "Continue from interrupt") + (handler-bind ((serious-condition #'invoke-slime-debugger)) + (check-slime-interrupts)))) + (t + (log-event "queue-interrupt: ~a~%" function) + (when *interrupt-queued-handler* + (funcall *interrupt-queued-handler*)) + t))))) + + +;;; FIXME: poor name? +(defmacro with-io-redirection ((connection) &body body) + "Execute BODY I/O redirection to CONNECTION. " + `(with-bindings (connection.env ,connection) + . ,body)) + +;; Thread local variable used for flow-control. +;; It's bound by `with-connection'. +(defvar *send-counter*) + +(defmacro with-connection ((connection) &body body) + "Execute BODY in the context of CONNECTION." + `(let ((connection ,connection) + (function (lambda () . ,body))) + (if (eq *emacs-connection* connection) + (funcall function) + (let ((*emacs-connection* connection) + (*pending-slime-interrupts* '()) + (*send-counter* 0)) + (without-slime-interrupts + (with-swank-error-handler (connection) + (with-io-redirection (connection) + (call-with-debugger-hook #'swank-debugger-hook + function)))))))) + +(defun call-with-retry-restart (msg thunk) + (loop (with-simple-restart (retry "~a" msg) + (return (funcall thunk))))) + +(defmacro with-retry-restart ((&key (msg "Retry.")) &body body) + (check-type msg string) + `(call-with-retry-restart ,msg (lambda () ,@body))) + +(defmacro with-struct* ((conc-name get obj) &body body) + (let ((var (gensym))) + `(let ((,var ,obj)) + (macrolet ((,get (slot) + (let ((getter (intern (concatenate 'string + ',(string conc-name) + (string slot)) + (symbol-package ',conc-name)))) + `(,getter ,',var)))) + ,@body)))) + +(defmacro define-special (name doc) + "Define a special variable NAME with doc string DOC. +This is like defvar, but NAME will not be initialized." + `(progn + (defvar ,name) + (setf (documentation ',name 'variable) ,doc))) + + +;;;;; Sentinel +;;; +;;; The sentinel thread manages some global lists. +;;; FIXME: Overdesigned? + +(defvar *connections* '() + "List of all active connections, with the most recent at the front.") + +(defvar *servers* '() + "A list ((server-socket port thread) ...) describing the listening sockets. +Used to close sockets on server shutdown or restart.") + +;; FIXME: we simply access the global variable here. We could ask the +;; sentinel thread instead but then we still have the problem that the +;; connection could be closed before we use it. +(defun default-connection () + "Return the 'default' Emacs connection. +This connection can be used to talk with Emacs when no specific +connection is in use, i.e. *EMACS-CONNECTION* is NIL. + +The default connection is defined (quite arbitrarily) as the most +recently established one." + (car *connections*)) + +(defun start-sentinel () + (unless (find-registered 'sentinel) + (let ((thread (spawn #'sentinel :name "Swank Sentinel"))) + (register-thread 'sentinel thread)))) + +(defun sentinel () + (catch 'exit-sentinel + (loop (sentinel-serve (receive))))) + +(defun send-to-sentinel (msg) + (let ((sentinel (find-registered 'sentinel))) + (cond (sentinel (send sentinel msg)) + (t (sentinel-serve msg))))) + +(defun sentinel-serve (msg) + (dcase msg + ((:add-connection conn) + (push conn *connections*)) + ((:close-connection connection condition backtrace) + (close-connection% connection condition backtrace) + (sentinel-maybe-exit)) + ((:add-server socket port thread) + (push (list socket port thread) *servers*)) + ((:stop-server key port) + (sentinel-stop-server key port) + (sentinel-maybe-exit)))) + +(defun sentinel-stop-server (key value) + (let ((probe (find value *servers* :key (ecase key + (:socket #'car) + (:port #'cadr))))) + (cond (probe + (setq *servers* (delete probe *servers*)) + (destructuring-bind (socket _port thread) probe + (declare (ignore _port)) + (ignore-errors (close-socket socket)) + (when (and thread + (thread-alive-p thread) + (not (eq thread (current-thread)))) + (ignore-errors (kill-thread thread))))) + (t + (warn "No server for ~s: ~s" key value))))) + +(defun sentinel-maybe-exit () + (when (and (null *connections*) + (null *servers*) + (and (current-thread) + (eq (find-registered 'sentinel) + (current-thread)))) + (register-thread 'sentinel nil) + (throw 'exit-sentinel nil))) + + +;;;;; Misc + +(defun use-threads-p () + (eq (connection.communication-style *emacs-connection*) :spawn)) + +(defun current-thread-id () + (thread-id (current-thread))) + +(declaim (inline ensure-list)) +(defun ensure-list (thing) + (if (listp thing) thing (list thing))) + + +;;;;; Symbols + +;; FIXME: this docstring is more confusing than helpful. +(defun symbol-status (symbol &optional (package (symbol-package symbol))) + "Returns one of + + :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol, + + :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol, + + :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE, + but is not _present_ in PACKAGE, + + or NIL if SYMBOL is not _accessible_ in PACKAGE. + + +Be aware not to get confused with :INTERNAL and how \"internal +symbols\" are defined in the spec; there is a slight mismatch of +definition with the Spec and what's commonly meant when talking +about internal symbols most times. As the spec says: + + In a package P, a symbol S is + + _accessible_ if S is either _present_ in P itself or was + inherited from another package Q (which implies + that S is _external_ in Q.) + + You can check that with: (AND (SYMBOL-STATUS S P) T) + + + _present_ if either P is the /home package/ of S or S has been + imported into P or exported from P by IMPORT, or + EXPORT respectively. + + Or more simply, if S is not _inherited_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :INHERITED)))) + + + _external_ if S is going to be inherited into any package that + /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or + DEFPACKAGE. + + Note that _external_ implies _present_, since to + make a symbol _external_, you'd have to use EXPORT + which will automatically make the symbol _present_. + + You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL) + + + _internal_ if S is _accessible_ but not _external_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :EXTERNAL)))) + + + Notice that this is *different* to + (EQ (SYMBOL-STATUS S P) :INTERNAL) + because what the spec considers _internal_ is split up into two + explicit pieces: :INTERNAL, and :INHERITED; just as, for instance, + CL:FIND-SYMBOL does. + + The rationale is that most times when you speak about \"internal\" + symbols, you're actually not including the symbols inherited + from other packages, but only about the symbols directly specific + to the package in question. +" + (when package ; may be NIL when symbol is completely uninterned. + (check-type symbol symbol) (check-type package package) + (multiple-value-bind (present-symbol status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol present-symbol) status)))) + +(defun symbol-external-p (symbol &optional (package (symbol-package symbol))) + "True if SYMBOL is external in PACKAGE. +If PACKAGE is not specified, the home package of SYMBOL is used." + (eq (symbol-status symbol package) :external)) + + +;;;; TCP Server + +(defvar *communication-style* (preferred-communication-style)) + +(defvar *dont-close* nil + "Default value of :dont-close argument to start-server and + create-server.") + +(defparameter *loopback-interface* "localhost") + +(defun start-server (port-file &key (style *communication-style*) + (dont-close *dont-close*)) + "Start the server and write the listen port number to PORT-FILE. +This is the entry point for Emacs." + (setup-server 0 + (lambda (port) (announce-server-port port-file port)) + style dont-close nil)) + +(defun create-server (&key (port default-server-port) + (style *communication-style*) + (dont-close *dont-close*) + interface + backlog) + "Start a SWANK server on PORT running in STYLE. +If DONT-CLOSE is true then the listen socket will accept multiple +connections, otherwise it will be closed after the first. + +Optionally, an INTERFACE could be specified and swank will bind +the PORT on this interface. By default, interface is \"localhost\"." + (let ((*loopback-interface* (or interface + *loopback-interface*))) + (setup-server port #'simple-announce-function + style dont-close backlog))) + +(defun find-external-format-or-lose (coding-system) + (or (find-external-format coding-system) + (error "Unsupported coding system: ~s" coding-system))) + +(defmacro restart-loop (form &body clauses) + "Executes FORM, with restart-case CLAUSES which have a chance to modify FORM's +environment before trying again (by returning normally) or giving up (through an +explicit transfer of control), all within an implicit block named nil. +e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))" + `(loop (restart-case (return ,form) ,@clauses))) + +(defun socket-quest (port backlog) + (restart-loop (create-socket *loopback-interface* port :backlog backlog) + (use-value (&optional (new-port (1+ port))) + :report (lambda (stream) (format stream "Try a port other than ~D" port)) + :interactive + (lambda () + (format *query-io* "Enter port (defaults to ~D): " (1+ port)) + (finish-output *query-io*) ; necessary for tunnels + (ignore-errors (list (parse-integer (read-line *query-io*))))) + (setq port new-port)))) + +(defun setup-server (port announce-fn style dont-close backlog) + (init-log-output) + (let* ((socket (socket-quest port backlog)) + (port (local-port socket))) + (funcall announce-fn port) + (labels ((serve () (accept-connections socket style dont-close)) + (note () (send-to-sentinel `(:add-server ,socket ,port + ,(current-thread)))) + (serve-loop () (note) (loop do (serve) while dont-close))) + (ecase style + (:spawn (initialize-multiprocessing + (lambda () + (start-sentinel) + (spawn #'serve-loop :name (format nil "Swank ~s" port))))) + ((:fd-handler :sigio) + (note) + (add-fd-handler socket #'serve)) + ((nil) (serve-loop)))) + port)) + +(defun stop-server (port) + "Stop server running on PORT." + (send-to-sentinel `(:stop-server :port ,port))) + +(defun restart-server (&key (port default-server-port) + (style *communication-style*) + (dont-close *dont-close*)) + "Stop the server listening on PORT, then start a new SWANK server +on PORT running in STYLE. If DONT-CLOSE is true then the listen socket +will accept multiple connections, otherwise it will be closed after the +first." + (stop-server port) + (sleep 5) + (create-server :port port :style style :dont-close dont-close)) + +(defun accept-connections (socket style dont-close) + (unwind-protect + (let ((client (accept-connection socket :external-format nil + :buffering t))) + (authenticate-client client) + (serve-requests (make-connection socket client style))) + (unless dont-close + (send-to-sentinel `(:stop-server :socket ,socket))))) + +(defun authenticate-client (stream) + (let ((secret (slime-secret))) + (when secret + (set-stream-timeout stream 20) + (let ((first-val (read-packet stream))) + (unless (and (stringp first-val) (string= first-val secret)) + (error "Incoming connection doesn't know the password."))) + (set-stream-timeout stream nil)))) + +(defun slime-secret () + "Finds the magic secret from the user's home directory. Returns nil +if the file doesn't exist; otherwise the first line of the file." + (with-open-file (in + (merge-pathnames (user-homedir-pathname) #p".slime-secret") + :if-does-not-exist nil) + (and in (read-line in nil "")))) + +(defun serve-requests (connection) + "Read and process all requests on connections." + (etypecase connection + (multithreaded-connection + (spawn-threads-for-connection connection)) + (singlethreaded-connection + (ecase (connection.communication-style connection) + ((nil) (simple-serve-requests connection)) + (:sigio (install-sigio-handler connection)) + (:fd-handler (install-fd-handler connection)))))) + +(defun stop-serving-requests (connection) + (etypecase connection + (multithreaded-connection + (cleanup-connection-threads connection)) + (singlethreaded-connection + (ecase (connection.communication-style connection) + ((nil)) + (:sigio (deinstall-sigio-handler connection)) + (:fd-handler (deinstall-fd-handler connection)))))) + +(defun announce-server-port (file port) + (with-open-file (s file + :direction :output + :if-exists :error + :if-does-not-exist :create) + (format s "~S~%" port)) + (simple-announce-function port)) + +(defun simple-announce-function (port) + (when *swank-debug-p* + (format *log-output* "~&;; Swank started at port: ~D.~%" port) + (force-output *log-output*))) + + +;;;;; Event Decoding/Encoding + +(defun decode-message (stream) + "Read an S-expression from STREAM using the SLIME protocol." + (log-event "decode-message~%") + (without-slime-interrupts + (handler-bind ((error #'signal-swank-error)) + (handler-case (read-message stream *swank-io-package*) + (swank-reader-error (c) + `(:reader-error ,(swank-reader-error.packet c) + ,(swank-reader-error.cause c))))))) + +(defun encode-message (message stream) + "Write an S-expression to STREAM using the SLIME protocol." + (log-event "encode-message~%") + (without-slime-interrupts + (handler-bind ((error #'signal-swank-error)) + (write-message message *swank-io-package* stream)))) + + +;;;;; Event Processing + +(defvar *sldb-quit-restart* nil + "The restart that will be invoked when the user calls sldb-quit.") + +;; Establish a top-level restart and execute BODY. +;; Execute K if the restart is invoked. +(defmacro with-top-level-restart ((connection k) &body body) + `(with-connection (,connection) + (restart-case + (let ((*sldb-quit-restart* (find-restart 'abort))) + ,@body) + (abort (&optional v) + :report "Return to SLIME's top level." + (declare (ignore v)) + (force-user-output) + ,k)))) + +(defun handle-requests (connection &optional timeout) + "Read and process :emacs-rex requests. +The processing is done in the extent of the toplevel restart." + (with-connection (connection) + (cond (*sldb-quit-restart* + (process-requests timeout)) + (t + (tagbody + start + (with-top-level-restart (connection (go start)) + (process-requests timeout))))))) + +(defun process-requests (timeout) + "Read and process requests from Emacs." + (loop + (multiple-value-bind (event timeout?) + (wait-for-event `(or (:emacs-rex . _) + (:emacs-channel-send . _)) + timeout) + (when timeout? (return)) + (dcase event + ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) + ((:emacs-channel-send channel (selector &rest args)) + (channel-send channel selector args)))))) + +(defun current-socket-io () + (connection.socket-io *emacs-connection*)) + +(defun close-connection (connection condition backtrace) + (send-to-sentinel `(:close-connection ,connection ,condition ,backtrace))) + +(defun close-connection% (c condition backtrace) + (let ((*debugger-hook* nil)) + (log-event "close-connection: ~a ...~%" condition) + (format *log-output* "~&;; swank:close-connection: ~A~%" + (escape-non-ascii (safe-condition-message condition))) + (stop-serving-requests c) + (close (connection.socket-io c)) + (when (connection.dedicated-output c) + (close (connection.dedicated-output c))) + (setf *connections* (remove c *connections*)) + (run-hook *connection-closed-hook* c) + (when (and condition (not (typep condition 'end-of-file))) + (finish-output *log-output*) + (format *log-output* "~&;; Event history start:~%") + (dump-event-history *log-output*) + (format *log-output* "~ +;; Event history end.~%~ +;; Backtrace:~%~{~A~%~}~ +;; Connection to Emacs lost. [~%~ +;; condition: ~A~%~ +;; type: ~S~%~ +;; style: ~S]~%" + (loop for (i f) in backtrace collect + (ignore-errors + (format nil "~d: ~a" i (escape-non-ascii f)))) + (escape-non-ascii (safe-condition-message condition) ) + (type-of condition) + (connection.communication-style c))) + (finish-output *log-output*) + (log-event "close-connection ~a ... done.~%" condition))) + +;;;;;; Thread based communication + +(defun read-loop (connection) + (let ((input-stream (connection.socket-io connection)) + (control-thread (mconn.control-thread connection))) + (with-swank-error-handler (connection) + (loop (send control-thread (decode-message input-stream)))))) + +(defun dispatch-loop (connection) + (let ((*emacs-connection* connection)) + (with-panic-handler (connection) + (loop (dispatch-event connection (receive)))))) + +(defgeneric thread-for-evaluation (connection id) + (:documentation "Find or create a thread to evaluate the next request.") + (:method ((connection multithreaded-connection) (id (eql t))) + (spawn-worker-thread connection)) + (:method ((connection multithreaded-connection) (id (eql :find-existing))) + (car (mconn.active-threads connection))) + (:method (connection (id integer)) + (declare (ignorable connection)) + (find-thread id)) + (:method ((connection singlethreaded-connection) id) + (declare (ignorable connection connection id)) + (current-thread))) + +(defun interrupt-worker-thread (connection id) + (let ((thread (thread-for-evaluation connection + (cond ((eq id t) :find-existing) + (t id))))) + (log-event "interrupt-worker-thread: ~a ~a~%" id thread) + (if thread + (etypecase connection + (multithreaded-connection + (queue-thread-interrupt thread #'simple-break)) + (singlethreaded-connection + (simple-break))) + (encode-message (list :debug-condition (current-thread-id) + (format nil "Thread with id ~a not found" + id)) + (current-socket-io))))) + +(defun spawn-worker-thread (connection) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (with-top-level-restart (connection nil) + (apply #'eval-for-emacs + (cdr (wait-for-event `(:emacs-rex . _))))))) + :name "worker")) + +(defun add-active-thread (connection thread) + (etypecase connection + (multithreaded-connection + (push thread (mconn.active-threads connection))) + (singlethreaded-connection))) + +(defun remove-active-thread (connection thread) + (etypecase connection + (multithreaded-connection + (setf (mconn.active-threads connection) + (delete thread (mconn.active-threads connection) :count 1))) + (singlethreaded-connection))) + +(defparameter *event-hook* nil) + +(defun dispatch-event (connection event) + "Handle an event triggered either by Emacs or within Lisp." + (log-event "dispatch-event: ~s~%" event) + (or (run-hook-until-success *event-hook* connection event) + (dcase event + ((:emacs-rex form package thread-id id) + (let ((thread (thread-for-evaluation connection thread-id))) + (cond (thread + (add-active-thread connection thread) + (send-event thread `(:emacs-rex ,form ,package ,id))) + (t + (encode-message + (list :invalid-rpc id + (format nil "Thread not found: ~s" thread-id)) + (current-socket-io)))))) + ((:return thread &rest args) + (remove-active-thread connection thread) + (encode-message `(:return ,@args) (current-socket-io))) + ((:emacs-interrupt thread-id) + (interrupt-worker-thread connection thread-id)) + (((:write-string + :debug :debug-condition :debug-activate :debug-return :channel-send + :presentation-start :presentation-end + :new-package :new-features :ed :indentation-update + :eval :eval-no-wait :background-message :inspect :ping + :y-or-n-p :read-from-minibuffer :read-string :read-aborted :test-delay + :write-image :ed-rpc :ed-rpc-no-wait) + &rest _) + (declare (ignore _)) + (encode-message event (current-socket-io))) + (((:emacs-pong :emacs-return :emacs-return-string :ed-rpc-forbidden) + thread-id &rest args) + (send-event (find-thread thread-id) (cons (car event) args))) + ((:emacs-channel-send channel-id msg) + (let ((ch (find-channel channel-id))) + (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg)))) + ((:reader-error packet condition) + (encode-message `(:reader-error ,packet + ,(safe-condition-message condition)) + (current-socket-io)))))) + + +(defun send-event (thread event) + (log-event "send-event: ~s ~s~%" thread event) + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (send thread event)) + (singlethreaded-connection + (setf (sconn.event-queue c) (nconc (sconn.event-queue c) (list event))) + (setf (sconn.events-enqueued c) (mod (1+ (sconn.events-enqueued c)) + most-positive-fixnum)))))) + +(defun send-to-emacs (event) + "Send EVENT to Emacs." + ;;(log-event "send-to-emacs: ~a" event) + (without-slime-interrupts + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (send (mconn.control-thread c) event)) + (singlethreaded-connection + (dispatch-event c event))) + (maybe-slow-down)))) + + +;;;;;; Flow control + +;; After sending N (usually 100) messages we slow down and ping Emacs +;; to make sure that everything we have sent so far was received. + +(defconstant send-counter-limit 100) + +(defun maybe-slow-down () + (let ((counter (incf *send-counter*))) + (when (< send-counter-limit counter) + (setf *send-counter* 0) + (ping-pong)))) + +(defun ping-pong () + (let* ((tag (make-tag)) + (pattern `(:emacs-pong ,tag))) + (send-to-emacs `(:ping ,(current-thread-id) ,tag)) + (wait-for-event pattern))) + + +(defun wait-for-event (pattern &optional timeout) + "Scan the event queue for PATTERN and return the event. +If TIMEOUT is 'nil wait until a matching event is enqued. +If TIMEOUT is 't only scan the queue without waiting. +The second return value is t if the timeout expired before a matching +event was found." + (log-event "wait-for-event: ~s ~s~%" pattern timeout) + (without-slime-interrupts + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (receive-if (lambda (e) (event-match-p e pattern)) timeout)) + (singlethreaded-connection + (wait-for-event/event-loop c pattern timeout)))))) + +(defun wait-for-event/event-loop (connection pattern timeout) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (let ((event (poll-for-event connection pattern))) + (when event (return (car event)))) + (let ((events-enqueued (sconn.events-enqueued connection)) + (ready (wait-for-input (list (current-socket-io)) timeout))) + (cond ((and timeout (not ready)) + (return (values nil t))) + ((or (/= events-enqueued (sconn.events-enqueued connection)) + (eq ready :interrupt)) + ;; rescan event queue, interrupts may enqueue new events + ) + (t + (assert (equal ready (list (current-socket-io)))) + (dispatch-event connection + (decode-message (current-socket-io)))))))) + +(defun poll-for-event (connection pattern) + (let* ((c connection) + (tail (member-if (lambda (e) (event-match-p e pattern)) + (sconn.event-queue c)))) + (when tail + (setf (sconn.event-queue c) + (nconc (ldiff (sconn.event-queue c) tail) (cdr tail))) + tail))) + +;;; FIXME: Make this use SWANK-MATCH. +(defun event-match-p (event pattern) + (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) + (member pattern '(nil t))) + (equal event pattern)) + ((symbolp pattern) t) + ((consp pattern) + (case (car pattern) + ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern))) + (t (and (consp event) + (and (event-match-p (car event) (car pattern)) + (event-match-p (cdr event) (cdr pattern))))))) + (t (error "Invalid pattern: ~S" pattern)))) + + + +(defun spawn-threads-for-connection (connection) + (setf (mconn.control-thread connection) + (spawn (lambda () (control-thread connection)) + :name "control-thread")) + connection) + +(defun control-thread (connection) + (with-struct* (mconn. @ connection) + (setf (@ control-thread) (current-thread)) + (setf (@ reader-thread) (spawn (lambda () (read-loop connection)) + :name "reader-thread")) + (setf (@ indentation-cache-thread) + (spawn (lambda () (indentation-cache-loop connection)) + :name "swank-indentation-cache-thread")) + (dispatch-loop connection))) + +(defun cleanup-connection-threads (connection) + (let* ((c connection) + (threads (list (mconn.repl-thread c) + (mconn.reader-thread c) + (mconn.control-thread c) + (mconn.auto-flush-thread c) + (mconn.indentation-cache-thread c)))) + (dolist (thread threads) + (when (and thread + (thread-alive-p thread) + (not (equal (current-thread) thread))) + (ignore-errors (kill-thread thread)))))) + +;;;;;; Signal driven IO + +(defun install-sigio-handler (connection) + (add-sigio-handler (connection.socket-io connection) + (lambda () (process-io-interrupt connection))) + (handle-requests connection t)) + +(defvar *io-interupt-level* 0) + +(defun process-io-interrupt (connection) + (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*) + (let ((*io-interupt-level* (1+ *io-interupt-level*))) + (invoke-or-queue-interrupt + (lambda () (handle-requests connection t)))) + (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*)) + +(defun deinstall-sigio-handler (connection) + (log-event "deinstall-sigio-handler...~%") + (remove-sigio-handlers (connection.socket-io connection)) + (log-event "deinstall-sigio-handler...done~%")) + +;;;;;; SERVE-EVENT based IO + +(defun install-fd-handler (connection) + (add-fd-handler (connection.socket-io connection) + (lambda () (handle-requests connection t))) + (setf (sconn.saved-sigint-handler connection) + (install-sigint-handler + (lambda () + (invoke-or-queue-interrupt + (lambda () (dispatch-interrupt-event connection)))))) + (handle-requests connection t)) + +(defun dispatch-interrupt-event (connection) + (with-connection (connection) + (dispatch-event connection `(:emacs-interrupt ,(current-thread-id))))) + +(defun deinstall-fd-handler (connection) + (log-event "deinstall-fd-handler~%") + (remove-fd-handlers (connection.socket-io connection)) + (install-sigint-handler (sconn.saved-sigint-handler connection))) + +;;;;;; Simple sequential IO + +(defun simple-serve-requests (connection) + (unwind-protect + (with-connection (connection) + (call-with-user-break-handler + (lambda () + (invoke-or-queue-interrupt + (lambda () (dispatch-interrupt-event connection)))) + (lambda () + (with-simple-restart (close-connection "Close SLIME connection.") + (let* ((stdin (real-input-stream *standard-input*)) + (*standard-input* (make-repl-input-stream connection + stdin))) + (tagbody toplevel + (with-top-level-restart (connection (go toplevel)) + (simple-repl)))))))) + (close-connection connection nil (safe-backtrace)))) + +;; this is signalled when our custom stream thinks the end-of-file is reached. +;; (not when the end-of-file on the socket is reached) +(define-condition end-of-repl-input (end-of-file) ()) + +(defun simple-repl () + (loop + (format t "~a> " (package-string-for-prompt *package*)) + (force-output) + (let ((form (handler-case (read) + (end-of-repl-input () (return))))) + (let ((- form) + (values (multiple-value-list (eval form)))) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + form) + (cond ((null values) (format t "; No values~&")) + (t (mapc (lambda (v) (format t "~s~&" v)) values))))))) + +(defun make-repl-input-stream (connection stdin) + (make-input-stream + (lambda () (repl-input-stream-read connection stdin)))) + +(defun repl-input-stream-read (connection stdin) + (loop + (let* ((socket (connection.socket-io connection)) + (inputs (list socket stdin)) + (ready (wait-for-input inputs))) + (cond ((eq ready :interrupt) + (check-slime-interrupts)) + ((member socket ready) + ;; A Slime request from Emacs is pending; make sure to + ;; redirect IO to the REPL buffer. + (with-simple-restart (process-input "Continue reading input.") + (let ((*sldb-quit-restart* (find-restart 'process-input))) + (with-io-redirection (connection) + (handle-requests connection t))))) + ((member stdin ready) + ;; User typed something into the *inferior-lisp* buffer, + ;; so do not redirect. + (return (read-non-blocking stdin))) + (t (assert (null ready))))))) + +(defun read-non-blocking (stream) + (with-output-to-string (str) + (handler-case + (loop (let ((c (read-char-no-hang stream))) + (unless c (return)) + (write-char c str))) + (end-of-file () (error 'end-of-repl-input :stream stream))))) + + +;;; Channels + +;; FIXME: should be per connection not global. +(defvar *channels* '()) +(defvar *channel-counter* 0) + +(defclass channel () + ((id :reader channel-id) + (thread :initarg :thread :initform (current-thread) :reader channel-thread) + (name :initarg :name :initform nil))) + +(defmethod initialize-instance :after ((ch channel) &key) + (with-slots (id) ch + (setf id (incf *channel-counter*)) + (push (cons id ch) *channels*))) + +(defmethod print-object ((c channel) stream) + (print-unreadable-object (c stream :type t) + (with-slots (id name) c + (format stream "~d ~a" id name)))) + +(defun find-channel (id) + (cdr (assoc id *channels*))) + +(defgeneric channel-send (channel selector args)) + +(defmacro define-channel-method (selector (channel &rest args) &body body) + `(defmethod channel-send (,channel (selector (eql ',selector)) args) + (destructuring-bind ,args args + . ,body))) + +(defun send-to-remote-channel (channel-id msg) + (send-to-emacs `(:channel-send ,channel-id ,msg))) + + + +(defvar *slime-features* nil + "The feature list that has been sent to Emacs.") + +(defun send-oob-to-emacs (object) + (send-to-emacs object)) + +;; FIXME: belongs to swank-repl.lisp +(defun force-user-output () + (force-output (connection.user-io *emacs-connection*))) + +(add-hook *pre-reply-hook* 'force-user-output) + +;; FIXME: belongs to swank-repl.lisp +(defun clear-user-input () + (clear-input (connection.user-input *emacs-connection*))) + +;; FIXME: not thread save. +(defvar *tag-counter* 0) + +(defun make-tag () + (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22)))) + +(defun y-or-n-p-in-emacs (format-string &rest arguments) + "Like y-or-n-p, but ask in the Emacs minibuffer." + (let ((tag (make-tag)) + (question (apply #'format nil format-string arguments))) + (force-output) + (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question)) + (third (wait-for-event `(:emacs-return ,tag result))))) + +(defun read-from-minibuffer-in-emacs (prompt &optional initial-value) + "Ask user a question in Emacs' minibuffer. Returns \"\" when user +entered nothing, returns NIL when user pressed C-g." + (check-type prompt string) (check-type initial-value (or null string)) + (let ((tag (make-tag))) + (force-output) + (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag + ,prompt ,initial-value)) + (third (wait-for-event `(:emacs-return ,tag result))))) + +(defstruct (unreadable-result + (:constructor make-unreadable-result (string)) + (:copier nil) + (:print-object + (lambda (object stream) + (print-unreadable-object (object stream :type t) + (princ (unreadable-result-string object) stream))))) + string) + +(defun symbol-name-for-emacs (symbol) + (check-type symbol symbol) + (let ((name (string-downcase (symbol-name symbol)))) + (if (keywordp symbol) + (concatenate 'string ":" name) + name))) + +(defun process-form-for-emacs (form) + "Returns a string which emacs will read as equivalent to +FORM. FORM can contain lists, strings, characters, symbols and +numbers. + +Characters are converted emacs' ? notaion, strings are left +as they are (except for espacing any nested \" chars, numbers are +printed in base 10 and symbols are printed as their symbol-name +converted to lower case." + (etypecase form + (string (format nil "~S" form)) + (cons (format nil "(~A . ~A)" + (process-form-for-emacs (car form)) + (process-form-for-emacs (cdr form)))) + (character (format nil "?~C" form)) + (symbol (symbol-name-for-emacs form)) + (number (let ((*print-base* 10)) + (princ-to-string form))))) + +(defun wait-for-emacs-return (tag) + (let ((event (caddr (wait-for-event `(:emacs-return ,tag result))))) + (dcase event + ((:unreadable value) (make-unreadable-result value)) + ((:ok value) value) + ((:error kind . data) (error "~a: ~{~a~}" kind data)) + ((:abort) (abort)) + ;; only in reply to :ed-rpc{-no-wait} events. + ((:ed-rpc-forbidden fn) (error "ED-RPC forbidden for ~a" fn))))) + +(defun eval-in-emacs (form &optional nowait) + "Eval FORM in Emacs. +`slime-enable-evaluate-in-emacs' should be set to T on the Emacs side." + (cond (nowait + (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form)))) + (t + (force-output) + (let ((tag (make-tag))) + (send-to-emacs `(:eval ,(current-thread-id) ,tag + ,(process-form-for-emacs form))) + (wait-for-emacs-return tag))))) + +(defun ed-rpc-no-wait (fn &rest args) + "Invoke FN in Emacs (or some lesser editor) and don't wait for the result." + (send-to-emacs `(:ed-rpc-no-wait ,(symbol-name-for-emacs fn) ,@args)) + (values)) + +(defun ed-rpc (fn &rest args) + "Invoke FN in Emacs (or some lesser editor). FN should be defined in +Emacs Lisp via `defslimefun' or otherwise marked as RPCallable." + (let ((tag (make-tag))) + (send-to-emacs `(:ed-rpc ,(current-thread-id) ,tag + ,(symbol-name-for-emacs fn) + ,@args)) + (wait-for-emacs-return tag))) + +(defvar *swank-wire-protocol-version* nil + "The version of the swank/slime communication protocol.") + +(defslimefun connection-info () + "Return a key-value list of the form: +\(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION) +PID: is the process-id of Lisp process (or nil, depending on the STYLE) +STYLE: the communication style +LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION) +FEATURES: a list of keywords +PACKAGE: a list (&key NAME PROMPT) +VERSION: the protocol version" + (let ((c *emacs-connection*)) + (setq *slime-features* *features*) + `(:pid ,(getpid) :style ,(connection.communication-style c) + :encoding (:coding-systems + ,(loop for cs in '("utf-8-unix" "iso-latin-1-unix") + when (find-external-format cs) collect cs)) + :lisp-implementation (:type ,(lisp-implementation-type) + :name ,(lisp-implementation-type-name) + :version ,(lisp-implementation-version) + :program ,(lisp-implementation-program)) + :machine (:instance ,(machine-instance) + :type ,(machine-type) + :version ,(machine-version)) + :features ,(features-for-emacs) + :modules ,*modules* + :package (:name ,(package-name *package*) + :prompt ,(package-string-for-prompt *package*)) + :version ,*swank-wire-protocol-version*))) + +(defun debug-on-swank-error () + (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*)) + *debug-on-swank-protocol-error*) + +(defun (setf debug-on-swank-error) (new-value) + (setf *debug-on-swank-protocol-error* new-value) + (setf *debug-swank-backend* new-value)) + +(defslimefun toggle-debug-on-swank-error () + (setf (debug-on-swank-error) (not (debug-on-swank-error)))) + + +;;;; Reading and printing + +(define-special *buffer-package* + "Package corresponding to slime-buffer-package. + +EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime +buffer are best read in this package. See also FROM-STRING and TO-STRING.") + +(define-special *buffer-readtable* + "Readtable associated with the current buffer") + +(defmacro with-buffer-syntax ((&optional package) &body body) + "Execute BODY with appropriate *package* and *readtable* bindings. + +This should be used for code that is conceptionally executed in an +Emacs buffer." + `(call-with-buffer-syntax ,package (lambda () ,@body))) + +(defun call-with-buffer-syntax (package fun) + (let ((*package* (if package + (guess-buffer-package package) + *buffer-package*))) + ;; Don't shadow *readtable* unnecessarily because that prevents + ;; the user from assigning to it. + (if (eq *readtable* *buffer-readtable*) + (call-with-syntax-hooks fun) + (let ((*readtable* *buffer-readtable*)) + (call-with-syntax-hooks fun))))) + +(defmacro without-printing-errors ((&key object stream + (msg "<>")) + &body body) + "Catches errors during evaluation of BODY and prints MSG instead." + `(handler-case (progn ,@body) + (serious-condition () + ,(cond ((and stream object) + (let ((gstream (gensym "STREAM+"))) + `(let ((,gstream ,stream)) + (print-unreadable-object (,object ,gstream :type t + :identity t) + (write-string ,msg ,gstream))))) + (stream + `(write-string ,msg ,stream)) + (object + `(with-output-to-string (s) + (print-unreadable-object (,object s :type t :identity t) + (write-string ,msg s)))) + (t msg))))) + +(defun to-string (object) + "Write OBJECT in the *BUFFER-PACKAGE*. +The result may not be readable. Handles problems with PRINT-OBJECT methods +gracefully." + (with-buffer-syntax () + (let ((*print-readably* nil)) + (without-printing-errors (:object object :stream nil) + (prin1-to-string object))))) + +(defun from-string (string) + "Read string in the *BUFFER-PACKAGE*" + (with-buffer-syntax () + (let ((*read-suppress* nil)) + (values (read-from-string string))))) + +(defun parse-string (string package) + "Read STRING in PACKAGE." + (with-buffer-syntax (package) + (let ((*read-suppress* nil)) + (read-from-string string)))) + +;; FIXME: deal with #\| etc. hard to do portably. +(defun tokenize-symbol (string) + "STRING is interpreted as the string representation of a symbol +and is tokenized accordingly. The result is returned in three +values: The package identifier part, the actual symbol identifier +part, and a flag if the STRING represents a symbol that is +internal to the package identifier part. (Notice that the flag is +also true with an empty package identifier part, as the STRING is +considered to represent a symbol internal to some current package.)" + (let ((package (let ((pos (position #\: string))) + (if pos (subseq string 0 pos) nil))) + (symbol (let ((pos (position #\: string :from-end t))) + (if pos (subseq string (1+ pos)) string))) + (internp (not (= (count #\: string) 1)))) + (values symbol package internp))) + +(defun tokenize-symbol-thoroughly (string) + "This version of TOKENIZE-SYMBOL handles escape characters." + (let ((package nil) + (token (make-array (length string) :element-type 'character + :fill-pointer 0)) + (backslash nil) + (vertical nil) + (internp nil)) + (loop for char across string do + (cond + (backslash + (vector-push-extend char token) + (setq backslash nil)) + ((char= char #\\) ; Quotes next character, even within |...| + (setq backslash t)) + ((char= char #\|) + (setq vertical (not vertical))) + (vertical + (vector-push-extend char token)) + ((char= char #\:) + (cond ((and package internp) + (return-from tokenize-symbol-thoroughly)) + (package + (setq internp t)) + (t + (setq package token + token (make-array (length string) + :element-type 'character + :fill-pointer 0))))) + (t + (vector-push-extend (casify-char char) token)))) + (unless vertical + (values token package (or (not package) internp))))) + +(defun untokenize-symbol (package-name internal-p symbol-name) + "The inverse of TOKENIZE-SYMBOL. + + (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\" + (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\" + (untokenize-symbol nil nil \"foo\") ==> \"foo\" +" + (cond ((not package-name) symbol-name) + (internal-p (cat package-name "::" symbol-name)) + (t (cat package-name ":" symbol-name)))) + +(defun casify-char (char) + "Convert CHAR accoring to readtable-case." + (ecase (readtable-case *readtable*) + (:preserve char) + (:upcase (char-upcase char)) + (:downcase (char-downcase char)) + (:invert (if (upper-case-p char) + (char-downcase char) + (char-upcase char))))) + + +(defun find-symbol-with-status (symbol-name status + &optional (package *package*)) + (multiple-value-bind (symbol flag) (find-symbol symbol-name package) + (if (and flag (eq flag status)) + (values symbol flag) + (values nil nil)))) + +(defun parse-symbol (string &optional (package *package*)) + "Find the symbol named STRING. +Return the symbol and a flag indicating whether the symbols was found." + (multiple-value-bind (sname pname internalp) + (tokenize-symbol-thoroughly string) + (when sname + (let ((package (cond ((string= pname "") keyword-package) + (pname (find-package pname)) + (t package)))) + (if package + (multiple-value-bind (symbol flag) + (if internalp + (find-symbol sname package) + (find-symbol-with-status sname ':external package)) + (values symbol flag sname package)) + (values nil nil nil nil)))))) + +(defun parse-symbol-or-lose (string &optional (package *package*)) + (multiple-value-bind (symbol status) (parse-symbol string package) + (if status + (values symbol status) + (error "Unknown symbol: ~A [in ~A]" string package)))) + +(defun parse-package (string) + "Find the package named STRING. +Return the package or nil." + ;; STRING comes usually from a (in-package STRING) form. + (ignore-errors + (find-package (let ((*package* *swank-io-package*)) + (read-from-string string))))) + +(defun unparse-name (string) + "Print the name STRING according to the current printer settings." + ;; this is intended for package or symbol names + (subseq (prin1-to-string (make-symbol string)) 2)) + +(defun guess-package (string) + "Guess which package corresponds to STRING. +Return nil if no package matches." + (when string + (or (find-package string) + (parse-package string) + (if (find #\! string) ; for SBCL + (guess-package (substitute #\- #\! string)))))) + +(defvar *readtable-alist* (default-readtable-alist) + "An alist mapping package names to readtables.") + +(defun guess-buffer-readtable (package-name) + (let ((package (guess-package package-name))) + (or (and package + (cdr (assoc (package-name package) *readtable-alist* + :test #'string=))) + *readtable*))) + + +;;;; Evaluation + +(defvar *pending-continuations* '() + "List of continuations for Emacs. (thread local)") + +(defun guess-buffer-package (string) + "Return a package for STRING. +Fall back to the current if no such package exists." + (or (and string (guess-package string)) + *package*)) + +(defun eval-for-emacs (form buffer-package id) + "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM. +Return the result to the continuation ID. +Errors are trapped and invoke our debugger." + (let (ok result condition) + (unwind-protect + (let ((*buffer-package* (guess-buffer-package buffer-package)) + (*buffer-readtable* (guess-buffer-readtable buffer-package)) + (*pending-continuations* (cons id *pending-continuations*))) + (check-type *buffer-package* package) + (check-type *buffer-readtable* readtable) + ;; APPLY would be cleaner than EVAL. + ;; (setq result (apply (car form) (cdr form))) + (handler-bind ((t (lambda (c) (setf condition c)))) + (setq result (with-slime-interrupts (eval form)))) + (run-hook *pre-reply-hook*) + (setq ok t)) + (send-to-emacs `(:return ,(current-thread) + ,(if ok + `(:ok ,result) + `(:abort ,(prin1-to-string condition))) + ,id))))) + +(defvar *echo-area-prefix* "=> " + "A prefix that `format-values-for-echo-area' should use.") + +(defun format-values-for-echo-area (values) + (with-buffer-syntax () + (let ((*print-readably* nil)) + (cond ((null values) "; No value") + ((and (integerp (car values)) (null (cdr values))) + (let ((i (car values))) + (format nil "~A~D (~a bit~:p, #x~X, #o~O, #b~B)" + *echo-area-prefix* + i (integer-length i) i i i))) + ((and (typep (car values) 'ratio) + (null (cdr values)) + (ignore-errors + ;; The ratio may be to large to be represented as a single float + (format nil "~A~D (~:*~f)" + *echo-area-prefix* + (car values))))) + (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values)))))) + +(defmacro values-to-string (values) + `(format-values-for-echo-area (multiple-value-list ,values))) + +(defslimefun interactive-eval (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME interactive evaluation request.") + (let ((values (multiple-value-list (eval (from-string string))))) + (finish-output) + (format-values-for-echo-area values))))) + +(defslimefun eval-and-grab-output (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME evaluation request.") + (let* ((s (make-string-output-stream)) + (*standard-output* s) + (values (multiple-value-list (eval (from-string string))))) + (list (get-output-stream-string s) + (format nil "~{~S~^~%~}" values)))))) + +(defun eval-region (string) + "Evaluate STRING. +Return the results of the last form as a list and as secondary value the +last form." + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (finish-output) + (return (values values -))) + (setq - form) + (setq values (multiple-value-list (eval form))) + (finish-output)))))) + +(defslimefun interactive-eval-region (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME interactive evaluation request.") + (format-values-for-echo-area (eval-region string))))) + +(defslimefun re-evaluate-defvar (form) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME evaluation request.") + (let ((form (read-from-string form))) + (destructuring-bind (dv name &optional value doc) form + (declare (ignore value doc)) + (assert (eq dv 'defvar)) + (makunbound name) + (prin1-to-string (eval form))))))) + +(defvar *swank-pprint-bindings* + `((*print-pretty* . t) + (*print-level* . nil) + (*print-length* . nil) + (*print-circle* . t) + (*print-gensym* . t) + (*print-readably* . nil)) + "A list of variables bindings during pretty printing. +Used by pprint-eval.") + +(defun swank-pprint (values) + "Bind some printer variables and pretty print each object in VALUES." + (with-buffer-syntax () + (with-bindings *swank-pprint-bindings* + (cond ((null values) "; No value") + (t (with-output-to-string (*standard-output*) + (dolist (o values) + (pprint o) + (terpri)))))))) + +(defslimefun pprint-eval (string) + (with-buffer-syntax () + (let* ((s (make-string-output-stream)) + (values + (let ((*standard-output* s) + (*trace-output* s)) + (multiple-value-list (eval (read-from-string string)))))) + (cat (get-output-stream-string s) + (swank-pprint values))))) + +(defslimefun set-package (name) + "Set *package* to the package named NAME. +Return the full package-name and the string to use in the prompt." + (let ((p (guess-package name))) + (assert (packagep p) nil "Package ~a doesn't exist." name) + (setq *package* p) + (list (package-name p) (package-string-for-prompt p)))) + +(defun cat (&rest strings) + "Concatenate all arguments and make the result a string." + (with-output-to-string (out) + (dolist (s strings) + (etypecase s + (string (write-string s out)) + (character (write-char s out)))))) + +(defun truncate-string (string width &optional ellipsis) + (let ((len (length string))) + (cond ((< len width) string) + (ellipsis (cat (subseq string 0 width) ellipsis)) + (t (subseq string 0 width))))) + +(defun call/truncated-output-to-string (length function + &optional (ellipsis "..")) + "Call FUNCTION with a new stream, return the output written to the stream. +If FUNCTION tries to write more than LENGTH characters, it will be +aborted and return immediately with the output written so far." + (let ((buffer (make-string (+ length (length ellipsis)))) + (fill-pointer 0)) + (block buffer-full + (flet ((write-output (string) + (let* ((free (- length fill-pointer)) + (count (min free (length string)))) + (replace buffer string :start1 fill-pointer :end2 count) + (incf fill-pointer count) + (when (> (length string) free) + (replace buffer ellipsis :start1 fill-pointer) + (return-from buffer-full buffer))))) + (let ((stream (make-output-stream #'write-output))) + (funcall function stream) + (finish-output stream) + (subseq buffer 0 fill-pointer)))))) + +(defmacro with-string-stream ((var &key length bindings) + &body body) + (cond ((and (not bindings) (not length)) + `(with-output-to-string (,var) . ,body)) + ((not bindings) + `(call/truncated-output-to-string + ,length (lambda (,var) . ,body))) + (t + `(with-bindings ,bindings + (with-string-stream (,var :length ,length) + . ,body))))) + +(defun to-line (object &optional width) + "Print OBJECT to a single line. Return the string." + (let ((width (or width 512))) + (without-printing-errors (:object object :stream nil) + (with-string-stream (stream :length width) + (write object :stream stream :right-margin width :lines 1))))) + +(defun escape-string (string stream &key length (map '((#\" . "\\\"") + (#\\ . "\\\\")))) + "Write STRING to STREAM surronded by double-quotes. +LENGTH -- if non-nil truncate output after LENGTH chars. +MAP -- rewrite the chars in STRING according to this alist." + (let ((limit (or length array-dimension-limit))) + (write-char #\" stream) + (loop for c across string + for i from 0 do + (when (= i limit) + (write-string "..." stream) + (return)) + (let ((probe (assoc c map))) + (cond (probe (write-string (cdr probe) stream)) + (t (write-char c stream))))) + (write-char #\" stream))) + + +;;;; Prompt + +;; FIXME: do we really need 45 lines of code just to figure out the +;; prompt? + +(defvar *canonical-package-nicknames* + `((:common-lisp-user . :cl-user)) + "Canonical package names to use instead of shortest name/nickname.") + +(defvar *auto-abbreviate-dotted-packages* t + "Abbreviate dotted package names to their last component if T.") + +(defun package-string-for-prompt (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (unparse-name + (or (canonical-package-nickname package) + (auto-abbreviated-package-name package) + (shortest-package-nickname package)))) + +(defun canonical-package-nickname (package) + "Return the canonical package nickname, if any, of PACKAGE." + (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames* + :test #'string=)))) + (and name (string name)))) + +(defun auto-abbreviated-package-name (package) + "Return an abbreviated 'name' for PACKAGE. + +N.B. this is not an actual package name or nickname." + (when *auto-abbreviate-dotted-packages* + (loop with package-name = (package-name package) + with offset = nil + do (let ((last-dot-pos (position #\. package-name :end offset + :from-end t))) + (unless last-dot-pos + (return nil)) + ;; If a dot chunk contains only numbers, that chunk most + ;; likely represents a version number; so we collect the + ;; next chunks, too, until we find one with meat. + (let ((name (subseq package-name (1+ last-dot-pos) offset))) + (if (notevery #'digit-char-p name) + (return (subseq package-name (1+ last-dot-pos))) + (setq offset last-dot-pos))))))) + +(defun shortest-package-nickname (package) + "Return the shortest nickname of PACKAGE." + (loop for name in (cons (package-name package) (package-nicknames package)) + for shortest = name then (if (< (length name) (length shortest)) + name + shortest) + finally (return shortest))) + + + +(defslimefun ed-in-emacs (&optional what) + "Edit WHAT in Emacs. + +WHAT can be: + A pathname or a string, + A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION), + A function name (symbol or cons), + NIL. " + (flet ((canonicalize-filename (filename) + (pathname-to-filename (or (probe-file filename) filename)))) + (let ((target + (etypecase what + (null nil) + ((or string pathname) + `(:filename ,(canonicalize-filename what))) + ((cons (or string pathname) *) + `(:filename ,(canonicalize-filename (car what)) ,@(cdr what))) + ((or symbol cons) + `(:function-name ,(prin1-to-string what)))))) + (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target))) + ((default-connection) + (with-connection ((default-connection)) + (send-oob-to-emacs `(:ed ,target)))) + (t (error "No connection")))))) + +(defslimefun inspect-in-emacs (what &key wait) + "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the +inspector has been closed in Emacs." + (flet ((send-it () + (let ((tag (when wait (make-tag))) + (thread (when wait (current-thread-id)))) + (with-buffer-syntax () + (reset-inspector) + (send-oob-to-emacs `(:inspect ,(inspect-object what) + ,thread + ,tag))) + (when wait + (wait-for-event `(:emacs-return ,tag result)))))) + (cond + (*emacs-connection* + (send-it)) + ((default-connection) + (with-connection ((default-connection)) + (send-it)))) + what)) + +(defslimefun value-for-editing (form) + "Return a readable value of FORM for editing in Emacs. +FORM is expected, but not required, to be SETF'able." + ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005) + (with-buffer-syntax () + (let* ((value (eval (read-from-string form))) + (*print-length* nil)) + (prin1-to-string value)))) + +(defslimefun commit-edited-value (form value) + "Set the value of a setf'able FORM to VALUE. +FORM and VALUE are both strings from Emacs." + (with-buffer-syntax () + (eval `(setf ,(read-from-string form) + ,(read-from-string (concatenate 'string "`" value)))) + t)) + +(defun background-message (format-string &rest args) + "Display a message in Emacs' echo area. + +Use this function for informative messages only. The message may even +be dropped if we are too busy with other things." + (when *emacs-connection* + (send-to-emacs `(:background-message + ,(apply #'format nil format-string args))))) + +;; This is only used by the test suite. +(defun sleep-for (seconds) + "Sleep for at least SECONDS seconds. +This is just like cl:sleep but guarantees to sleep +at least SECONDS." + (let* ((start (get-internal-real-time)) + (end (+ start + (* seconds internal-time-units-per-second)))) + (loop + (let ((now (get-internal-real-time))) + (cond ((< end now) (return)) + (t (sleep (/ (- end now) + internal-time-units-per-second)))))))) + + +;;;; Debugger + +(defun invoke-slime-debugger (condition) + "Sends a message to Emacs declaring that the debugger has been entered, +then waits to handle further requests from Emacs. Eventually returns +after Emacs causes a restart to be invoked." + (without-slime-interrupts + (cond (*emacs-connection* + (debug-in-emacs condition)) + ((default-connection) + (with-connection ((default-connection)) + (debug-in-emacs condition)))))) + +(define-condition invoke-default-debugger () ()) + +(defun swank-debugger-hook (condition hook) + "Debugger function for binding *DEBUGGER-HOOK*." + (declare (ignore hook)) + (handler-case + (call-with-debugger-hook #'swank-debugger-hook + (lambda () (invoke-slime-debugger condition))) + (invoke-default-debugger () + (invoke-default-debugger condition)))) + +(defun invoke-default-debugger (condition) + (call-with-debugger-hook nil (lambda () (invoke-debugger condition)))) + +(defvar *global-debugger* t + "Non-nil means the Swank debugger hook will be installed globally.") + +(add-hook *new-connection-hook* 'install-debugger) +(defun install-debugger (connection) + (declare (ignore connection)) + (when *global-debugger* + (install-debugger-globally #'swank-debugger-hook))) + +;;;;; Debugger loop +;;; +;;; These variables are dynamically bound during debugging. +;;; +(defvar *swank-debugger-condition* nil + "The condition being debugged.") + +(defvar *sldb-level* 0 + "The current level of recursive debugging.") + +(defvar *sldb-initial-frames* 20 + "The initial number of backtrace frames to send to Emacs.") + +(defvar *sldb-restarts* nil + "The list of currenlty active restarts.") + +(defvar *sldb-stepping-p* nil + "True during execution of a step command.") + +(defun debug-in-emacs (condition) + (let ((*swank-debugger-condition* condition) + (*sldb-restarts* (compute-restarts condition)) + (*sldb-quit-restart* (and *sldb-quit-restart* + (find-restart *sldb-quit-restart*))) + (*package* (or (and (boundp '*buffer-package*) + (symbol-value '*buffer-package*)) + *package*)) + (*sldb-level* (1+ *sldb-level*)) + (*sldb-stepping-p* nil)) + (force-user-output) + (call-with-debugging-environment + (lambda () + (sldb-loop *sldb-level*))))) + +(defun sldb-loop (level) + (unwind-protect + (loop + (with-simple-restart (abort "Return to sldb level ~D." level) + (send-to-emacs + (list* :debug (current-thread-id) level + (debugger-info-for-emacs 0 *sldb-initial-frames*))) + (send-to-emacs + (list :debug-activate (current-thread-id) level nil)) + (loop + (handler-case + (dcase (wait-for-event + `(or (:emacs-rex . _) + (:sldb-return ,(1+ level)))) + ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) + ((:sldb-return _) (declare (ignore _)) (return nil))) + (sldb-condition (c) + (handle-sldb-condition c)))))) + (send-to-emacs `(:debug-return + ,(current-thread-id) ,level ,*sldb-stepping-p*)) + (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue + (when (> level 1) + (send-event (current-thread) `(:sldb-return ,level))))) + +(defun handle-sldb-condition (condition) + "Handle an internal debugger condition. +Rather than recursively debug the debugger (a dangerous idea!), these +conditions are simply reported." + (let ((real-condition (original-condition condition))) + (send-to-emacs `(:debug-condition ,(current-thread-id) + ,(princ-to-string real-condition))))) + +(defun %%condition-message (condition) + (let ((limit (ash 1 16))) + (with-string-stream (stream :length limit) + (handler-case + (let ((*print-readably* nil) + (*print-pretty* t) + (*print-right-margin* 65) + (*print-circle* t) + (*print-length* (or *print-length* limit)) + (*print-level* (or *print-level* limit)) + (*print-lines* (or *print-lines* limit))) + (print-condition condition stream)) + (serious-condition (c) + (ignore-errors + (with-standard-io-syntax + (let ((*print-readably* nil)) + (format stream "~&Error (~a) during printing: " (type-of c)) + (print-unreadable-object (condition stream :type t + :identity t)))))))))) + +(defun %condition-message (condition) + (string-trim #(#\newline #\space #\tab) + (%%condition-message condition))) + +(defvar *sldb-condition-printer* #'%condition-message + "Function called to print a condition to an SLDB buffer.") + +(defun safe-condition-message (condition) + "Print condition to a string, handling any errors during printing." + (funcall *sldb-condition-printer* condition)) + +(defun debugger-condition-for-emacs () + (list (safe-condition-message *swank-debugger-condition*) + (format nil " [Condition of type ~S]" + (type-of *swank-debugger-condition*)) + (condition-extras *swank-debugger-condition*))) + +(defun format-restarts-for-emacs () + "Return a list of restarts for *swank-debugger-condition* in a +format suitable for Emacs." + (let ((*print-right-margin* most-positive-fixnum)) + (loop for restart in *sldb-restarts* collect + (list (format nil "~:[~;*~]~a" + (eq restart *sldb-quit-restart*) + (restart-name restart)) + (with-output-to-string (stream) + (without-printing-errors (:object restart + :stream stream + :msg "<>") + (princ restart stream))))))) + +;;;;; SLDB entry points + +(defslimefun sldb-break-with-default-debugger (dont-unwind) + "Invoke the default debugger." + (cond (dont-unwind + (invoke-default-debugger *swank-debugger-condition*)) + (t + (signal 'invoke-default-debugger)))) + +(defslimefun backtrace (start end) + "Return a list ((I FRAME PLIST) ...) of frames from START to END. + +I is an integer, and can be used to reference the corresponding frame +from Emacs; FRAME is a string representation of an implementation's +frame." + (loop for frame in (compute-backtrace start end) + for i from start collect + (list* i (frame-to-string frame) + (ecase (frame-restartable-p frame) + ((nil) nil) + ((t) `((:restartable t))))))) + +(defun frame-to-string (frame) + (with-string-stream (stream :length (* (or *print-lines* 1) + (or *print-right-margin* 100)) + :bindings *backtrace-printer-bindings*) + (handler-case (print-frame frame stream) + (serious-condition () + (format stream "[error printing frame]"))))) + +(defslimefun debugger-info-for-emacs (start end) + "Return debugger state, with stack frames from START to END. +The result is a list: + (condition ({restart}*) ({stack-frame}*) (cont*)) +where + condition ::= (description type [extra]) + restart ::= (name description) + stack-frame ::= (number description [plist]) + extra ::= (:references and other random things) + cont ::= continutation + plist ::= (:restartable {nil | t | :unknown}) + +condition---a pair of strings: message, and type. If show-source is +not nil it is a frame number for which the source should be displayed. + +restart---a pair of strings: restart name, and description. + +stack-frame---a number from zero (the top), and a printed +representation of the frame's call. + +continutation---the id of a pending Emacs continuation. + +Below is an example return value. In this case the condition was a +division by zero (multi-line description), and only one frame is being +fetched (start=0, end=1). + + ((\"Arithmetic error DIVISION-BY-ZERO signalled. +Operation was KERNEL::DIVISION, operands (1 0).\" + \"[Condition of type DIVISION-BY-ZERO]\") + ((\"ABORT\" \"Return to Slime toplevel.\") + (\"ABORT\" \"Return to Top-Level.\")) + ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil))) + (4))" + (list (debugger-condition-for-emacs) + (format-restarts-for-emacs) + (backtrace start end) + *pending-continuations*)) + +(defun nth-restart (index) + (nth index *sldb-restarts*)) + +(defslimefun invoke-nth-restart (index) + (let ((restart (nth-restart index))) + (when restart + (invoke-restart-interactively restart)))) + +(defslimefun sldb-abort () + (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) + +(defslimefun sldb-continue () + (continue)) + +(defun coerce-to-condition (datum args) + (etypecase datum + (string (make-condition 'simple-error :format-control datum + :format-arguments args)) + (symbol (apply #'make-condition datum args)))) + +(defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args) + (with-simple-restart (continue "Continue from break.") + (invoke-slime-debugger (coerce-to-condition datum args)))) + +;; FIXME: (last (compute-restarts)) looks dubious. +(defslimefun throw-to-toplevel () + "Invoke the ABORT-REQUEST restart abort an RPC from Emacs. +If we are not evaluating an RPC then ABORT instead." + (let ((restart (or (and *sldb-quit-restart* + (find-restart *sldb-quit-restart*)) + (car (last (compute-restarts)))))) + (cond (restart (invoke-restart restart)) + (t (format nil "Restart not active [~s]" *sldb-quit-restart*))))) + +(defslimefun invoke-nth-restart-for-emacs (sldb-level n) + "Invoke the Nth available restart. +SLDB-LEVEL is the debug level when the request was made. If this +has changed, ignore the request." + (when (= sldb-level *sldb-level*) + (invoke-nth-restart n))) + +(defun wrap-sldb-vars (form) + `(let ((*sldb-level* ,*sldb-level*)) + ,form)) + +(defun eval-in-frame-aux (frame string package print) + (let* ((form (wrap-sldb-vars (parse-string string package))) + (values (multiple-value-list (eval-in-frame form frame)))) + (with-buffer-syntax (package) + (funcall print values)))) + +(defslimefun eval-string-in-frame (string frame package) + (eval-in-frame-aux frame string package #'format-values-for-echo-area)) + +(defslimefun pprint-eval-string-in-frame (string frame package) + (eval-in-frame-aux frame string package #'swank-pprint)) + +(defslimefun frame-package-name (frame) + (let ((pkg (frame-package frame))) + (cond (pkg (package-name pkg)) + (t (with-buffer-syntax () (package-name *package*)))))) + +(defslimefun frame-locals-and-catch-tags (index) + "Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX. +LOCALS is a list of the form ((&key NAME ID VALUE) ...). +TAGS has is a list of strings." + (list (frame-locals-for-emacs index) + (mapcar #'to-string (frame-catch-tags index)))) + +(defun frame-locals-for-emacs (index) + (with-bindings *backtrace-printer-bindings* + (loop for var in (frame-locals index) collect + (destructuring-bind (&key name id value) var + (list :name (let ((*package* (or (frame-package index) *package*))) + (prin1-to-string name)) + :id id + :value (to-line value *print-right-margin*)))))) + +(defslimefun sldb-disassemble (index) + (with-output-to-string (*standard-output*) + (disassemble-frame index))) + +(defslimefun sldb-return-from-frame (index string) + (let ((form (from-string string))) + (to-string (multiple-value-list (return-from-frame index form))))) + +(defslimefun sldb-break (name) + (with-buffer-syntax () + (sldb-break-at-start (read-from-string name)))) + +(defmacro define-stepper-function (name backend-function-name) + `(defslimefun ,name (frame) + (cond ((sldb-stepper-condition-p *swank-debugger-condition*) + (setq *sldb-stepping-p* t) + (,backend-function-name)) + ((find-restart 'continue) + (activate-stepping frame) + (setq *sldb-stepping-p* t) + (continue)) + (t + (error "Not currently single-stepping, ~ +and no continue restart available."))))) + +(define-stepper-function sldb-step sldb-step-into) +(define-stepper-function sldb-next sldb-step-next) +(define-stepper-function sldb-out sldb-step-out) + +(defslimefun toggle-break-on-signals () + (setq *break-on-signals* (not *break-on-signals*)) + (format nil "*break-on-signals* = ~a" *break-on-signals*)) + +(defslimefun sdlb-print-condition () + (princ-to-string *swank-debugger-condition*)) + + +;;;; Compilation Commands. + +(defstruct (compilation-result (:type list)) + (type :compilation-result) + notes + (successp nil :type boolean) + (duration 0.0 :type float) + (loadp nil :type boolean) + (faslfile nil :type (or null string))) + +(defun measure-time-interval (fun) + "Call FUN and return the first return value and the elapsed time. +The time is measured in seconds." + (declare (type function fun)) + (let ((before (get-internal-real-time))) + (values + (funcall fun) + (/ (- (get-internal-real-time) before) + (coerce internal-time-units-per-second 'float))))) + +(defun make-compiler-note (condition) + "Make a compiler note data structure from a compiler-condition." + (declare (type compiler-condition condition)) + (list* :message (message condition) + :severity (severity condition) + :location (location condition) + :references (references condition) + (let ((s (source-context condition))) + (if s (list :source-context s))))) + +(defun collect-notes (function) + (let ((notes '())) + (multiple-value-bind (result seconds) + (handler-bind ((compiler-condition + (lambda (c) (push (make-compiler-note c) notes)))) + (measure-time-interval + (lambda () + ;; To report location of error-signaling toplevel forms + ;; for errors in EVAL-WHEN or during macroexpansion. + (restart-case (multiple-value-list (funcall function)) + (abort () :report "Abort compilation." (list nil)))))) + (destructuring-bind (successp &optional loadp faslfile) result + (let ((faslfile (etypecase faslfile + (null nil) + (pathname (pathname-to-filename faslfile))))) + (make-compilation-result :notes (reverse notes) + :duration seconds + :successp (if successp t) + :loadp (if loadp t) + :faslfile faslfile)))))) + +(defun swank-compile-file* (pathname load-p &rest options &key policy + &allow-other-keys) + (multiple-value-bind (output-pathname warnings? failure?) + (swank-compile-file pathname + (fasl-pathname pathname options) + nil + (or (guess-external-format pathname) + :default) + :policy policy) + (declare (ignore warnings?)) + (values t (not failure?) load-p output-pathname))) + +(defvar *compile-file-for-emacs-hook* '(swank-compile-file*)) + +(defslimefun compile-file-for-emacs (filename load-p &rest options) + "Compile FILENAME and, when LOAD-P, load the result. +Record compiler notes signalled as `compiler-condition's." + (with-buffer-syntax () + (collect-notes + (lambda () + (let ((pathname (filename-to-pathname filename)) + (*compile-print* nil) + (*compile-verbose* t)) + (loop for hook in *compile-file-for-emacs-hook* + do + (multiple-value-bind (tried success load? output-pathname) + (apply hook pathname load-p options) + (when tried + (return (values success load? output-pathname)))))))))) + +;; FIXME: now that *compile-file-for-emacs-hook* is there this is +;; redundant and confusing. +(defvar *fasl-pathname-function* nil + "In non-nil, use this function to compute the name for fasl-files.") + +(defun pathname-as-directory (pathname) + (append (pathname-directory pathname) + (when (pathname-name pathname) + (list (file-namestring pathname))))) + +(defun compile-file-output (file directory) + (make-pathname :directory (pathname-as-directory directory) + :defaults (compile-file-pathname file))) + +(defun fasl-pathname (input-file options) + (cond (*fasl-pathname-function* + (funcall *fasl-pathname-function* input-file options)) + ((getf options :fasl-directory) + (let ((dir (getf options :fasl-directory))) + (assert (char= (aref dir (1- (length dir))) #\/)) + (compile-file-output input-file dir))) + (t + (compile-file-pathname input-file)))) + +(defslimefun compile-string-for-emacs (string buffer position filename policy) + "Compile STRING (exerpted from BUFFER at POSITION). +Record compiler notes signalled as `compiler-condition's." + (let ((offset (cadr (assoc :position position)))) + (with-buffer-syntax () + (collect-notes + (lambda () + (let ((*compile-print* t) (*compile-verbose* nil)) + (swank-compile-string string + :buffer buffer + :position offset + :filename filename + :policy policy))))))) + +(defslimefun compile-multiple-strings-for-emacs (strings policy) + "Compile STRINGS (exerpted from BUFFER at POSITION). +Record compiler notes signalled as `compiler-condition's." + (loop for (string buffer package position filename) in strings collect + (collect-notes + (lambda () + (with-buffer-syntax (package) + (let ((*compile-print* t) (*compile-verbose* nil)) + (swank-compile-string string + :buffer buffer + :position position + :filename filename + :policy policy))))))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun requires-compile-p (source-file) + (let ((fasl-file (probe-file (compile-file-pathname source-file)))) + (or (not fasl-file) + (file-newer-p source-file fasl-file)))) + +(defslimefun compile-file-if-needed (filename loadp) + (let ((pathname (filename-to-pathname filename))) + (cond ((requires-compile-p pathname) + (compile-file-for-emacs pathname loadp)) + (t + (collect-notes + (lambda () + (or (not loadp) + (load (compile-file-pathname pathname))))))))) + + +;;;; Loading + +(defslimefun load-file (filename) + (to-string (load (filename-to-pathname filename)))) + + +;;;;; swank-require + +(defslimefun swank-require (modules &optional filename) + "Load the module MODULE." + (dolist (module (ensure-list modules)) + (unless (member (string module) *modules* :test #'string=) + (require module (if filename + (filename-to-pathname filename) + (module-filename module))) + (assert (member (string module) *modules* :test #'string=) + () "Required module ~s was not provided" module))) + *modules*) + +(defvar *find-module* 'find-module + "Pluggable function to locate modules. +The function receives a module name as argument and should return +the filename of the module (or nil if the file doesn't exist).") + +(defun module-filename (module) + "Return the filename for the module MODULE." + (or (funcall *find-module* module) + (error "Can't locate module: ~s" module))) + +;;;;;; Simple *find-module* function. + +(defun merged-directory (dirname defaults) + (pathname-directory + (merge-pathnames + (make-pathname :directory `(:relative ,dirname) :defaults defaults) + defaults))) + +(defvar *load-path* '() + "A list of directories to search for modules.") + +(defun module-candidates (name dir) + (list (compile-file-pathname (make-pathname :name name :defaults dir)) + (make-pathname :name name :type "lisp" :defaults dir))) + +(defun find-module (module) + (let ((name (string-downcase module))) + (some (lambda (dir) (some #'probe-file (module-candidates name dir))) + *load-path*))) + + +;;;; Macroexpansion + +(defvar *macroexpand-printer-bindings* + '((*print-circle* . nil) + (*print-pretty* . t) + (*print-escape* . t) + (*print-lines* . nil) + (*print-level* . nil) + (*print-length* . nil))) + +(defun apply-macro-expander (expander string) + (with-buffer-syntax () + (with-bindings *macroexpand-printer-bindings* + (prin1-to-string (funcall expander (from-string string)))))) + +(defslimefun swank-macroexpand-1 (string) + (apply-macro-expander #'macroexpand-1 string)) + +(defslimefun swank-macroexpand (string) + (apply-macro-expander #'macroexpand string)) + +(defslimefun swank-macroexpand-all (string) + (apply-macro-expander #'macroexpand-all string)) + +(defslimefun swank-compiler-macroexpand-1 (string) + (apply-macro-expander #'compiler-macroexpand-1 string)) + +(defslimefun swank-compiler-macroexpand (string) + (apply-macro-expander #'compiler-macroexpand string)) + +(defslimefun swank-expand-1 (string) + (apply-macro-expander #'expand-1 string)) + +(defslimefun swank-expand (string) + (apply-macro-expander #'expand string)) + +(defun expand-1 (form) + (multiple-value-bind (expansion expanded?) (macroexpand-1 form) + (if expanded? + (values expansion t) + (compiler-macroexpand-1 form)))) + +(defun expand (form) + (expand-repeatedly #'expand-1 form)) + +(defun expand-repeatedly (expander form) + (loop + (multiple-value-bind (expansion expanded?) (funcall expander form) + (unless expanded? (return expansion)) + (setq form expansion)))) + +(defslimefun swank-format-string-expand (string) + (apply-macro-expander #'format-string-expand string)) + +(defslimefun disassemble-form (form) + (with-buffer-syntax () + (with-output-to-string (*standard-output*) + (let ((*print-readably* nil)) + (disassemble (eval (read-from-string form))))))) + + +;;;; Simple completion + +(defslimefun simple-completions (prefix package) + "Return a list of completions for the string PREFIX." + (let ((strings (all-completions prefix package))) + (list strings (longest-common-prefix strings)))) + +(defun all-completions (prefix package) + (multiple-value-bind (name pname intern) (tokenize-symbol prefix) + (let* ((extern (and pname (not intern))) + (pkg (cond ((equal pname "") keyword-package) + ((not pname) (guess-buffer-package package)) + (t (guess-package pname)))) + (test (lambda (sym) (prefix-match-p name (symbol-name sym)))) + (syms (and pkg (matching-symbols pkg extern test))) + (strings (loop for sym in syms + for str = (unparse-symbol sym) + when (prefix-match-p name str) ; remove |Foo| + collect str))) + (format-completion-set strings intern pname)))) + +(defun matching-symbols (package external test) + (let ((test (if external + (lambda (s) + (and (symbol-external-p s package) + (funcall test s))) + test)) + (result '())) + (do-symbols (s package) + (when (funcall test s) + (push s result))) + (remove-duplicates result))) + +(defun unparse-symbol (symbol) + (let ((*print-case* (case (readtable-case *readtable*) + (:downcase :upcase) + (t :downcase)))) + (unparse-name (symbol-name symbol)))) + +(defun prefix-match-p (prefix string) + "Return true if PREFIX is a prefix of STRING." + (not (mismatch prefix string :end2 (min (length string) (length prefix)) + :test #'char-equal))) + +(defun longest-common-prefix (strings) + "Return the longest string that is a common prefix of STRINGS." + (if (null strings) + "" + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix strings)))) + +(defun format-completion-set (strings internal-p package-name) + "Format a set of completion strings. +Returns a list of completions with package qualifiers if needed." + (mapcar (lambda (string) (untokenize-symbol package-name internal-p string)) + (sort strings #'string<))) + + +;;;; Simple arglist display + +(defslimefun operator-arglist (name package) + (ignore-errors + (let ((args (arglist (parse-symbol name (guess-buffer-package package))))) + (cond ((eq args :not-available) nil) + (t (princ-to-string (cons name args))))))) + + +;;;; Documentation + +(defslimefun apropos-list-for-emacs (name &optional external-only + case-sensitive package) + "Make an apropos search for Emacs. +The result is a list of property lists." + (let ((package (if package + (or (parse-package package) + (error "No such package: ~S" package))))) + ;; The MAPCAN will filter all uninteresting symbols, i.e. those + ;; who cannot be meaningfully described. + (mapcan (listify #'briefly-describe-symbol-for-emacs) + (sort (remove-duplicates + (apropos-symbols name external-only case-sensitive package)) + #'present-symbol-before-p)))) + +(defun briefly-describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. +Like `describe-symbol-for-emacs' but with at most one line per item." + (flet ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos))))) + (let ((desc (map-if #'stringp #'first-line + (describe-symbol-for-emacs symbol)))) + (if desc + (list* :designator (to-string symbol) desc))))) + +(defun map-if (test fn &rest lists) + "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST. +Example: +\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)" + (apply #'mapcar + (lambda (x) (if (funcall test x) (funcall fn x) x)) + lists)) + +(defun listify (f) + "Return a function like F, but which returns any non-null value +wrapped in a list." + (lambda (x) + (let ((y (funcall f x))) + (and y (list y))))) + +(defun present-symbol-before-p (x y) + "Return true if X belongs before Y in a printed summary of symbols. +Sorted alphabetically by package name and then symbol name, except +that symbols accessible in the current package go first." + (declare (type symbol x y)) + (flet ((accessible (s) + ;; Test breaks on NIL for package that does not inherit it + (eq (find-symbol (symbol-name s) *buffer-package*) s))) + (let ((ax (accessible x)) (ay (accessible y))) + (cond ((and ax ay) (string< (symbol-name x) (symbol-name y))) + (ax t) + (ay nil) + (t (let ((px (symbol-package x)) (py (symbol-package y))) + (if (eq px py) + (string< (symbol-name x) (symbol-name y)) + (string< (package-name px) (package-name py))))))))) + +(defun make-apropos-matcher (pattern case-sensitive) + (let ((chr= (if case-sensitive #'char= #'char-equal))) + (lambda (symbol) + (search pattern (string symbol) :test chr=)))) + +(defun apropos-symbols (string external-only case-sensitive package) + (let ((packages (or package (remove (find-package :keyword) + (list-all-packages)))) + (matcher (make-apropos-matcher string case-sensitive)) + (result)) + (with-package-iterator (next packages :external :internal) + (loop (multiple-value-bind (morep symbol) (next) + (cond ((not morep) (return)) + ((and (if external-only (symbol-external-p symbol) t) + (funcall matcher symbol)) + (push symbol result)))))) + result)) + +(defun call-with-describe-settings (fn) + (let ((*print-readably* nil)) + (funcall fn))) + +(defmacro with-describe-settings ((&rest _) &body body) + (declare (ignore _)) + `(call-with-describe-settings (lambda () ,@body))) + +(defun describe-to-string (object) + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe object)))) + +(defslimefun describe-symbol (symbol-name) + (with-buffer-syntax () + (describe-to-string (parse-symbol-or-lose symbol-name)))) + +(defslimefun describe-function (name) + (with-buffer-syntax () + (let ((symbol (parse-symbol-or-lose name))) + (describe-to-string (or (macro-function symbol) + (symbol-function symbol)))))) + +(defslimefun describe-definition-for-emacs (name kind) + (with-buffer-syntax () + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe-definition (parse-symbol-or-lose name) kind))))) + +(defslimefun documentation-symbol (symbol-name) + (with-buffer-syntax () + (multiple-value-bind (sym foundp) (parse-symbol symbol-name) + (if foundp + (let ((vdoc (documentation sym 'variable)) + (fdoc (documentation sym 'function))) + (with-output-to-string (string) + (format string "Documentation for the symbol ~a:~2%" sym) + (unless (or vdoc fdoc) + (format string "Not documented." )) + (when vdoc + (format string "Variable:~% ~a~2%" vdoc)) + (when fdoc + (format string "Function:~% Arglist: ~a~2% ~a" + (arglist sym) + fdoc)))) + (format nil "No such symbol, ~a." symbol-name))))) + + +;;;; Package Commands + +(defslimefun list-all-package-names (&optional nicknames) + "Return a list of all package names. +Include the nicknames if NICKNAMES is true." + (mapcar #'unparse-name + (if nicknames + (mapcan #'package-names (list-all-packages)) + (mapcar #'package-name (list-all-packages))))) + + +;;;; Tracing + +;; Use eval for the sake of portability... +(defun tracedp (fspec) + (member fspec (eval '(trace)))) + +(defvar *after-toggle-trace-hook* nil + "Hook called whenever a SPEC is traced or untraced. + +If non-nil, called with two arguments SPEC and TRACED-P." ) +(defslimefun swank-toggle-trace (spec-string) + (let* ((spec (from-string spec-string)) + (retval (cond ((consp spec) ; handle complicated cases in the backend + (toggle-trace spec)) + ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec)) + (format nil "~S is now traced." spec)))) + (traced-p (let* ((tosearch "is now traced.") + (start (- (length retval) + (length tosearch))) + (end (+ start (length tosearch)))) + (search tosearch (subseq retval start end)))) + (hook-msg (when *after-toggle-trace-hook* + (funcall *after-toggle-trace-hook* + spec + traced-p)))) + (if hook-msg + (format nil "~a~%(also ~a)" retval hook-msg) + retval))) + +(defslimefun untrace-all () + (untrace)) + + +;;;; Undefing + +(defslimefun undefine-function (fname-string) + (let ((fname (from-string fname-string))) + (format nil "~S" (fmakunbound fname)))) + +(defslimefun unintern-symbol (name package) + (let ((pkg (guess-package package))) + (cond ((not pkg) (format nil "No such package: ~s" package)) + (t + (multiple-value-bind (sym found) (parse-symbol name pkg) + (case found + ((nil) (format nil "~s not in package ~s" name package)) + (t + (unintern sym pkg) + (format nil "Uninterned symbol: ~s" sym)))))))) + +(defslimefun swank-delete-package (package-name) + (let ((pkg (or (guess-package package-name) + (error "No such package: ~s" package-name)))) + (delete-package pkg) + nil)) + + +;;;; Profiling + +(defun profiledp (fspec) + (member fspec (profiled-functions))) + +(defslimefun toggle-profile-fdefinition (fname-string) + (let ((fname (from-string fname-string))) + (cond ((profiledp fname) + (unprofile fname) + (format nil "~S is now unprofiled." fname)) + (t + (profile fname) + (format nil "~S is now profiled." fname))))) + +(defslimefun profile-by-substring (substring package) + (let ((count 0)) + (flet ((maybe-profile (symbol) + (when (and (fboundp symbol) + (not (profiledp symbol)) + (search substring (symbol-name symbol) :test #'equalp)) + (handler-case (progn + (profile symbol) + (incf count)) + (error (condition) + (warn "~a" condition)))))) + (if package + (do-symbols (symbol (parse-package package)) + (maybe-profile symbol)) + (do-all-symbols (symbol) + (maybe-profile symbol)))) + (format nil "~a function~:p ~:*~[are~;is~:;are~] now profiled" count))) + +(defslimefun swank-profile-package (package-name callersp methodsp) + (let ((pkg (or (guess-package package-name) + (error "Not a valid package name: ~s" package-name)))) + (check-type callersp boolean) + (check-type methodsp boolean) + (profile-package pkg callersp methodsp))) + + +;;;; Source Locations + +(defslimefun find-definition-for-thing (thing) + (find-source-location thing)) + +(defslimefun find-source-location-for-emacs (spec) + (find-source-location (value-spec-ref spec))) + +(defun value-spec-ref (spec) + (dcase spec + ((:string string package) + (with-buffer-syntax (package) + (eval (read-from-string string)))) + ((:inspector part) + (inspector-nth-part part)) + ((:sldb frame var) + (frame-var-value frame var)))) + +(defvar *find-definitions-right-trim* ",:.>") +(defvar *find-definitions-left-trim* "#:<") + +(defun find-definitions-find-symbol-or-package (name) + (flet ((do-find (name) + (multiple-value-bind (symbol found name) + (with-buffer-syntax () + (parse-symbol name)) + (cond (found + (return-from find-definitions-find-symbol-or-package + (values symbol found))) + ;; Packages are not named by symbols, so + ;; not-interned symbols can refer to packages + ((find-package name) + (return-from find-definitions-find-symbol-or-package + (values (make-symbol name) t))))))) + (do-find name) + (do-find (string-right-trim *find-definitions-right-trim* name)) + (do-find (string-left-trim *find-definitions-left-trim* name)) + (do-find (string-left-trim *find-definitions-left-trim* + (string-right-trim + *find-definitions-right-trim* name))) + ;; Not exactly robust + (when (and (eql (search "(setf " name :test #'char-equal) 0) + (char= (char name (1- (length name))) #\))) + (multiple-value-bind (symbol found) + (with-buffer-syntax () + (parse-symbol (subseq name (length "(setf ") + (1- (length name))))) + (when found + (values `(setf ,symbol) t)))))) + +(defslimefun find-definitions-for-emacs (name) + "Return a list ((DSPEC LOCATION) ...) of definitions for NAME. +DSPEC is a string and LOCATION a source location. NAME is a string." + (multiple-value-bind (symbol found) + (find-definitions-find-symbol-or-package name) + (when found + (mapcar #'xref>elisp (find-definitions symbol))))) + +;;; Generic function so contribs can extend it. +(defgeneric xref-doit (type thing) + (:method (type thing) + (declare (ignore type thing)) + :not-implemented)) + +(macrolet ((define-xref-action (xref-type handler) + `(defmethod xref-doit ((type (eql ,xref-type)) thing) + (declare (ignorable type)) + (funcall ,handler thing)))) + (define-xref-action :calls #'who-calls) + (define-xref-action :calls-who #'calls-who) + (define-xref-action :references #'who-references) + (define-xref-action :binds #'who-binds) + (define-xref-action :sets #'who-sets) + (define-xref-action :macroexpands #'who-macroexpands) + (define-xref-action :specializes #'who-specializes) + (define-xref-action :callers #'list-callers) + (define-xref-action :callees #'list-callees)) + +(defslimefun xref (type name) + (multiple-value-bind (sexp error) (ignore-errors (from-string name)) + (unless error + (let ((xrefs (xref-doit type sexp))) + (if (eq xrefs :not-implemented) + :not-implemented + (mapcar #'xref>elisp xrefs)))))) + +(defslimefun xrefs (types name) + (loop for type in types + for xrefs = (xref type name) + when (and (not (eq :not-implemented xrefs)) + (not (null xrefs))) + collect (cons type xrefs))) + +(defun xref>elisp (xref) + (destructuring-bind (name loc) xref + (list (to-string name) loc))) + + +;;;;; Lazy lists + +(defstruct (lcons (:constructor %lcons (car %cdr)) + (:predicate lcons?)) + car + (%cdr nil :type (or null lcons function)) + (forced? nil)) + +(defmacro lcons (car cdr) + `(%lcons ,car (lambda () ,cdr))) + +(defmacro lcons* (car cdr &rest more) + (cond ((null more) `(lcons ,car ,cdr)) + (t `(lcons ,car (lcons* ,cdr ,@more))))) + +(defun lcons-cdr (lcons) + (with-struct* (lcons- @ lcons) + (cond ((@ forced?) + (@ %cdr)) + (t + (let ((value (funcall (@ %cdr)))) + (setf (@ forced?) t + (@ %cdr) value)))))) + +(defun llist-range (llist start end) + (llist-take (llist-skip llist start) (- end start))) + +(defun llist-skip (lcons index) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i index) (null l)) + l))) + +(defun llist-take (lcons count) + (let ((result '())) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i count) + (null l))) + (push (lcons-car l) result)) + (nreverse result))) + +(defun iline (label value) + `(:line ,label ,value)) + + +;;;; Inspecting + +(defvar *inspector-verbose* nil) + +(defvar *inspector-printer-bindings* + '((*print-lines* . 1) + (*print-right-margin* . 75) + (*print-pretty* . t) + (*print-readably* . nil))) + +(defvar *inspector-verbose-printer-bindings* + '((*print-escape* . t) + (*print-circle* . t) + (*print-array* . nil))) + +(defstruct inspector-state) +(defstruct (istate (:conc-name istate.) (:include inspector-state)) + object + (verbose *inspector-verbose*) + (parts (make-array 10 :adjustable t :fill-pointer 0)) + (actions (make-array 10 :adjustable t :fill-pointer 0)) + metadata-plist + content + next previous) + +(defvar *istate* nil) +(defvar *inspector-history*) + +(defun reset-inspector () + (setq *istate* nil + *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) + +(defslimefun init-inspector (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME inspection request.") + (reset-inspector) + (inspect-object (eval (read-from-string string)))))) + +(defun ensure-istate-metadata (o indicator default) + (with-struct (istate. object metadata-plist) *istate* + (assert (eq object o)) + (let ((data (getf metadata-plist indicator default))) + (setf (getf metadata-plist indicator) data) + data))) + +(defun inspect-object (o) + (let* ((prev *istate*) + (istate (make-istate :object o :previous prev + :verbose (cond (prev (istate.verbose prev)) + (t *inspector-verbose*))))) + (setq *istate* istate) + (setf (istate.content istate) (emacs-inspect/istate istate)) + (unless (find o *inspector-history*) + (vector-push-extend o *inspector-history*)) + (let ((previous (istate.previous istate))) + (if previous (setf (istate.next previous) istate))) + (istate>elisp istate))) + +(defun emacs-inspect/istate (istate) + (with-bindings (if (istate.verbose istate) + *inspector-verbose-printer-bindings* + *inspector-printer-bindings*) + (emacs-inspect (istate.object istate)))) + +(defun istate>elisp (istate) + (list :title (prepare-title istate) + :id (assign-index (istate.object istate) (istate.parts istate)) + :content (prepare-range istate 0 500))) + +(defun prepare-title (istate) + (if (istate.verbose istate) + (with-bindings *inspector-verbose-printer-bindings* + (to-string (istate.object istate))) + (with-string-stream (stream :length 200 + :bindings *inspector-printer-bindings*) + (print-unreadable-object + ((istate.object istate) stream :type t :identity t))))) + +(defun prepare-range (istate start end) + (let* ((range (content-range (istate.content istate) start end)) + (ps (loop for part in range append (prepare-part part istate)))) + (list ps + (if (< (length ps) (- end start)) + (+ start (length ps)) + (+ end 1000)) + start end))) + +(defun prepare-part (part istate) + (let ((newline '#.(string #\newline))) + (etypecase part + (string (list part)) + (cons (dcase part + ((:newline) (list newline)) + ((:value obj &optional str) + (list (value-part obj str (istate.parts istate)))) + ((:label &rest strs) + (list (list :label (apply #'cat (mapcar #'string strs))))) + ((:action label lambda &key (refreshp t)) + (list (action-part label lambda refreshp + (istate.actions istate)))) + ((:line label value) + (list (princ-to-string label) ": " + (value-part value nil (istate.parts istate)) + newline))))))) + +(defun value-part (object string parts) + (list :value + (or string (print-part-to-string object)) + (assign-index object parts))) + +(defun action-part (label lambda refreshp actions) + (list :action label (assign-index (list lambda refreshp) actions))) + +(defun assign-index (object vector) + (let ((index (fill-pointer vector))) + (vector-push-extend object vector) + index)) + +(defun print-part-to-string (value) + (let* ((*print-readably* nil) + (string (to-line value)) + (pos (position value *inspector-history*))) + (if pos + (format nil "@~D=~A" pos string) + string))) + +(defun content-range (list start end) + (typecase list + (list (let ((len (length list))) + (subseq list start (min len end)))) + (lcons (llist-range list start end)))) + +(defslimefun inspector-nth-part (index) + "Return the current inspector's INDEXth part. +The second value indicates if that part exists at all." + (let* ((parts (istate.parts *istate*)) + (foundp (< index (length parts)))) + (values (and foundp (aref parts index)) + foundp))) + +(defslimefun inspect-nth-part (index) + (with-buffer-syntax () + (inspect-object (inspector-nth-part index)))) + +(defslimefun inspector-range (from to) + (prepare-range *istate* from to)) + +(defslimefun inspector-call-nth-action (index &rest args) + (destructuring-bind (fun refreshp) (aref (istate.actions *istate*) index) + (apply fun args) + (if refreshp + (inspector-reinspect) + ;; tell emacs that we don't want to refresh the inspector buffer + nil))) + +(defslimefun inspector-pop () + "Inspect the previous object. +Return nil if there's no previous object." + (with-buffer-syntax () + (cond ((istate.previous *istate*) + (setq *istate* (istate.previous *istate*)) + (istate>elisp *istate*)) + (t nil)))) + +(defslimefun inspector-next () + "Inspect the next element in the history of inspected objects.." + (with-buffer-syntax () + (cond ((istate.next *istate*) + (setq *istate* (istate.next *istate*)) + (istate>elisp *istate*)) + (t nil)))) + +(defslimefun inspector-reinspect () + (let ((istate *istate*)) + (setf (istate.content istate) (emacs-inspect/istate istate)) + (istate>elisp istate))) + +(defslimefun inspector-toggle-verbose () + "Toggle verbosity of inspected object." + (setf (istate.verbose *istate*) (not (istate.verbose *istate*))) + (istate>elisp *istate*)) + +(defslimefun inspector-eval (string) + (let* ((obj (istate.object *istate*)) + (context (eval-context obj)) + (form (with-buffer-syntax ((cdr (assoc '*package* context))) + (read-from-string string))) + (ignorable (remove-if #'boundp (mapcar #'car context)))) + (to-string (eval `(let ((* ',obj) (- ',form) + . ,(loop for (var . val) in context + unless (constantp var) collect + `(,var ',val))) + (declare (ignorable . ,ignorable)) + ,form))))) + +(defslimefun inspector-history () + (with-output-to-string (out) + (let ((newest (loop for s = *istate* then next + for next = (istate.next s) + if (not next) return s))) + (format out "--- next/prev chain ---") + (loop for s = newest then (istate.previous s) while s do + (let ((val (istate.object s))) + (format out "~%~:[ ~; *~]@~d " + (eq s *istate*) + (position val *inspector-history*)) + (print-unreadable-object (val out :type t :identity t))))) + (format out "~%~%--- all visited objects ---") + (loop for val across *inspector-history* for i from 0 do + (format out "~%~2,' d " i) + (print-unreadable-object (val out :type t :identity t))))) + +(defslimefun quit-inspector () + (reset-inspector) + nil) + +(defslimefun describe-inspectee () + "Describe the currently inspected object." + (with-buffer-syntax () + (describe-to-string (istate.object *istate*)))) + +(defslimefun pprint-inspector-part (index) + "Pretty-print the currently inspected object." + (with-buffer-syntax () + (swank-pprint (list (inspector-nth-part index))))) + +(defslimefun inspect-in-frame (string index) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME inspection request.") + (reset-inspector) + (inspect-object (eval-in-frame (from-string string) index))))) + +(defslimefun inspect-current-condition () + (with-buffer-syntax () + (reset-inspector) + (inspect-object *swank-debugger-condition*))) + +(defslimefun inspect-frame-var (frame var) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (frame-var-value frame var)))) + +;;;;; Lists + +(defmethod emacs-inspect ((o cons)) + (if (listp (cdr o)) + (inspect-list o) + (inspect-cons o))) + +(defun inspect-cons (cons) + (label-value-line* + ('car (car cons)) + ('cdr (cdr cons)))) + +(defun inspect-list (list) + (multiple-value-bind (length tail) (safe-length list) + (flet ((frob (title list) + (list* title '(:newline) (inspect-list-aux list)))) + (cond ((not length) + (frob "A circular list:" + (cons (car list) + (ldiff (cdr list) list)))) + ((not tail) + (frob "A proper list:" list)) + (t + (frob "An improper list:" list)))))) + +(defun inspect-list-aux (list) + (loop for i from 0 for rest on list while (consp rest) append + (if (listp (cdr rest)) + (label-value-line i (car rest)) + (label-value-line* (i (car rest)) (:tail (cdr rest)))))) + +(defun safe-length (list) + "Similar to `list-length', but avoid errors on improper lists. +Return two values: the length of the list and the last cdr. +Return NIL if LIST is circular." + (do ((n 0 (+ n 2)) ;Counter. + (fast list (cddr fast)) ;Fast pointer: leaps by 2. + (slow list (cdr slow))) ;Slow pointer: leaps by 1. + (nil) + (cond ((null fast) (return (values n nil))) + ((not (consp fast)) (return (values n fast))) + ((null (cdr fast)) (return (values (1+ n) (cdr fast)))) + ((and (eq fast slow) (> n 0)) (return nil)) + ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) + +;;;;; Hashtables + +(defun hash-table-to-alist (ht) + (let ((result '())) + (maphash (lambda (key value) + (setq result (acons key value result))) + ht) + result)) + +(defmethod emacs-inspect ((ht hash-table)) + (append + (label-value-line* + ("Count" (hash-table-count ht)) + ("Size" (hash-table-size ht)) + ("Test" (hash-table-test ht)) + ("Rehash size" (hash-table-rehash-size ht)) + ("Rehash threshold" (hash-table-rehash-threshold ht))) + (let ((weakness (hash-table-weakness ht))) + (when weakness + (label-value-line "Weakness:" weakness))) + (unless (zerop (hash-table-count ht)) + `((:action "[clear hashtable]" + ,(lambda () (clrhash ht))) (:newline) + "Contents: " (:newline))) + (let ((content (hash-table-to-alist ht))) + (cond ((every (lambda (x) (typep (first x) '(or string symbol))) content) + (setf content (sort content 'string< :key #'first))) + ((every (lambda (x) (typep (first x) 'real)) content) + (setf content (sort content '< :key #'first)))) + (loop for (key . value) in content appending + `((:value ,key) " = " (:value ,value) + " " (:action "[remove entry]" + ,(let ((key key)) + (lambda () (remhash key ht)))) + (:newline)))))) + +;;;;; Arrays + +(defmethod emacs-inspect ((array array)) + (lcons* + (iline "Dimensions" (array-dimensions array)) + (iline "Element type" (array-element-type array)) + (iline "Total size" (array-total-size array)) + (iline "Adjustable" (adjustable-array-p array)) + (iline "Fill pointer" (if (array-has-fill-pointer-p array) + (fill-pointer array))) + "Contents:" '(:newline) + (labels ((k (i max) + (cond ((= i max) '()) + (t (lcons (iline i (row-major-aref array i)) + (k (1+ i) max)))))) + (k 0 (array-total-size array))))) + +;;;;; Chars + +(defmethod emacs-inspect ((char character)) + (append + (label-value-line* + ("Char code" (char-code char)) + ("Lower cased" (char-downcase char)) + ("Upper cased" (char-upcase char))) + (if (get-macro-character char) + `("In the current readtable (" + (:value ,*readtable*) ") it is a macro character: " + (:value ,(get-macro-character char)))))) + +;;;; Thread listing + +(defvar *thread-list* () + "List of threads displayed in Emacs. We don't care a about +synchronization issues (yet). There can only be one thread listing at +a time.") + +(defslimefun list-threads () + "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...). +LABELS is a list of attribute names and the remaining lists are the +corresponding attribute values per thread. +Example: + ((:id :name :status :priority) + (6 \"swank-indentation-cache-thread\" \"Semaphore timed wait\" 0) + (5 \"reader-thread\" \"Active\" 0) + (4 \"control-thread\" \"Semaphore timed wait\" 0) + (2 \"Swank Sentinel\" \"Semaphore timed wait\" 0) + (1 \"listener\" \"Active\" 0) + (0 \"Initial\" \"Sleep\" 0))" + (setq *thread-list* (all-threads)) + (when (and *emacs-connection* + (use-threads-p) + (equalp (thread-name (current-thread)) "worker")) + (setf *thread-list* (delete (current-thread) *thread-list*))) + (let* ((plist (thread-attributes (car *thread-list*))) + (labels (loop for (key) on plist by #'cddr + collect key))) + `((:id :name :status ,@labels) + ,@(loop for thread in *thread-list* + for name = (thread-name thread) + for attributes = (thread-attributes thread) + collect (list* (thread-id thread) + (string name) + (thread-status thread) + (loop for label in labels + collect (getf attributes label))))))) + +(defslimefun quit-thread-browser () + (setq *thread-list* nil)) + +(defun nth-thread (index) + (nth index *thread-list*)) + +(defslimefun debug-nth-thread (index) + (let ((connection *emacs-connection*)) + (queue-thread-interrupt + (nth-thread index) + (lambda () + (with-connection (connection) + (simple-break)))))) + +(defslimefun kill-nth-thread (index) + (kill-thread (nth-thread index))) + +(defslimefun start-swank-server-in-thread (index port-file-name) + "Interrupt the INDEXth thread and make it start a swank server. +The server port is written to PORT-FILE-NAME." + (interrupt-thread (nth-thread index) + (lambda () + (start-server port-file-name :style nil)))) + +;;;; Class browser + +(defun mop-helper (class-name fn) + (let ((class (find-class class-name nil))) + (if class + (mapcar (lambda (x) (to-string (class-name x))) + (funcall fn class))))) + +(defslimefun mop (type symbol-name) + "Return info about classes using mop. + + When type is: + :subclasses - return the list of subclasses of class. + :superclasses - return the list of superclasses of class." + (let ((symbol (parse-symbol symbol-name *buffer-package*))) + (ecase type + (:subclasses + (mop-helper symbol #'swank-mop:class-direct-subclasses)) + (:superclasses + (mop-helper symbol #'swank-mop:class-direct-superclasses))))) + + +;;;; Automatically synchronized state +;;; +;;; Here we add hooks to push updates of relevant information to +;;; Emacs. + +;;;;; *FEATURES* + +(defun sync-features-to-emacs () + "Update Emacs if any relevant Lisp state has changed." + ;; FIXME: *slime-features* should be connection-local + (unless (eq *slime-features* *features*) + (setq *slime-features* *features*) + (send-to-emacs (list :new-features (features-for-emacs))))) + +(defun features-for-emacs () + "Return `*slime-features*' in a format suitable to send it to Emacs." + *slime-features*) + +(add-hook *pre-reply-hook* 'sync-features-to-emacs) + + +;;;;; Indentation of macros +;;; +;;; This code decides how macros should be indented (based on their +;;; arglists) and tells Emacs. A per-connection cache is used to avoid +;;; sending redundant information to Emacs -- we just say what's +;;; changed since last time. +;;; +;;; The strategy is to scan all symbols, pick out the macros, and look +;;; for &body-arguments. + +(defvar *configure-emacs-indentation* t + "When true, automatically send indentation information to Emacs +after each command.") + +(defslimefun update-indentation-information () + (send-to-indentation-cache `(:update-indentation-information)) + nil) + +;; This function is for *PRE-REPLY-HOOK*. +(defun sync-indentation-to-emacs () + "Send any indentation updates to Emacs via CONNECTION." + (when *configure-emacs-indentation* + (send-to-indentation-cache `(:sync-indentation ,*buffer-package*)))) + +;; Send REQUEST to the cache. If we are single threaded perform the +;; request right away, otherwise delegate the request to the +;; indentation-cache-thread. +(defun send-to-indentation-cache (request) + (let ((c *emacs-connection*)) + (etypecase c + (singlethreaded-connection + (handle-indentation-cache-request c request)) + (multithreaded-connection + (without-slime-interrupts + (send (mconn.indentation-cache-thread c) request)))))) + +(defun indentation-cache-loop (connection) + (with-connection (connection) + (loop + (restart-case + (handle-indentation-cache-request connection (receive)) + (abort () + :report "Return to the indentation cache request handling loop."))))) + +(defun handle-indentation-cache-request (connection request) + (dcase request + ((:sync-indentation package) + (let ((fullp (need-full-indentation-update-p connection))) + (perform-indentation-update connection fullp package))) + ((:update-indentation-information) + (perform-indentation-update connection t nil)))) + +(defun need-full-indentation-update-p (connection) + "Return true if the whole indentation cache should be updated. +This is a heuristic to avoid scanning all symbols all the time: +instead, we only do a full scan if the set of packages has changed." + (set-difference (list-all-packages) + (connection.indentation-cache-packages connection))) + +(defun perform-indentation-update (connection force package) + "Update the indentation cache in CONNECTION and update Emacs. +If FORCE is true then start again without considering the old cache." + (let ((cache (connection.indentation-cache connection))) + (when force (clrhash cache)) + (let ((delta (update-indentation/delta-for-emacs cache force package))) + (setf (connection.indentation-cache-packages connection) + (list-all-packages)) + (unless (null delta) + (setf (connection.indentation-cache connection) cache) + (send-to-emacs (list :indentation-update delta)))))) + +(defun update-indentation/delta-for-emacs (cache force package) + "Update the cache and return the changes in a (SYMBOL INDENT PACKAGES) list. +If FORCE is true then check all symbols, otherwise only check symbols +belonging to PACKAGE." + (let ((alist '())) + (flet ((consider (symbol) + (let ((indent (symbol-indentation symbol))) + (when indent + (unless (equal (gethash symbol cache) indent) + (setf (gethash symbol cache) indent) + (let ((pkgs (mapcar #'package-name + (symbol-packages symbol))) + (name (string-downcase symbol))) + (push (list name indent pkgs) alist))))))) + (cond (force + (do-all-symbols (symbol) + (consider symbol))) + ((package-name package) ; don't try to iterate over a + ; deleted package. + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (consider symbol))))) + alist))) + +(defun package-names (package) + "Return the name and all nicknames of PACKAGE in a fresh list." + (cons (package-name package) (copy-list (package-nicknames package)))) + +(defun symbol-packages (symbol) + "Return the packages where SYMBOL can be found." + (let ((string (string symbol))) + (loop for p in (list-all-packages) + when (eq symbol (find-symbol string p)) + collect p))) + +(defun cl-symbol-p (symbol) + "Is SYMBOL a symbol in the COMMON-LISP package?" + (eq (symbol-package symbol) cl-package)) + +(defun known-to-emacs-p (symbol) + "Return true if Emacs has special rules for indenting SYMBOL." + (cl-symbol-p symbol)) + +(defun symbol-indentation (symbol) + "Return a form describing the indentation of SYMBOL. +The form is to be used as the `common-lisp-indent-function' property +in Emacs." + (if (and (macro-function symbol) + (not (known-to-emacs-p symbol))) + (let ((arglist (arglist symbol))) + (etypecase arglist + ((member :not-available) + nil) + (list + (macro-indentation arglist)))) + nil)) + +(defun macro-indentation (arglist) + (if (well-formed-list-p arglist) + (position '&body (remove '&optional (clean-arglist arglist))) + nil)) + +(defun clean-arglist (arglist) + "Remove &whole, &enviroment, and &aux elements from ARGLIST." + (cond ((null arglist) '()) + ((member (car arglist) '(&whole &environment)) + (clean-arglist (cddr arglist))) + ((eq (car arglist) '&aux) + '()) + (t (cons (car arglist) (clean-arglist (cdr arglist)))))) + +(defun well-formed-list-p (list) + "Is LIST a proper list terminated by NIL?" + (typecase list + (null t) + (cons (well-formed-list-p (cdr list))) + (t nil))) + +(defun print-indentation-lossage (&optional (stream *standard-output*)) + "Return the list of symbols whose indentation styles collide incompatibly. +Collisions are caused because package information is ignored." + (let ((table (make-hash-table :test 'equal))) + (flet ((name (s) (string-downcase (symbol-name s)))) + (do-all-symbols (s) + (setf (gethash (name s) table) + (cons s (symbol-indentation s)))) + (let ((collisions '())) + (do-all-symbols (s) + (let* ((entry (gethash (name s) table)) + (owner (car entry)) + (indent (cdr entry))) + (unless (or (eq s owner) + (equal (symbol-indentation s) indent) + (and (not (fboundp s)) + (null (macro-function s)))) + (pushnew owner collisions) + (pushnew s collisions)))) + (if (null collisions) + (format stream "~&No worries!~%") + (format stream "~&Symbols with collisions:~%~{ ~S~%~}" + collisions)))))) + +;;; FIXME: it's too slow on CLASP right now, remove once it's fast enough. +#-clasp +(add-hook *pre-reply-hook* 'sync-indentation-to-emacs) + +(defun make-output-function-for-target (connection target) + "Create a function to send user output to a specific TARGET in Emacs." + (lambda (string) + (swank::with-connection (connection) + (with-simple-restart + (abort "Abort sending output to Emacs.") + (swank::send-to-emacs `(:write-string ,string ,target)))))) + +(defun make-output-stream-for-target (connection target) + "Create a stream that sends output to a specific TARGET in Emacs." + (make-output-stream (make-output-function-for-target connection target))) + + +;;;; Testing + +(defslimefun io-speed-test (&optional (n 1000) (m 1)) + (let* ((s *standard-output*) + (*trace-output* (make-broadcast-stream s *log-output*))) + (time (progn + (dotimes (i n) + (format s "~D abcdefghijklm~%" i) + (when (zerop (mod n m)) + (finish-output s))) + (finish-output s) + (when *emacs-connection* + (eval-in-emacs '(message "done."))))) + (terpri *trace-output*) + (finish-output *trace-output*) + nil)) + +(defslimefun flow-control-test (n delay) + (let ((stream (make-output-stream + (let ((conn *emacs-connection*)) + (lambda (string) + (declare (ignore string)) + (with-connection (conn) + (send-to-emacs `(:test-delay ,delay)))))))) + (dotimes (i n) + (print i stream) + (force-output stream) + (background-message "flow-control-test: ~d" i)))) + + +(defun before-init (version load-path) + (pushnew :swank *features*) + (setq *swank-wire-protocol-version* version) + (setq *load-path* load-path)) + +(defun init () + (run-hook *after-init-hook*)) + +;; Local Variables: +;; coding: latin-1-unix +;; indent-tabs-mode: nil +;; outline-regexp: ";;;;;*" +;; End: + +;;; swank.lisp ends here diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/abcl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/abcl.lisp new file mode 100644 index 0000000..f5764d6 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/abcl.lisp @@ -0,0 +1,847 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*- +;;; +;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME. +;;; +;;; Adapted from swank-acl.lisp, Andras Simon, 2004 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/abcl + (:use cl swank/backend)) + +(in-package swank/abcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :collect) ;just so that it doesn't spoil the flying letters + (require :pprint) + (require :gray-streams) + (assert (>= (read-from-string (subseq (lisp-implementation-version) 0 4)) + 0.22) + () "This file needs ABCL version 0.22 or newer")) + +(defimplementation gray-package-name () + "GRAY-STREAMS") + +;; FIXME: switch to shared Gray stream implementation when bugs are +;; fixed in ABCL. See: http://abcl.org/trac/ticket/373. +(progn + (defimplementation make-output-stream (write-string) + (ext:make-slime-output-stream write-string)) + + (defimplementation make-input-stream (read-string) + (ext:make-slime-input-stream read-string + (make-synonym-stream '*standard-output*)))) + +(defimplementation call-with-compilation-hooks (function) + (funcall function)) + +;;; swank-mop + +;;dummies and definition + +(defclass standard-slot-definition ()()) + +;(defun class-finalized-p (class) t) + +(defun slot-definition-documentation (slot) + (declare (ignore slot)) + #+nil (documentation slot 't)) + +(defun slot-definition-type (slot) + (declare (ignore slot)) + t) + +(defun class-prototype (class) + (declare (ignore class)) + nil) + +(defun generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun specializer-direct-methods (spec) + (mop:class-direct-methods spec)) + +(defun slot-definition-name (slot) + (mop:slot-definition-name slot)) + +(defun class-slots (class) + (mop:class-slots class)) + +(defun method-generic-function (method) + (mop:method-generic-function method)) + +(defun method-function (method) + (mop:method-function method)) + +(defun slot-boundp-using-class (class object slotdef) + (declare (ignore class)) + (system::slot-boundp object (slot-definition-name slotdef))) + +(defun slot-value-using-class (class object slotdef) + (declare (ignore class)) + (system::slot-value object (slot-definition-name slotdef))) + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + standard-slot-definition ;;dummy + cl:method + cl:standard-class + #+#.(swank/backend:with-symbol 'compute-applicable-methods-using-classes + 'mop) + mop:compute-applicable-methods-using-classes + ;; standard-class readers + mop:class-default-initargs + mop:class-direct-default-initargs + mop:class-direct-slots + mop:class-direct-subclasses + mop:class-direct-superclasses + mop:eql-specializer + mop:class-finalized-p + mop:finalize-inheritance + cl:class-name + mop:class-precedence-list + class-prototype ;;dummy + class-slots + specializer-direct-methods + ;; eql-specializer accessors + mop::eql-specializer-object + ;; generic function readers + mop:generic-function-argument-precedence-order + generic-function-declarations ;;dummy + mop:generic-function-lambda-list + mop:generic-function-methods + mop:generic-function-method-class + mop:generic-function-method-combination + mop:generic-function-name + ;; method readers + method-generic-function + method-function + mop:method-lambda-list + mop:method-specializers + mop:method-qualifiers + ;; slot readers + mop:slot-definition-allocation + slot-definition-documentation ;;dummy + mop:slot-definition-initargs + mop:slot-definition-initform + mop:slot-definition-initfunction + slot-definition-name + slot-definition-type ;;dummy + mop:slot-definition-readers + mop:slot-definition-writers + slot-boundp-using-class + slot-value-using-class + mop:slot-makunbound-using-class)) + +;;;; TCP Server + + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (ext:make-server-socket port)) + +(defimplementation local-port (socket) + (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket)) + +(defimplementation close-socket (socket) + (ext:server-socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (ext:get-socket-stream (ext:socket-accept socket) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) + +;;;; UTF8 + +;; faster please! +(defimplementation string-to-utf8 (s) + (jbytes-to-octets + (java:jcall + (java:jmethod "java.lang.String" "getBytes" "java.lang.String") + s + "UTF8"))) + +(defimplementation utf8-to-string (u) + (java:jnew + (java:jconstructor "org.armedbear.lisp.SimpleString" + "java.lang.String") + (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String") + (octets-to-jbytes u) + "UTF8"))) + +(defun octets-to-jbytes (octets) + (declare (type octets (simple-array (unsigned-byte 8) (*)))) + (let* ((len (length octets)) + (bytes (java:jnew-array "byte" len))) + (loop for byte across octets + for i from 0 + do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte" + "java.lang.Object" "int" "byte") + "java.lang.relect.Array" + bytes i byte)) + bytes)) + +(defun jbytes-to-octets (jbytes) + (let* ((len (java:jarray-length jbytes)) + (octets (make-array len :element-type '(unsigned-byte 8)))) + (loop for i from 0 below len + for jbyte = (java:jarray-ref jbytes i) + do (setf (aref octets i) jbyte)) + octets)) + +;;;; External formats + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1") + ((:iso-8859-1 :eol-style :lf) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + (:utf-8 "utf-8") + ((:utf-8 :eol-style :lf) "utf-8-unix") + (:euc-jp "euc-jp") + ((:euc-jp :eol-style :lf) "euc-jp-unix") + (:us-ascii "us-ascii") + ((:us-ascii :eol-style :lf) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) + (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +;;;; Unix signals + +(defimplementation getpid () + (handler-case + (let* ((runtime + (java:jstatic "getRuntime" "java.lang.Runtime")) + (command + (java:jnew-array-from-array + "java.lang.String" #("sh" "-c" "echo $PPID"))) + (runtime-exec-jmethod + ;; Complicated because java.lang.Runtime.exec() is + ;; overloaded on a non-primitive type (array of + ;; java.lang.String), so we have to use the actual + ;; parameter instance to get java.lang.Class + (java:jmethod "java.lang.Runtime" "exec" + (java:jcall + (java:jmethod "java.lang.Object" "getClass") + command))) + (process + (java:jcall runtime-exec-jmethod runtime command)) + (output + (java:jcall (java:jmethod "java.lang.Process" "getInputStream") + process))) + (java:jcall (java:jmethod "java.lang.Process" "waitFor") + process) + (loop :with b :do + (setq b + (java:jcall (java:jmethod "java.io.InputStream" "read") + output)) + :until (member b '(-1 #x0a)) ; Either EOF or LF + :collecting (code-char b) :into result + :finally (return + (parse-integer (coerce result 'string))))) + (t () 0))) + +(defimplementation lisp-implementation-type-name () + "armedbear") + +(defimplementation set-default-directory (directory) + (let ((dir (sys::probe-directory directory))) + (when dir (setf *default-pathname-defaults* dir)) + (namestring dir))) + + +;;;; Misc + +(defimplementation arglist (fun) + (cond ((symbolp fun) + (multiple-value-bind (arglist present) + (sys::arglist fun) + (when (and (not present) + (fboundp fun) + (typep (symbol-function fun) + 'standard-generic-function)) + (setq arglist + (mop::generic-function-lambda-list (symbol-function fun)) + present + t)) + (if present arglist :not-available))) + (t :not-available))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form &optional env) + (ext:macroexpand-all form env)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,(macroexpand-all form env))))) + (values macro-forms nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + ((:variable :macro) + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + + +;;;; Debugger + +;; Copied from swank-sbcl.lisp. +;; +;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*, +;; so we have to make sure that the latter gets run when it was +;; established locally by a user (i.e. changed meanwhile.) +(defun make-invoke-debugger-hook (hook) + (lambda (condition old-hook) + (if *debugger-hook* + (funcall *debugger-hook* condition old-hook) + (funcall hook condition old-hook)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank)) + (*sldb-topframe* + (second (member magic-token (sys:backtrace) + :key (lambda (frame) + (first (sys:frame-to-list frame))))))) + (funcall debugger-loop-fn))) + +(defun backtrace (start end) + "A backtrace without initial SWANK frames." + (let ((backtrace (sys:backtrace))) + (subseq (or (member *sldb-topframe* backtrace) backtrace) + start end))) + +(defun nth-frame (index) + (nth index (backtrace 0 nil))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (backtrace start end))) + +(defimplementation print-frame (frame stream) + (write-string (sys:frame-to-string frame) + stream)) + +;;; Sorry, but can't seem to declare DEFIMPLEMENTATION under FLET. +;;; --ME 20150403 +(defun nth-frame-list (index) + (java:jcall "toLispList" (nth-frame index))) + +(defun match-lambda (operator values) + (jvm::match-lambda-list + (multiple-value-list + (jvm::parse-lambda-list (ext:arglist operator))) + values)) + +(defimplementation frame-locals (index) + (loop + :for id :upfrom 0 + :with frame = (nth-frame-list index) + :with operator = (first frame) + :with values = (rest frame) + :with arglist = (if (and operator (consp values) (not (null values))) + (handler-case + (match-lambda operator values) + (jvm::lambda-list-mismatch (e) + :lambda-list-mismatch)) + :not-available) + :for value :in values + :collecting (list + :name (if (not (keywordp arglist)) + (first (nth id arglist)) + (format nil "arg~A" id)) + :id id + :value value))) + +(defimplementation frame-var-value (index id) + (elt (rest (java:jcall "toLispList" (nth-frame index))) id)) + + +#+nil +(defimplementation disassemble-frame (index) + (disassemble (debugger:frame-function (nth-frame index)))) + +(defimplementation frame-source-location (index) + (let ((frame (nth-frame index))) + (or (source-location (nth-frame index)) + `(:error ,(format nil "No source for frame: ~a" frame))))) + +#+nil +(defimplementation eval-in-frame (form frame-number) + (debugger:eval-form-in-context + form + (debugger:environment-of-frame (nth-frame frame-number)))) + +#+nil +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +;;; XXX doesn't work for frames with arguments +#+nil +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (debugger:frame-retry frame (debugger:frame-function frame)))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defvar *abcl-signaled-conditions*) + +(defun handle-compiler-warning (condition) + (let ((loc (when (and jvm::*compile-file-pathname* + system::*source-position*) + (cons jvm::*compile-file-pathname* system::*source-position*)))) + ;; filter condition signaled more than once. + (unless (member condition *abcl-signaled-conditions*) + (push condition *abcl-signaled-conditions*) + (signal 'compiler-condition + :original-condition condition + :severity :warning + :message (format nil "~A" condition) + :location (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0))) + (loc + (destructuring-bind (file . pos) loc + (make-location + (list :file (namestring (truename file))) + (list :position (1+ pos))))) + (t + (make-location + (list :file (namestring *compile-filename*)) + (list :position 1)))))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore external-format policy)) + (let ((jvm::*resignal-compiler-warnings* t) + (*abcl-signaled-conditions* nil)) + (handler-bind ((warning #'handle-compiler-warning)) + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (multiple-value-bind (fn warn fail) + (compile-file input-file :output-file output-file) + (values fn warn + (and fn load-p + (not (load fn))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (let ((jvm::*resignal-compiler-warnings* t) + (*abcl-signaled-conditions* nil)) + (handler-bind ((warning #'handle-compiler-warning)) + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string) + (sys::*source* (make-pathname :device "emacs-buffer" :name buffer)) + (sys::*source-position* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t)))) + +#| +;;;; Definition Finding + +(defun find-fspec-location (fspec type) + (let ((file (excl::fspec-pathname fspec type))) + (etypecase file + (pathname + (let ((start (scm:find-definition-in-file fspec type file))) + (make-location (list :file (namestring (truename file))) + (if start + (list :position (1+ start)) + (list :function-name (string fspec)))))) + ((member :top-level) + (list :error (format nil "Defined at toplevel: ~A" fspec))) + (null + (list :error (format nil "Unkown source location for ~A" fspec)))))) + +(defun fspec-definition-locations (fspec) + (let ((defs (excl::find-multiple-definitions fspec))) + (loop for (fspec type) in defs + collect (list fspec (find-fspec-location fspec type))))) + +(defimplementation find-definitions (symbol) + (fspec-definition-locations symbol)) +|# + +(defgeneric source-location (object)) + +(defmethod source-location ((symbol symbol)) + (when (pathnamep (ext:source-pathname symbol)) + (let ((pos (ext:source-file-position symbol)) + (path (namestring (ext:source-pathname symbol)))) + (cond ((ext:pathname-jar-p path) + `(:location + ;; strip off "jar:file:" = 9 characters + (:zip ,@(split-string (subseq path 9) "!/")) + ;; pos never seems right. Use function name. + (:function-name ,(string symbol)) + (:align t))) + ((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer") + ;; conspire with swank-compile-string to keep the buffer + ;; name in a pathname whose device is "emacs-buffer". + `(:location + (:buffer ,(pathname-name (ext:source-pathname symbol))) + (:function-name ,(string symbol)) + (:align t))) + (t + `(:location + (:file ,path) + ,(if pos + (list :position (1+ pos)) + (list :function-name (string symbol))) + (:align t))))))) + +(defmethod source-location ((frame sys::java-stack-frame)) + (destructuring-bind (&key class method file line) (sys:frame-to-list frame) + (declare (ignore method)) + (let ((file (or (find-file-in-path file *source-path*) + (let ((f (format nil "~{~a/~}~a" + (butlast (split-string class "\\.")) + file))) + (find-file-in-path f *source-path*))))) + (and file + `(:location ,file (:line ,line) ()))))) + +(defmethod source-location ((frame sys::lisp-stack-frame)) + (destructuring-bind (operator &rest args) (sys:frame-to-list frame) + (declare (ignore args)) + (etypecase operator + (function (source-location operator)) + (list nil) + (symbol (source-location operator))))) + +(defmethod source-location ((fun function)) + (let ((name (function-name fun))) + (and name (source-location name)))) + +(defun system-property (name) + (java:jstatic "getProperty" "java.lang.System" name)) + +(defun pathname-parent (pathname) + (make-pathname :directory (butlast (pathname-directory pathname)))) + +(defun pathname-absolute-p (pathname) + (eq (car (pathname-directory pathname)) ':absolute)) + +(defun split-string (string regexp) + (coerce + (java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String") + string regexp) + 'list)) + +(defun path-separator () + (java:jfield "java.io.File" "pathSeparator")) + +(defun search-path-property (prop-name) + (let ((string (system-property prop-name))) + (and string + (remove nil + (mapcar #'truename + (split-string string (path-separator))))))) + +(defun jdk-source-path () + (let* ((jre-home (truename (system-property "java.home"))) + (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home))) + (truename (probe-file src-zip))) + (and truename (list truename)))) + +(defun class-path () + (append (search-path-property "java.class.path") + (search-path-property "sun.boot.class.path"))) + +(defvar *source-path* + (append (search-path-property "user.dir") + (jdk-source-path) + ;;(list (truename "/scratch/abcl/src")) + ) + "List of directories to search for source files.") + +(defun zipfile-contains-p (zipfile-name entry-name) + (let ((zipfile (java:jnew (java:jconstructor "java.util.zip.ZipFile" + "java.lang.String") + zipfile-name))) + (java:jcall + (java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String") + zipfile entry-name))) + +;; (find-file-in-path "java/lang/String.java" *source-path*) +;; (find-file-in-path "Lisp.java" *source-path*) + +;; Try to find FILENAME in PATH. If found, return a file spec as +;; needed by Emacs. We also look in zip files. +(defun find-file-in-path (filename path) + (labels ((try (dir) + (cond ((not (pathname-type dir)) + (let ((f (probe-file (merge-pathnames filename dir)))) + (and f `(:file ,(namestring f))))) + ((equal (pathname-type dir) "zip") + (try-zip dir)) + (t (error "strange path element: ~s" path)))) + (try-zip (zip) + (let* ((zipfile-name (namestring (truename zip)))) + (and (zipfile-contains-p zipfile-name filename) + `(:dir ,zipfile-name ,filename))))) + (cond ((pathname-absolute-p filename) (probe-file filename)) + (t + (loop for dir in path + if (try dir) return it))))) + +(defimplementation find-definitions (symbol) + (ext:resolve symbol) + (let ((srcloc (source-location symbol))) + (and srcloc `((,symbol ,srcloc))))) + +#| +Uncomment this if you have patched xref.lisp, as in +http://article.gmane.org/gmane.lisp.slime.devel/2425 +Also, make sure that xref.lisp is loaded by modifying the armedbear +part of *sysdep-pathnames* in swank.loader.lisp. + +;;;; XREF +(setq pxref:*handle-package-forms* '(cl:in-package)) + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls pxref:list-callers) +(defxref who-references pxref:list-readers) +(defxref who-binds pxref:list-setters) +(defxref who-sets pxref:list-setters) +(defxref list-callers pxref:list-callers) +(defxref list-callees pxref:list-callees) + +(defun xref-results (symbols) + (let ((xrefs '())) + (dolist (symbol symbols) + (push (list symbol (cadar (source-location symbol))) xrefs)) + xrefs)) +|# + +;;;; Inspecting +(defmethod emacs-inspect ((o t)) + (let ((parts (sys:inspected-parts o))) + `("The object is of type " ,(symbol-name (type-of o)) "." (:newline) + ,@(if parts + (loop :for (label . value) :in parts + :appending (label-value-line label value)) + (list "No inspectable parts, dumping output of CL:DESCRIBE:" + '(:newline) + (with-output-to-string (desc) (describe o desc))))))) + +(defmethod emacs-inspect ((slot mop::slot-definition)) + `("Name: " + (:value ,(mop:slot-definition-name slot)) + (:newline) + "Documentation:" (:newline) + ,@(when (slot-definition-documentation slot) + `((:value ,(slot-definition-documentation slot)) (:newline))) + "Initialization:" (:newline) + " Args: " (:value ,(mop:slot-definition-initargs slot)) (:newline) + " Form: " ,(if (mop:slot-definition-initfunction slot) + `(:value ,(mop:slot-definition-initform slot)) + "#") (:newline) + " Function: " + (:value ,(mop:slot-definition-initfunction slot)) + (:newline))) + +(defmethod emacs-inspect ((f function)) + `(,@(when (function-name f) + `("Name: " + ,(princ-to-string (function-name f)) (:newline))) + ,@(multiple-value-bind (args present) + (sys::arglist f) + (when present + `("Argument list: " + ,(princ-to-string args) (:newline)))) + (:newline) + #+nil,@(when (documentation f t) + `("Documentation:" (:newline) + ,(documentation f t) (:newline))) + ,@(when (function-lambda-expression f) + `("Lambda expression:" + (:newline) ,(princ-to-string + (function-lambda-expression f)) (:newline))))) + +;;; Although by convention toString() is supposed to be a +;;; non-computationally expensive operation this isn't always the +;;; case, so make its computation a user interaction. +(defparameter *to-string-hashtable* (make-hash-table)) +(defmethod emacs-inspect ((o java:java-object)) + (let ((to-string (lambda () + (handler-case + (setf (gethash o *to-string-hashtable*) + (java:jcall "toString" o)) + (t (e) + (setf (gethash o *to-string-hashtable*) + (format nil + "Could not invoke toString(): ~A" + e))))))) + (append + (if (gethash o *to-string-hashtable*) + (label-value-line "toString()" (gethash o *to-string-hashtable*)) + `((:action "[compute toString()]" ,to-string) (:newline))) + (loop :for (label . value) :in (sys:inspected-parts o) + :appending (label-value-line label value))))) + +;;;; Multithreading + +(defimplementation spawn (fn &key name) + (threads:make-thread (lambda () (funcall fn)) :name name)) + +(defvar *thread-plists* (make-hash-table) ; should be a weak table + "A hashtable mapping threads to a plist.") + +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (threads:synchronized-on *thread-plists* + (or (getf (gethash thread *thread-plists*) 'id) + (setf (getf (gethash thread *thread-plists*) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-plists*) 'id)))) + +(defimplementation thread-name (thread) + (threads:thread-name thread)) + +(defimplementation thread-status (thread) + (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread))) + +(defimplementation make-lock (&key name) + (declare (ignore name)) + (threads:make-thread-lock)) + +(defimplementation call-with-lock-held (lock function) + (threads:with-thread-lock (lock) (funcall function))) + +(defimplementation current-thread () + (threads:current-thread)) + +(defimplementation all-threads () + (copy-list (threads:mapcar-threads #'identity))) + +(defimplementation thread-alive-p (thread) + (member thread (all-threads))) + +(defimplementation interrupt-thread (thread fn) + (threads:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (threads:destroy-thread thread)) + +(defstruct mailbox + (queue '())) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (threads:synchronized-on *thread-plists* + (or (getf (gethash thread *thread-plists*) 'mailbox) + (setf (getf (gethash thread *thread-plists*) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (threads:synchronized-on mbox + (setf (mailbox-queue mbox) + (nconc (mailbox-queue mbox) (list message))) + (threads:object-notify-all mbox)))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread)))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (threads:synchronized-on mbox + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))) + (when (eq timeout t) (return (values nil t))) + (threads:object-wait mbox 0.3)))))) + +(defimplementation quit-lisp () + (ext:exit)) +;;; +#+#.(swank/backend:with-symbol 'package-local-nicknames 'ext) +(defimplementation package-local-nicknames (package) + (ext:package-local-nicknames package)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/allegro.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/allegro.lisp new file mode 100644 index 0000000..63f4b6f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/allegro.lisp @@ -0,0 +1,1070 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*- +;;; +;;; swank-allegro.lisp --- Allegro CL specific code for SLIME. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/allegro + (:use cl swank/backend)) + +(in-package swank/allegro) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + (require :process) + #+(version>= 8 2) + (require 'lldb)) + +(defimplementation gray-package-name () + '#:excl) + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; UTF8 + +(define-symbol-macro utf8-ef + (load-time-value + (excl:crlf-base-ef (excl:find-external-format :utf-8)) + t)) + +(defimplementation string-to-utf8 (s) + (excl:string-to-octets s :external-format utf8-ef + :null-terminate nil)) + +(defimplementation utf8-to-string (u) + (excl:octets-to-string u :external-format utf8-ef)) + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (socket:make-socket :connect :passive :local-port port + :local-host host :reuse-address t + :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (socket:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format buffering + timeout) + (declare (ignore buffering timeout)) + (let ((s (socket:accept-connection socket :wait t))) + (when external-format + (setf (stream-external-format s) external-format)) + s)) + +(defimplementation socket-fd (stream) + (excl::stream-input-handle stream)) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix") + (:emacs-mule "emacs-mule" "emacs-mule-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + (and e (excl:crlf-base-ef + (excl:find-external-format (car e) + :try-variant t))))) + +;;;; Unix signals + +(defimplementation getpid () + (excl::getpid)) + +(defimplementation lisp-implementation-type-name () + "allegro") + +(defimplementation set-default-directory (directory) + (let* ((dir (namestring (truename (merge-pathnames directory))))) + (setf *default-pathname-defaults* (pathname (excl:chdir dir))) + dir)) + +(defimplementation default-directory () + (namestring (excl:current-directory))) + +;;;; Misc + +(defimplementation arglist (symbol) + (handler-case (excl:arglist symbol) + (simple-error () :not-available))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + #+(version>= 8 0) + (excl::walk-form form) + #-(version>= 8 0) + (excl::walk form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defimplementation function-name (f) + (check-type f function) + (cross-reference::object-to-function-name f)) + +;;;; Debugger + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let ((*sldb-topframe* (find-topframe)) + (excl::*break-hook* nil)) + (funcall debugger-loop-fn))) + +(defimplementation sldb-break-at-start (fname) + ;; :print-before is kind of mis-used but we just want to stuff our + ;; break form somewhere. This does not work for setf, :before and + ;; :after methods, which need special syntax in the trace call, see + ;; ACL's doc/debugging.htm chapter 10. + (eval `(trace (,fname + :print-before + ((break "Function start breakpoint of ~A" ',fname))))) + `(:ok ,(format nil "Set breakpoint at start of ~S" fname))) + +(defun find-topframe () + (let ((magic-symbol (intern (symbol-name :swank-debugger-hook) + (find-package :swank))) + (top-frame (excl::int-newest-frame (excl::current-thread)))) + (loop for frame = top-frame then (next-frame frame) + for i from 0 + while (and frame (< i 30)) + when (eq (debugger:frame-name frame) magic-symbol) + return (next-frame frame) + finally (return top-frame)))) + +(defun next-frame (frame) + (let ((next (excl::int-next-older-frame frame))) + (cond ((not next) nil) + ((debugger:frame-visible-p next) next) + (t (next-frame next))))) + +(defun nth-frame (index) + (do ((frame *sldb-topframe* (next-frame frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (next-frame f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (debugger:output-frame stream frame :moderate)) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for i from 0 below (debugger:frame-number-vars frame) + collect (list :name (debugger:frame-var-name frame i) + :id 0 + :value (debugger:frame-var-value frame i))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (debugger:frame-var-value frame var))) + +(defimplementation disassemble-frame (index) + (let ((frame (nth-frame index))) + (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) + (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun) + (disassemble (debugger:frame-function frame))))) + +(defimplementation frame-source-location (index) + (let* ((frame (nth-frame index))) + (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) + (declare (ignore x xx xxx)) + (cond ((and pc + #+(version>= 8 2) + (pc-source-location fun pc) + #-(version>= 8 2) + (function-source-location fun))) + (t ; frames for unbound functions etc end up here + (cadr (car (fspec-definition-locations + (car (debugger:frame-expression frame)))))))))) + +(defun function-source-location (fun) + (cadr (car (fspec-definition-locations + (xref::object-to-function-name fun))))) + +#+(version>= 8 2) +(defun pc-source-location (fun pc) + (let* ((debug-info (excl::function-source-debug-info fun))) + (cond ((not debug-info) + (function-source-location fun)) + (t + (let* ((code-loc (find-if (lambda (c) + (<= (- pc (sys::natural-width)) + (let ((x (excl::ldb-code-pc c))) + (or x -1)) + pc)) + debug-info))) + (cond ((not code-loc) + (ldb-code-to-src-loc (aref debug-info 0))) + (t + (ldb-code-to-src-loc code-loc)))))))) + +#+(version>= 8 2) +(defun ldb-code-to-src-loc (code) + (declare (optimize debug)) + (let* ((func (excl::ldb-code-func code)) + (debug-info (excl::function-source-debug-info func)) + (start (loop for i from (excl::ldb-code-index code) downto 0 + for bpt = (aref debug-info i) + for start = (excl::ldb-code-start-char bpt) + when start + return (if (listp start) + (first start) + start))) + (src-file (excl:source-file func))) + (cond (start + (buffer-or-file-location src-file start)) + (func + (let* ((debug-info (excl::function-source-debug-info func)) + (whole (aref debug-info 0)) + (paths (source-paths-of (excl::ldb-code-source whole) + (excl::ldb-code-source code))) + (path (if paths (longest-common-prefix paths) '())) + (start 0)) + (buffer-or-file + src-file + (lambda (file) + (make-location `(:file ,file) + `(:source-path (0 . ,path) ,start))) + (lambda (buffer bstart) + (make-location `(:buffer ,buffer) + `(:source-path (0 . ,path) + ,(+ bstart start))))))) + (t + nil)))) + +(defun longest-common-prefix (sequences) + (assert sequences) + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix sequences))) + +(defun source-paths-of (whole part) + (let ((result '())) + (labels ((walk (form path) + (cond ((eq form part) + (push (reverse path) result)) + ((consp form) + (loop for i from 0 while (consp form) do + (walk (pop form) (cons i path))))))) + (walk whole '()) + (reverse result)))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + ;; let-bind lexical variables + (let ((vars (loop for i below (debugger:frame-number-vars frame) + for name = (debugger:frame-var-name frame i) + if (typep name '(and symbol (not null) (not keyword))) + collect `(,name ',(debugger:frame-var-value frame i))))) + (debugger:eval-form-in-context + `(let* ,vars ,form) + (debugger:environment-of-frame frame))))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (exp (debugger:frame-expression frame))) + (typecase exp + ((cons symbol) (symbol-package (car exp))) + ((cons (cons (eql :internal) (cons symbol))) + (symbol-package (cadar exp)))))) + +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +(defimplementation frame-restartable-p (frame) + (handler-case (debugger:frame-retryable-p frame) + (serious-condition (c) + (funcall (read-from-string "swank::background-message") + "~a ~a" frame (princ-to-string c)) + nil))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (cond ((debugger:frame-retryable-p frame) + (apply #'debugger:frame-retry frame (debugger:frame-function frame) + (cdr (debugger:frame-expression frame)))) + (t "Frame is not retryable")))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +(defun compiler-note-p (object) + (member (type-of object) '(excl::compiler-note compiler::compiler-note))) + +(defun redefinition-p (condition) + (and (typep condition 'style-warning) + (every #'char-equal "redefin" (princ-to-string condition)))) + +(defun compiler-undefined-functions-called-warning-p (object) + (typep object 'excl:compiler-undefined-functions-called-warning)) + +(deftype compiler-note () + `(satisfies compiler-note-p)) + +(deftype redefinition () + `(satisfies redefinition-p)) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +(defun handle-compiler-warning (condition) + (declare (optimize (debug 3) (speed 0) (space 0))) + (cond ((and #-(version>= 10 0) (not *buffer-name*) + (compiler-undefined-functions-called-warning-p condition)) + (handle-undefined-functions-warning condition)) + ((and (typep condition 'excl::compiler-note) + (let ((format (slot-value condition 'excl::format-control))) + (and (search "Closure" format) + (search "will be stack allocated" format)))) + ;; Ignore "Closure will be stack allocated" notes. + ;; That occurs often but is usually uninteresting. + ) + (t + (signal-compiler-condition + :original-condition condition + :severity (etypecase condition + (redefinition :redefinition) + (style-warning :style-warning) + (warning :warning) + (compiler-note :note) + (reader-error :read-error) + (error :error)) + :message (format nil "~A" condition) + :location (compiler-warning-location condition))))) + +(defun condition-pathname-and-position (condition) + (let* ((context #+(version>= 10 0) + (getf (slot-value condition 'excl::plist) + :source-context)) + (location-available (and context + (excl::source-context-start-char context)))) + (cond (location-available + (values (excl::source-context-pathname context) + (when-let (start-char (excl::source-context-start-char context)) + (let ((position (if (listp start-char) ; HACK + (first start-char) + start-char))) + (if (typep condition 'excl::compiler-free-reference-warning) + position + (1+ position)))))) + ((typep condition 'reader-error) + (let ((pos (car (last (slot-value condition 'excl::format-arguments)))) + (file (pathname (stream-error-stream condition)))) + (when (integerp pos) + (values file pos)))) + (t + (let ((loc (getf (slot-value condition 'excl::plist) :loc))) + (when loc + (destructuring-bind (file . pos) loc + (let ((start (if (consp pos) ; 8.2 and newer + #+(version>= 10 1) + (if (typep condition 'excl::compiler-inconsistent-name-usage-warning) + (second pos) + (first pos)) + #-(version>= 10 1) + (first pos) + pos))) + (values file start))))))))) + +(defun compiler-warning-location (condition) + (multiple-value-bind (pathname position) + (condition-pathname-and-position condition) + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (if position + (list :offset 1 (1- position)) + (list :offset *buffer-start-position* 0)))) + (pathname + (make-location + (list :file (namestring (truename pathname))) + #+(version>= 10 1) + (list :offset 1 position) + #-(version>= 10 1) + (list :position (1+ position)))) + (t + (make-error-location "No error location available."))))) + +;; TODO: report it as a bug to Franz that the condition's plist +;; slot contains (:loc nil). +(defun handle-undefined-functions-warning (condition) + (let ((fargs (slot-value condition 'excl::format-arguments))) + (loop for (fname . locs) in (car fargs) do + (dolist (loc locs) + (multiple-value-bind (pos file) (ecase (length loc) + (2 (values-list loc)) + (3 (destructuring-bind + (start end file) loc + (declare (ignore end)) + (values start file)))) + (signal-compiler-condition + :original-condition condition + :severity :warning + :message (format nil "Undefined function referenced: ~S" + fname) + :location (make-location (list :file file) + #+(version>= 9 0) + (list :offset 1 pos) + #-(version>= 9 0) + (list :position (1+ pos))))))))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-compiler-warning) + (compiler-note #'handle-compiler-warning) + (reader-error #'handle-compiler-warning)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (handler-case + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file) + #+(version>= 8 2) + (compiler:save-source-level-debug-info-switch t) + (excl:*load-source-file-info* t) + #+(version>= 8 2) + (excl:*load-source-debug-info* t)) + (compile-file *compile-filename* + :output-file output-file + :load-after-compile load-p + :external-format external-format))) + (reader-error () (values nil nil t)))) + +(defun call-with-temp-file (fn) + (let ((tmpname (system:make-temp-file-name))) + (unwind-protect + (with-open-file (file tmpname :direction :output :if-exists :error) + (funcall fn file tmpname)) + (delete-file tmpname)))) + +(defvar *temp-file-map* (make-hash-table :test #'equal) + "A mapping from tempfile names to Emacs buffer names.") + +(defun write-tracking-preamble (stream file file-offset) + "Instrument the top of the temporary file to be compiled. + +The header tells allegro that any definitions compiled in the temp +file should be found in FILE exactly at FILE-OFFSET. To get Allegro +to do this, this factors in the length of the inserted header itself." + (with-standard-io-syntax + (let* ((*package* (find-package :keyword)) + (source-pathname-form + `(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setq excl::*source-pathname* + (pathname ,(sys::frob-source-file file))))) + (source-pathname-string (write-to-string source-pathname-form)) + (position-form-length-bound 160) ; should be enough for everyone + (header-length (+ (length source-pathname-string) + position-form-length-bound)) + (position-form + `(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setq excl::*partial-source-file-p* ,(- file-offset + header-length + 1 ; for the newline + )))) + (position-form-string (write-to-string position-form)) + (padding-string (make-string (- position-form-length-bound + (length position-form-string)) + :initial-element #\;))) + (write-string source-pathname-string stream) + (write-string position-form-string stream) + (write-string padding-string stream) + (write-char #\newline stream)))) + +(defun compile-from-temp-file (string buffer offset file) + (call-with-temp-file + (lambda (stream filename) + (when (and file offset (probe-file file)) + (write-tracking-preamble stream file offset)) + (write-string string stream) + (finish-output stream) + (multiple-value-bind (binary-filename warnings? failure?) + (let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension + #+(version>= 8 2) + (compiler:save-source-level-debug-info-switch t) + (excl:*redefinition-warnings* nil)) + (compile-file filename)) + (declare (ignore warnings?)) + (when binary-filename + (let ((excl:*load-source-file-info* t) + #+(version>= 8 2) + (excl:*load-source-debug-info* t)) + excl::*source-pathname* + (load binary-filename)) + (when (and buffer offset (or (not file) + (not (probe-file file)))) + (setf (gethash (pathname stream) *temp-file-map*) + (list buffer offset))) + (delete-file binary-filename)) + (not failure?))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore policy)) + (handler-case + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (compile-from-temp-file string buffer position filename))) + (reader-error () nil))) + +;;;; Definition Finding + +(defun buffer-or-file (file file-fun buffer-fun) + (let* ((probe (gethash file *temp-file-map*))) + (cond (probe + (destructuring-bind (buffer start) probe + (funcall buffer-fun buffer start))) + (t (funcall file-fun (namestring (truename file))))))) + +(defun buffer-or-file-location (file offset) + (buffer-or-file file + (lambda (filename) + (make-location `(:file ,filename) + `(:position ,(1+ offset)))) + (lambda (buffer start) + (make-location `(:buffer ,buffer) + `(:offset ,start ,offset))))) + +(defun fspec-primary-name (fspec) + (etypecase fspec + (symbol fspec) + (list (fspec-primary-name (second fspec))))) + +(defun find-definition-in-file (fspec type file top-level) + (let* ((part + (or (scm::find-definition-in-definition-group + fspec type (scm:section-file :file file) + :top-level top-level) + (scm::find-definition-in-definition-group + (fspec-primary-name fspec) + type (scm:section-file :file file) + :top-level top-level))) + (start (and part + (scm::source-part-start part))) + (pos (if start + (list :offset 1 start) + (list :function-name (string (fspec-primary-name fspec)))))) + (make-location (list :file (namestring (truename file))) + pos))) + +(defun find-fspec-location (fspec type file top-level) + (handler-case + (etypecase file + (pathname + (let ((probe (gethash file *temp-file-map*))) + (cond (probe + (destructuring-bind (buffer offset) probe + (make-location `(:buffer ,buffer) + `(:offset ,offset 0)))) + (t + (find-definition-in-file fspec type file top-level))))) + ((member :top-level) + (make-error-location "Defined at toplevel: ~A" + (fspec->string fspec)))) + (error (e) + (make-error-location "Error: ~A" e)))) + +(defun fspec->string (fspec) + (typecase fspec + (symbol (let ((*package* (find-package :keyword))) + (prin1-to-string fspec))) + (list (format nil "(~A ~A)" + (prin1-to-string (first fspec)) + (let ((*package* (find-package :keyword))) + (prin1-to-string (second fspec))))) + (t (princ-to-string fspec)))) + +(defun fspec-definition-locations (fspec) + (cond + ((and (listp fspec) (eq (car fspec) :internal)) + (destructuring-bind (_internal next _n) fspec + (declare (ignore _internal _n)) + (fspec-definition-locations next))) + (t + (let ((defs (excl::find-source-file fspec))) + (when (and (null defs) + (listp fspec) + (string= (car fspec) '#:method)) + ;; If methods are defined in a defgeneric form, the source location is + ;; recorded for the gf but not for the methods. Therefore fall back to + ;; the gf as the likely place of definition. + (setq defs (excl::find-source-file (second fspec)))) + (if (null defs) + (list + (list fspec + (make-error-location "Unknown source location for ~A" + (fspec->string fspec)))) + (loop for (fspec type file top-level) in defs collect + (list (list type fspec) + (find-fspec-location fspec type file top-level)))))))) + +(defimplementation find-definitions (symbol) + (fspec-definition-locations symbol)) + +(defimplementation find-source-location (obj) + (first (rest (first (fspec-definition-locations obj))))) + +;;;; XREF + +(defmacro defxref (name relation name1 name2) + `(defimplementation ,name (x) + (xref-result (xref:get-relation ,relation ,name1 ,name2)))) + +(defxref who-calls :calls :wild x) +(defxref calls-who :calls x :wild) +(defxref who-references :uses :wild x) +(defxref who-binds :binds :wild x) +(defxref who-macroexpands :macro-calls :wild x) +(defxref who-sets :sets :wild x) + +(defun xref-result (fspecs) + (loop for fspec in fspecs + append (fspec-definition-locations fspec))) + +;; list-callers implemented by groveling through all fbound symbols. +;; Only symbols are considered. Functions in the constant pool are +;; searched recursively. Closure environments are ignored at the +;; moment (constants in methods are therefore not found). + +(defun map-function-constants (function fn depth) + "Call FN with the elements of FUNCTION's constant pool." + (do ((i 0 (1+ i)) + (max (excl::function-constant-count function))) + ((= i max)) + (let ((c (excl::function-constant function i))) + (cond ((and (functionp c) + (not (eq c function)) + (plusp depth)) + (map-function-constants c fn (1- depth))) + (t + (funcall fn c)))))) + +(defun in-constants-p (fun symbol) + (map-function-constants fun + (lambda (c) + (when (eq c symbol) + (return-from in-constants-p t))) + 3)) + +(defun function-callers (name) + (let ((callers '())) + (do-all-symbols (sym) + (when (fboundp sym) + (let ((fn (fdefinition sym))) + (when (in-constants-p fn name) + (push sym callers))))) + callers)) + +(defimplementation list-callers (name) + (xref-result (function-callers name))) + +(defimplementation list-callees (name) + (let ((result '())) + (map-function-constants (fdefinition name) + (lambda (c) + (when (fboundp c) + (push c result))) + 2) + (xref-result result))) + +;;;; Profiling + +;; Per-function profiling based on description in +;; http://www.franz.com/support/documentation/8.0/\ +;; doc/runtime-analyzer.htm#data-collection-control-2 + +(defvar *profiled-functions* ()) +(defvar *profile-depth* 0) + +(defmacro with-redirected-y-or-n-p (&body body) + ;; If the profiler is restarted when the data from the previous + ;; session is not reported yet, the user is warned via Y-OR-N-P. + ;; As the CL:Y-OR-N-P question is (for some reason) not directly + ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily + ;; overruled. + `(let* ((pkg (find-package :common-lisp)) + (saved-pdl (excl::package-definition-lock pkg)) + (saved-ynp (symbol-function 'cl:y-or-n-p))) + (setf (excl::package-definition-lock pkg) nil + (symbol-function 'cl:y-or-n-p) + (symbol-function (read-from-string "swank:y-or-n-p-in-emacs"))) + (unwind-protect + (progn ,@body) + (setf (symbol-function 'cl:y-or-n-p) saved-ynp + (excl::package-definition-lock pkg) saved-pdl)))) + +(defun start-acl-profiler () + (with-redirected-y-or-n-p + (prof:start-profiler :type :time :count t + :start-sampling-p nil :verbose nil))) +(defun acl-profiler-active-p () + (not (eq (prof:profiler-status :verbose nil) :inactive))) + +(defun stop-acl-profiler () + (prof:stop-profiler :verbose nil)) + +(excl:def-fwrapper profile-fwrapper (&rest args) + ;; Ensures sampling is done during the execution of the function, + ;; taking into account recursion. + (declare (ignore args)) + (cond ((zerop *profile-depth*) + (let ((*profile-depth* (1+ *profile-depth*))) + (prof:start-sampling) + (unwind-protect (excl:call-next-fwrapper) + (prof:stop-sampling)))) + (t + (excl:call-next-fwrapper)))) + +(defimplementation profile (fname) + (unless (acl-profiler-active-p) + (start-acl-profiler)) + (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper) + (push fname *profiled-functions*)) + +(defimplementation profiled-functions () + *profiled-functions*) + +(defimplementation unprofile (fname) + (excl:funwrap fname 'profile-fwrapper) + (setq *profiled-functions* (remove fname *profiled-functions*))) + +(defimplementation profile-report () + (prof:show-flat-profile :verbose nil) + (when *profiled-functions* + (start-acl-profiler))) + +(defimplementation profile-reset () + (when (acl-profiler-active-p) + (stop-acl-profiler) + (start-acl-profiler)) + "Reset profiling counters.") + +;;;; Inspecting + +(excl:without-redefinition-warnings +(defmethod emacs-inspect ((o t)) + (allegro-inspect o))) + +(defmethod emacs-inspect ((o function)) + (allegro-inspect o)) + +(defmethod emacs-inspect ((o standard-object)) + (allegro-inspect o)) + +(defun allegro-inspect (o) + (loop for (d dd) on (inspect::inspect-ctl o) + append (frob-allegro-field-def o d) + until (eq d dd))) + +(defun frob-allegro-field-def (object def) + (with-struct (inspect::field-def- name type access) def + (ecase type + ((:unsigned-word :unsigned-byte :unsigned-natural + :unsigned-long :unsigned-half-long + :unsigned-3byte :unsigned-long32) + (label-value-line name (inspect::component-ref-v object access type))) + ((:lisp :value :func) + (label-value-line name (inspect::component-ref object access))) + (:indirect + (destructuring-bind (prefix count ref set) access + (declare (ignore set prefix)) + (loop for i below (funcall count object) + append (label-value-line (format nil "~A-~D" name i) + (funcall ref object i)))))))) + +;;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (mp:start-scheduler) + (funcall continuation)) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + +(defvar *id-lock* (mp:make-process-lock :name "id lock")) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-process-lock (*id-lock*) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id mp:*all-processes* + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (princ-to-string (mp:process-whostate thread))) + +(defimplementation thread-attributes (thread) + (list :priority (mp:process-priority thread) + :times-resumed (mp:process-times-resumed thread))) + +(defimplementation make-lock (&key name) + (mp:make-process-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-process-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (copy-list mp:*all-processes*)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock")) + +(defstruct (mailbox (:conc-name mailbox.)) + (lock (mp:make-process-lock :name "process mailbox")) + (queue '() :type list) + (gate (mp:make-gate nil))) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-process-lock (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread))) + (mp:with-process-lock ((mailbox.lock mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:open-gate (mailbox.gate mbox))))) + +(defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox mp:*current-process*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-process-lock ((mailbox.lock mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))) + (mp:close-gate (mailbox.gate mbox)))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout "receive-if" 0.5 + #'mp:gate-open-p (mailbox.gate mbox))))) + +(let ((alist '()) + (lock (mp:make-process-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-process-lock (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-process-lock (lock) + (cdr (assoc name alist))))) + +(defimplementation set-default-initial-binding (var form) + (push (cons var form) + #+(version>= 9 0) + excl:*required-thread-bindings* + #-(version>= 9 0) + excl::required-thread-bindings)) + +(defimplementation quit-lisp () + (excl:exit 0 :quiet t)) + + +;;Trace implementations +;;In Allegro 7.0, we have: +;; (trace ) +;; (trace ((method ? (+)))) +;; (trace ((labels ))) +;; (trace ((labels (method (+)) ))) +;; can be a normal name or a (setf name) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + (:defgeneric (toggle-trace-generic-function-methods (second spec))) + ((setf :defmethod :labels :flet) + (toggle-trace-aux (process-fspec-for-allegro spec))) + (:call + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee + :inside (list (process-fspec-for-allegro caller))))))) + +(defun tracedp (fspec) + (member fspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((tracedp fspec) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace (,fspec ,@args))) + (format nil "~S is now traced." fspec)))) + +(defun toggle-trace-generic-function-methods (name) + (let ((methods (mop:generic-function-methods (fdefinition name)))) + (cond ((tracedp name) + (eval `(untrace ,name)) + (dolist (method methods (format nil "~S is now untraced." name)) + (excl:funtrace (mop:method-function method)))) + (t + (eval `(trace (,name))) + (dolist (method methods (format nil "~S is now traced." name)) + (excl:ftrace (mop:method-function method))))))) + +(defun process-fspec-for-allegro (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((setf) fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))) + ((:flet) `(flet ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))))) + (t + fspec))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-keys t args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :values :weak args)) + +(defimplementation hash-table-weakness (hashtable) + (cond ((excl:hash-table-weak-keys hashtable) :key) + ((eq (excl:hash-table-values hashtable) :weak) :value))) + + + +;;;; Character names + +(defimplementation character-completion-set (prefix matchp) + (loop for name being the hash-keys of excl::*name-to-char-table* + when (funcall matchp prefix name) + collect (string-capitalize name))) + + +;;;; wrap interface implementation + +(defimplementation wrap (spec indicator &key before after replace) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:fwrap allegro-spec + indicator + (excl:def-fwrapper allegro-wrapper (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (if replace + (funcall replace args) + (excl:call-next-fwrapper)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally))))))) + allegro-spec)) + +(defimplementation unwrap (spec indicator) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:funwrap allegro-spec indicator) + allegro-spec)) + +(defimplementation wrapped-p (spec indicator) + (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/backend.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/backend.lisp new file mode 100644 index 0000000..eca348e --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/backend.lisp @@ -0,0 +1,1579 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- +;;; +;;; slime-backend.lisp --- SLIME backend interface. +;;; +;;; Created by James Bielman in 2003. Released into the public domain. +;;; +;;;; Frontmatter +;;; +;;; This file defines the functions that must be implemented +;;; separately for each Lisp. Each is declared as a generic function +;;; for which swank-.lisp provides methods. + +(in-package swank/backend) + + +;;;; Metacode + +(defparameter *debug-swank-backend* nil + "If this is true, backends should not catch errors but enter the +debugger where appropriate. Also, they should not perform backtrace +magic but really show every frame including SWANK related ones.") + +(defparameter *interface-functions* '() + "The names of all interface functions.") + +(defparameter *unimplemented-interfaces* '() + "List of interface functions that are not implemented. +DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.") + +(defvar *log-output* nil) ; should be nil for image dumpers + +(defmacro definterface (name args documentation &rest default-body) + "Define an interface function for the backend to implement. +A function is defined with NAME, ARGS, and DOCUMENTATION. This +function first looks for a function to call in NAME's property list +that is indicated by 'IMPLEMENTATION; failing that, it looks for a +function indicated by 'DEFAULT. If neither is present, an error is +signaled. + +If a DEFAULT-BODY is supplied, then a function with the same body and +ARGS will be added to NAME's property list as the property indicated +by 'DEFAULT. + +Backends implement these functions using DEFIMPLEMENTATION." + (check-type documentation string "a documentation string") + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + (labels ((gen-default-impl () + `(setf (get ',name 'default) (lambda ,args ,@default-body))) + (args-as-list (args) + (destructuring-bind (req opt key rest) (parse-lambda-list args) + `(,@req ,@opt + ,@(loop for k in key append `(,(kw k) ,k)) + ,@(or rest '(()))))) + (parse-lambda-list (args) + (parse args '(&optional &key &rest) + (make-array 4 :initial-element nil))) + (parse (args keywords vars) + (cond ((null args) + (reverse (map 'list #'reverse vars))) + ((member (car args) keywords) + (parse (cdr args) (cdr (member (car args) keywords)) vars)) + (t (push (car args) (aref vars (length keywords))) + (parse (cdr args) keywords vars)))) + (kw (s) (intern (string s) :keyword))) + `(progn + (defun ,name ,args + ,documentation + (let ((f (or (get ',name 'implementation) + (get ',name 'default)))) + (cond (f (apply f ,@(args-as-list args))) + (t (error "~S not implemented" ',name))))) + (pushnew ',name *interface-functions*) + ,(if (null default-body) + `(pushnew ',name *unimplemented-interfaces*) + (gen-default-impl)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name :swank/backend)) + ',name))) + +(defmacro defimplementation (name args &body body) + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + `(progn + (setf (get ',name 'implementation) + ;; For implicit BLOCK. FLET because of interplay w/ decls. + (flet ((,name ,args ,@body)) #',name)) + (if (member ',name *interface-functions*) + (setq *unimplemented-interfaces* + (remove ',name *unimplemented-interfaces*)) + (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name)) + ',name)) + +(defun warn-unimplemented-interfaces () + "Warn the user about unimplemented backend features. +The portable code calls this function at startup." + (let ((*print-pretty* t)) + (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>" + (list (sort (copy-list *unimplemented-interfaces*) #'string<))))) + +(defun import-to-swank-mop (symbol-list) + (dolist (sym symbol-list) + (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop))) + (when swank-mop-sym + (unintern swank-mop-sym :swank-mop)) + (import sym :swank-mop) + (export sym :swank-mop)))) + +(defun import-swank-mop-symbols (package except) + "Import the mop symbols from PACKAGE to SWANK-MOP. +EXCEPT is a list of symbol names which should be ignored." + (do-symbols (s :swank-mop) + (unless (member s except :test #'string=) + (let ((real-symbol (find-symbol (string s) package))) + (assert real-symbol () "Symbol ~A not found in package ~A" s package) + (unintern s :swank-mop) + (import real-symbol :swank-mop) + (export real-symbol :swank-mop))))) + +(definterface gray-package-name () + "Return a package-name that contains the Gray stream symbols. +This will be used like so: + (defpackage foo + (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)") + + +;;;; Utilities + +(defmacro with-struct ((conc-name &rest names) obj &body body) + "Like with-slots but works only for structs." + (check-type conc-name symbol) + (flet ((reader (slot) + (intern (concatenate 'string + (symbol-name conc-name) + (symbol-name slot)) + (symbol-package conc-name)))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + +(defmacro when-let ((var value) &body body) + `(let ((,var ,value)) + (when ,var ,@body))) + +(defun boolean-to-feature-expression (value) + "Converts a boolean VALUE to a form suitable for testing with #+." + (if value + '(:and) + '(:or))) + +(defun with-symbol (name package) + "Check if a symbol with a given NAME exists in PACKAGE and returns a +form suitable for testing with #+." + (boolean-to-feature-expression + (and (find-package package) + (find-symbol (string name) package)))) + +(defun choose-symbol (package name alt-package alt-name) + "If symbol package:name exists return that symbol, otherwise alt-package:alt-name. + Suitable for use with #." + (or (and (find-package package) + (find-symbol (string name) package)) + (find-symbol (string alt-name) alt-package))) + + +;;;; UFT8 + +(deftype octet () '(unsigned-byte 8)) +(deftype octets () '(simple-array octet (*))) + +;; Helper function. Decode the next N bytes starting from INDEX. +;; Return the decoded char and the new index. +(defun utf8-decode-aux (buffer index limit byte0 n) + (declare (type octets buffer) (fixnum index limit byte0 n)) + (if (< (- limit index) n) + (values nil index) + (do ((i 0 (1+ i)) + (code byte0 (let ((byte (aref buffer (+ index i)))) + (cond ((= (ldb (byte 2 6) byte) #b10) + (+ (ash code 6) (ldb (byte 6 0) byte))) + (t + (error "Invalid encoding")))))) + ((= i n) + (values (cond ((<= code #xff) (code-char code)) + ((<= #xd800 code #xdfff) + (error "Invalid Unicode code point: #x~x" code)) + ((and (< code char-code-limit) + (code-char code))) + (t + (error + "Can't represent code point: #x~x ~ + (char-code-limit is #x~x)" + code char-code-limit))) + (+ index n)))))) + +;; Decode one character in BUFFER starting at INDEX. +;; Return 2 values: the character and the new index. +;; If there aren't enough bytes between INDEX and LIMIT return nil. +(defun utf8-decode (buffer index limit) + (declare (type octets buffer) (fixnum index limit)) + (if (= index limit) + (values nil index) + (let ((b (aref buffer index))) + (if (<= b #x7f) + (values (code-char b) (1+ index)) + (macrolet ((try (marker else) + (let* ((l (integer-length marker)) + (n (- l 2))) + `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker) + (utf8-decode-aux buffer (1+ index) limit + (ldb (byte ,(- 8 l) 0) b) + ,n) + ,else)))) + (try #b110 + (try #b1110 + (try #b11110 + (try #b111110 + (try #b1111110 + (error "Invalid encoding"))))))))))) + +;; Decode characters from BUFFER and write them to STRING. +;; Return 2 values: LASTINDEX and LASTSTART where +;; LASTINDEX is the last index in BUFFER that was not decoded +;; and LASTSTART is the last index in STRING not written. +(defun utf8-decode-into (buffer index limit string start end) + (declare (string string) (fixnum index limit start end) (type octets buffer)) + (loop + (cond ((= start end) + (return (values index start))) + (t + (multiple-value-bind (c i) (utf8-decode buffer index limit) + (cond (c + (setf (aref string start) c) + (setq index i) + (setq start (1+ start))) + (t + (return (values index start))))))))) + +(defun default-utf8-to-string (octets) + (let* ((limit (length octets)) + (str (make-string limit))) + (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit) + (if (= i limit) + (if (= limit s) + str + (adjust-array str s)) + (loop + (let ((end (+ (length str) (- limit i)))) + (setq str (adjust-array str end)) + (multiple-value-bind (i2 s2) + (utf8-decode-into octets i limit str s end) + (cond ((= i2 limit) + (return (adjust-array str s2))) + (t + (setq i i2) + (setq s s2)))))))))) + +(defmacro utf8-encode-aux (code buffer start end n) + `(cond ((< (- ,end ,start) ,n) + ,start) + (t + (setf (aref ,buffer ,start) + (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code) + (byte ,(- 7 n) 0) + ,(dpb 0 (byte 1 (- 7 n)) #xff))) + ,@(loop for i from 0 upto (- n 2) collect + `(setf (aref ,buffer (+ ,start ,(- n 1 i))) + (dpb (ldb (byte 6 ,(* 6 i)) ,code) + (byte 6 0) + #b10111111))) + (+ ,start ,n)))) + +(defun %utf8-encode (code buffer start end) + (declare (type (unsigned-byte 31) code) (type octets buffer) + (type (and fixnum unsigned-byte) start end)) + (cond ((<= code #x7f) + (cond ((< start end) + (setf (aref buffer start) code) + (1+ start)) + (t start))) + ((<= code #x7ff) (utf8-encode-aux code buffer start end 2)) + ((<= #xd800 code #xdfff) + (error "Invalid Unicode code point (surrogate): #x~x" code)) + ((<= code #xffff) (utf8-encode-aux code buffer start end 3)) + ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4)) + ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5)) + (t (utf8-encode-aux code buffer start end 6)))) + +(defun utf8-encode (char buffer start end) + (declare (type character char) (type octets buffer) + (type (and fixnum unsigned-byte) start end)) + (%utf8-encode (char-code char) buffer start end)) + +(defun utf8-encode-into (string start end buffer index limit) + (declare (string string) (type octets buffer) (fixnum start end index limit)) + (loop + (cond ((= start end) + (return (values start index))) + ((= index limit) + (return (values start index))) + (t + (let ((i2 (utf8-encode (char string start) buffer index limit))) + (cond ((= i2 index) + (return (values start index))) + (t + (setq index i2) + (incf start)))))))) + +(defun default-string-to-utf8 (string) + (let* ((len (length string)) + (b (make-array len :element-type 'octet))) + (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len) + (if (= s len) + b + (loop + (let ((limit (+ (length b) (- len s)))) + (setq b (coerce (adjust-array b limit) 'octets)) + (multiple-value-bind (s2 i2) + (utf8-encode-into string s len b i limit) + (cond ((= s2 len) + (return (coerce (adjust-array b i2) 'octets))) + (t + (setq i i2) + (setq s s2)))))))))) + +(definterface string-to-utf8 (string) + "Convert the string STRING to a (simple-array (unsigned-byte 8))" + (default-string-to-utf8 string)) + +(definterface utf8-to-string (octets) + "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string." + (default-utf8-to-string octets)) + + +;;;; TCP server + +(definterface create-socket (host port &key backlog) + "Create a listening TCP socket on interface HOST and port PORT. +BACKLOG queue length for incoming connections.") + +(definterface local-port (socket) + "Return the local port number of SOCKET.") + +(definterface close-socket (socket) + "Close the socket SOCKET.") + +(definterface accept-connection (socket &key external-format + buffering timeout) + "Accept a client connection on the listening socket SOCKET. +Return a stream for the new connection. +If EXTERNAL-FORMAT is nil return a binary stream +otherwise create a character stream. +BUFFERING can be one of: + nil ... no buffering + t ... enable buffering + :line ... enable buffering with automatic flushing on eol.") + +(definterface add-sigio-handler (socket fn) + "Call FN whenever SOCKET is readable.") + +(definterface remove-sigio-handlers (socket) + "Remove all sigio handlers for SOCKET.") + +(definterface add-fd-handler (socket fn) + "Call FN when Lisp is waiting for input and SOCKET is readable.") + +(definterface remove-fd-handlers (socket) + "Remove all fd-handlers for SOCKET.") + +(definterface preferred-communication-style () + "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL." + nil) + +(definterface set-stream-timeout (stream timeout) + "Set the 'stream 'timeout. The timeout is either the real number + specifying the timeout in seconds or 'nil for no timeout." + (declare (ignore stream timeout)) + nil) + +;;; Base condition for networking errors. +(define-condition network-error (simple-error) ()) + +(definterface emacs-connected () + "Hook called when the first connection from Emacs is established. +Called from the INIT-FN of the socket server that accepts the +connection. + +This is intended for setting up extra context, e.g. to discover +that the calling thread is the one that interacts with Emacs." + nil) + + +;;;; Unix signals + +(defconstant +sigint+ 2) + +(definterface getpid () + "Return the (Unix) process ID of this superior Lisp.") + +(definterface install-sigint-handler (function) + "Call FUNCTION on SIGINT (instead of invoking the debugger). +Return old signal handler." + (declare (ignore function)) + nil) + +(definterface call-with-user-break-handler (handler function) + "Install the break handler HANDLER while executing FUNCTION." + (let ((old-handler (install-sigint-handler handler))) + (unwind-protect (funcall function) + (install-sigint-handler old-handler)))) + +(definterface quit-lisp () + "Exit the current lisp image.") + +(definterface lisp-implementation-type-name () + "Return a short name for the Lisp implementation." + (lisp-implementation-type)) + +(definterface lisp-implementation-program () + "Return the argv[0] of the running Lisp process, or NIL." + (let ((file (car (command-line-args)))) + (when (and file (probe-file file)) + (namestring (truename file))))) + +(definterface socket-fd (socket-stream) + "Return the file descriptor for SOCKET-STREAM.") + +(definterface make-fd-stream (fd external-format) + "Create a character stream for the file descriptor FD.") + +(definterface dup (fd) + "Duplicate a file descriptor. +If the syscall fails, signal a condition. +See dup(2).") + +(definterface exec-image (image-file args) + "Replace the current process with a new process image. +The new image is created by loading the previously dumped +core file IMAGE-FILE. +ARGS is a list of strings passed as arguments to +the new image. +This is thin wrapper around exec(3).") + +(definterface command-line-args () + "Return a list of strings as passed by the OS." + nil) + + +;; pathnames are sooo useless + +(definterface filename-to-pathname (filename) + "Return a pathname for FILENAME. +A filename in Emacs may for example contain asterisks which should not +be translated to wildcards." + (parse-namestring filename)) + +(definterface pathname-to-filename (pathname) + "Return the filename for PATHNAME." + (namestring pathname)) + +(definterface default-directory () + "Return the default directory." + (directory-namestring (truename *default-pathname-defaults*))) + +(definterface set-default-directory (directory) + "Set the default directory. +This is used to resolve filenames without directory component." + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (default-directory)) + + +(definterface call-with-syntax-hooks (fn) + "Call FN with hooks to handle special syntax." + (funcall fn)) + +(definterface default-readtable-alist () + "Return a suitable initial value for SWANK:*READTABLE-ALIST*." + '()) + + +;;;; Packages + +(definterface package-local-nicknames (package) + "Returns an alist of (local-nickname . actual-package) describing the +nicknames local to the designated package." + (declare (ignore package)) + nil) + +(definterface find-locally-nicknamed-package (name base-package) + "Return the package whose local nickname in BASE-PACKAGE matches NAME. +Return NIL if local nicknames are not implemented or if there is no +such package." + (cdr (assoc name (package-local-nicknames base-package) :test #'string-equal))) + + +;;;; Compilation + +(definterface call-with-compilation-hooks (func) + "Call FUNC with hooks to record compiler conditions.") + +(defmacro with-compilation-hooks ((&rest ignore) &body body) + "Execute BODY as in CALL-WITH-COMPILATION-HOOKS." + (declare (ignore ignore)) + `(call-with-compilation-hooks (lambda () (progn ,@body)))) + +(definterface swank-compile-string (string &key buffer position filename + policy) + "Compile source from STRING. +During compilation, compiler conditions must be trapped and +resignalled as COMPILER-CONDITIONs. + +If supplied, BUFFER and POSITION specify the source location in Emacs. + +Additionally, if POSITION is supplied, it must be added to source +positions reported in compiler conditions. + +If FILENAME is specified it may be used by certain implementations to +rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of +source information. + +If POLICY is supplied, and non-NIL, it may be used by certain +implementations to compile with optimization qualities of its +value. + +Should return T on successful compilation, NIL otherwise. +") + +(definterface swank-compile-file (input-file output-file load-p + external-format + &key policy) + "Compile INPUT-FILE signalling COMPILE-CONDITIONs. +If LOAD-P is true, load the file after compilation. +EXTERNAL-FORMAT is a value returned by find-external-format or +:default. + +If POLICY is supplied, and non-NIL, it may be used by certain +implementations to compile with optimization qualities of its +value. + +Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p +like `compile-file'") + +(deftype severity () + '(member :error :read-error :warning :style-warning :note :redefinition)) + +;; Base condition type for compiler errors, warnings and notes. +(define-condition compiler-condition (condition) + ((original-condition + ;; The original condition thrown by the compiler if appropriate. + ;; May be NIL if a compiler does not report using conditions. + :type (or null condition) + :initarg :original-condition + :accessor original-condition) + + (severity :type severity + :initarg :severity + :accessor severity) + + (message :initarg :message + :accessor message) + + ;; Macro expansion history etc. which may be helpful in some cases + ;; but is often very verbose. + (source-context :initarg :source-context + :type (or null string) + :initform nil + :accessor source-context) + + (references :initarg :references + :initform nil + :accessor references) + + (location :initarg :location + :accessor location))) + +(definterface find-external-format (coding-system) + "Return a \"external file format designator\" for CODING-SYSTEM. +CODING-SYSTEM is Emacs-style coding system name (a string), +e.g. \"latin-1-unix\"." + (if (equal coding-system "iso-latin-1-unix") + :default + nil)) + +(definterface guess-external-format (pathname) + "Detect the external format for the file with name pathname. +Return nil if the file contains no special markers." + ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section. + (with-open-file (s pathname :if-does-not-exist nil + :external-format (or (find-external-format "latin-1-unix") + :default)) + (if s + (or (let* ((line (read-line s nil)) + (p (search "-*-" line))) + (when p + (let* ((start (+ p (length "-*-"))) + (end (search "-*-" line :start2 start))) + (when end + (%search-coding line start end))))) + (let* ((len (file-length s)) + (buf (make-string (min len 3000)))) + (file-position s (- len (length buf))) + (read-sequence buf s) + (let ((start (search "Local Variables:" buf :from-end t)) + (end (search "End:" buf :from-end t))) + (and start end (< start end) + (%search-coding buf start end)))))))) + +(defun %search-coding (str start end) + (let ((p (search "coding:" str :start2 start :end2 end))) + (when p + (incf p (length "coding:")) + (loop while (and (< p end) + (member (aref str p) '(#\space #\tab))) + do (incf p)) + (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline #\;))) + str :start p))) + (find-external-format (subseq str p end)))))) + + +;;;; Streams + +(definterface make-output-stream (write-string) + "Return a new character output stream. +The stream calls WRITE-STRING when output is ready.") + +(definterface make-input-stream (read-string) + "Return a new character input stream. +The stream calls READ-STRING when input is needed.") + +(defvar *auto-flush-interval* 0.2) + +(defun auto-flush-loop (stream interval &optional receive) + (loop + (when (not (and (open-stream-p stream) + (output-stream-p stream))) + (return nil)) + (force-output stream) + (when receive + (receive-if #'identity)) + (sleep interval))) + +(definterface make-auto-flush-thread (stream) + "Make an auto-flush thread" + (spawn (lambda () (auto-flush-loop stream *auto-flush-interval* nil)) + :name "auto-flush-thread")) + + +;;;; Documentation + +(definterface arglist (name) + "Return the lambda list for the symbol NAME. NAME can also be +a lisp function object, on lisps which support this. + +The result can be a list or the :not-available keyword if the +arglist cannot be determined." + (declare (ignore name)) + :not-available) + +(defgeneric declaration-arglist (decl-identifier) + (:documentation + "Return the argument list of the declaration specifier belonging to the +declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined, +the keyword :NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (decl-identifier) + (case decl-identifier + (dynamic-extent '(&rest variables)) + (ignore '(&rest variables)) + (ignorable '(&rest variables)) + (special '(&rest variables)) + (inline '(&rest function-names)) + (notinline '(&rest function-names)) + (declaration '(&rest names)) + (optimize '(&any compilation-speed debug safety space speed)) + (type '(type-specifier &rest args)) + (ftype '(type-specifier &rest function-names)) + (otherwise + (flet ((typespec-p (symbol) + (member :type (describe-symbol-for-emacs symbol)))) + (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) + '(&rest variables)) + ((and (listp decl-identifier) + (typespec-p (first decl-identifier))) + '(&rest variables)) + (t :not-available))))))) + +(defgeneric type-specifier-arglist (typespec-operator) + (:documentation + "Return the argument list of the type specifier belonging to +TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword +:NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (typespec-operator) + (declare (special *type-specifier-arglists*)) ; defined at end of file. + (typecase typespec-operator + (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*)) + :not-available)) + (t :not-available)))) + +(definterface type-specifier-p (symbol) + "Determine if SYMBOL is a type-specifier." + (or (documentation symbol 'type) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(definterface function-name (function) + "Return the name of the function object FUNCTION. + +The result is either a symbol, a list, or NIL if no function name is +available." + (declare (ignore function)) + nil) + +(definterface valid-function-name-p (form) + "Is FORM syntactically valid to name a function? + If true, FBOUNDP should not signal a type-error for FORM." + (flet ((length=2 (list) + (and (not (null (cdr list))) (null (cddr list))))) + (or (symbolp form) + (and (consp form) (length=2 form) + (eq (first form) 'setf) (symbolp (second form)))))) + +(definterface macroexpand-all (form &optional env) + "Recursively expand all macros in FORM. +Return the resulting form.") + +(definterface compiler-macroexpand-1 (form &optional env) + "Call the compiler-macro for form. +If FORM is a function call for which a compiler-macro has been +defined, invoke the expander function using *macroexpand-hook* and +return the results and T. Otherwise, return the original form and +NIL." + (let ((fun (and (consp form) + (valid-function-name-p (car form)) + (compiler-macro-function (car form) env)))) + (if fun + (let ((result (funcall *macroexpand-hook* fun form env))) + (values result (not (eq result form)))) + (values form nil)))) + +(definterface compiler-macroexpand (form &optional env) + "Repetitively call `compiler-macroexpand-1'." + (labels ((frob (form expanded) + (multiple-value-bind (new-form newly-expanded) + (compiler-macroexpand-1 form env) + (if newly-expanded + (frob new-form t) + (values new-form expanded))))) + (frob form env))) + +(defmacro with-collected-macro-forms + ((forms &optional result) instrumented-form &body body) + "Collect macro forms by locally binding *MACROEXPAND-HOOK*. + +Evaluates INSTRUMENTED-FORM and collects any forms which undergo +macro-expansion into a list. Then evaluates BODY with FORMS bound to +the list of forms, and RESULT (optionally) bound to the value of +INSTRUMENTED-FORM." + (assert (and (symbolp forms) (not (null forms)))) + (assert (symbolp result)) + (let ((result-symbol (or result (gensym)))) + `(call-with-collected-macro-forms + (lambda (,forms ,result-symbol) + (declare (ignore ,@(and (not result) + `(,result-symbol)))) + ,@body) + (lambda () ,instrumented-form)))) + +(defun call-with-collected-macro-forms (body-fn instrumented-fn) + (let ((return-value nil) + (collected-forms '())) + (let* ((real-macroexpand-hook *macroexpand-hook*) + (*macroexpand-hook* + (lambda (macro-function form environment) + (let ((result (funcall real-macroexpand-hook + macro-function form environment))) + (unless (eq result form) + (push form collected-forms)) + result)))) + (setf return-value (funcall instrumented-fn))) + (funcall body-fn collected-forms return-value))) + +(definterface collect-macro-forms (form &optional env) + "Collect subforms of FORM which undergo (compiler-)macro expansion. +Returns two values: a list of macro forms and a list of compiler macro +forms." + (with-collected-macro-forms (macro-forms expansion) + (ignore-errors (macroexpand-all form env)) + (with-collected-macro-forms (compiler-macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,expansion)))) + (values macro-forms compiler-macro-forms)))) + +(definterface format-string-expand (control-string) + "Expand the format string CONTROL-STRING." + (macroexpand `(formatter ,control-string))) + +(definterface describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. + +The property list has an entry for each interesting aspect of the +symbol. The recognised keys are: + + :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO + :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM + +The value of each property is the corresponding documentation string, +or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys +not listed here (but slime-print-apropos in Emacs must know about +them). + +Properties should be included if and only if they are applicable to +the symbol. For example, only (and all) fbound symbols should include +the :FUNCTION property. + +Example: +\(describe-symbol-for-emacs 'vector) + => (:CLASS :NOT-DOCUMENTED + :TYPE :NOT-DOCUMENTED + :FUNCTION \"Constructs a simple-vector from the given objects.\")") + +(definterface describe-definition (name type) + "Describe the definition NAME of TYPE. +TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS. + +Return a documentation string, or NIL if none is available.") + + +;;;; Debugging + +(definterface install-debugger-globally (function) + "Install FUNCTION as the debugger for all threads/processes. This +usually involves setting *DEBUGGER-HOOK* and, if the implementation +permits, hooking into BREAK as well." + (setq *debugger-hook* function)) + +(definterface call-with-debugging-environment (debugger-loop-fn) + "Call DEBUGGER-LOOP-FN in a suitable debugging environment. + +This function is called recursively at each debug level to invoke the +debugger loop. The purpose is to setup any necessary environment for +other debugger callbacks that will be called within the debugger loop. + +For example, this is a reasonable place to compute a backtrace, switch +to safe reader/printer settings, and so on.") + +(definterface call-with-debugger-hook (hook fun) + "Call FUN and use HOOK as debugger hook. HOOK can be NIL. + +HOOK should be called for both BREAK and INVOKE-DEBUGGER." + (let ((*debugger-hook* hook)) + (funcall fun))) + +(define-condition sldb-condition (condition) + ((original-condition + :initarg :original-condition + :accessor original-condition)) + (:report (lambda (condition stream) + (format stream "Condition in debugger code~@[: ~A~]" + (original-condition condition)))) + (:documentation + "Wrapper for conditions that should not be debugged. + +When a condition arises from the internals of the debugger, it is not +desirable to debug it -- we'd risk entering an endless loop trying to +debug the debugger! Instead, such conditions can be reported to the +user without (re)entering the debugger by wrapping them as +`sldb-condition's.")) + +;;; The following functions in this section are supposed to be called +;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only. + +(definterface compute-backtrace (start end) + "Returns a backtrace of the condition currently being debugged, +that is an ordered list consisting of frames. ``Ordered list'' +means that an integer I can be mapped back to the i-th frame of this +backtrace. + +START and END are zero-based indices constraining the number of frames +returned. Frame zero is defined as the frame which invoked the +debugger. If END is nil, return the frames from START to the end of +the stack.") + +(definterface print-frame (frame stream) + "Print frame to stream.") + +(definterface frame-restartable-p (frame) + "Is the frame FRAME restartable?. +Return T if `restart-frame' can safely be called on the frame." + (declare (ignore frame)) + nil) + +(definterface frame-source-location (frame-number) + "Return the source location for the frame associated to FRAME-NUMBER.") + +(definterface frame-catch-tags (frame-number) + "Return a list of catch tags for being printed in a debugger stack +frame." + (declare (ignore frame-number)) + '()) + +(definterface frame-locals (frame-number) + "Return a list of ((&key NAME ID VALUE) ...) where each element of +the list represents a local variable in the stack frame associated to +FRAME-NUMBER. + +NAME, a symbol; the name of the local variable. + +ID, an integer; used as primary key for the local variable, unique +relatively to the frame under operation. + +value, an object; the value of the local variable.") + +(definterface frame-var-value (frame-number var-id) + "Return the value of the local variable associated to VAR-ID +relatively to the frame associated to FRAME-NUMBER.") + +(definterface disassemble-frame (frame-number) + "Disassemble the code for the FRAME-NUMBER. +The output should be written to standard output. +FRAME-NUMBER is a non-negative integer.") + +(definterface eval-in-frame (form frame-number) + "Evaluate a Lisp form in the lexical context of a stack frame +in the debugger. + +FRAME-NUMBER must be a positive integer with 0 indicating the +frame which invoked the debugger. + +The return value is the result of evaulating FORM in the +appropriate context.") + +(definterface frame-package (frame-number) + "Return the package corresponding to the frame at FRAME-NUMBER. +Return nil if the backend can't figure it out." + (declare (ignore frame-number)) + nil) + +(definterface frame-call (frame-number) + "Return a string representing a call to the entry point of a frame.") + +(definterface return-from-frame (frame-number form) + "Unwind the stack to the frame FRAME-NUMBER and return the value(s) +produced by evaluating FORM in the frame context to its caller. + +Execute any clean-up code from unwind-protect forms above the frame +during unwinding. + +Return a string describing the error if it's not possible to return +from the frame.") + +(definterface restart-frame (frame-number) + "Restart execution of the frame FRAME-NUMBER with the same arguments +as it was called originally.") + +(definterface print-condition (condition stream) + "Print a condition for display in SLDB." + (princ condition stream)) + +(definterface condition-extras (condition) + "Return a list of extra for the debugger. +The allowed elements are of the form: + (:SHOW-FRAME-SOURCE frame-number) + (:REFERENCES &rest refs) +" + (declare (ignore condition)) + '()) + +(definterface gdb-initial-commands () + "List of gdb commands supposed to be executed first for the + ATTACH-GDB restart." + nil) + +(definterface activate-stepping (frame-number) + "Prepare the frame FRAME-NUMBER for stepping.") + +(definterface sldb-break-on-return (frame-number) + "Set a breakpoint in the frame FRAME-NUMBER.") + +(definterface sldb-break-at-start (symbol) + "Set a breakpoint on the beginning of the function for SYMBOL.") + +(definterface sldb-stepper-condition-p (condition) + "Return true if SLDB was invoked due to a single-stepping condition, +false otherwise. " + (declare (ignore condition)) + nil) + +(definterface sldb-step-into () + "Step into the current single-stepper form.") + +(definterface sldb-step-next () + "Step to the next form in the current function.") + +(definterface sldb-step-out () + "Stop single-stepping temporarily, but resume it once the current function +returns.") + + +;;;; Definition finding + +(defstruct (location (:type list) + (:constructor make-location + (buffer position &optional hints))) + (type :location) + buffer position + ;; Hints is a property list optionally containing: + ;; :snippet SOURCE-TEXT + ;; This is a snippet of the actual source text at the start of + ;; the definition, which could be used in a text search. + hints) + +(defmacro converting-errors-to-error-location (&body body) + "Catches errors during BODY and converts them to an error location." + (let ((gblock (gensym "CONVERTING-ERRORS+"))) + `(block ,gblock + (handler-bind ((error + #'(lambda (e) + (if *debug-swank-backend* + nil ;decline + (return-from ,gblock + (make-error-location e)))))) + ,@body)))) + +(defun make-error-location (datum &rest args) + (cond ((typep datum 'condition) + `(:error ,(format nil "Error: ~A" datum))) + ((symbolp datum) + `(:error ,(format nil "Error: ~A" + (apply #'make-condition datum args)))) + (t + (assert (stringp datum)) + `(:error ,(apply #'format nil datum args))))) + +(definterface find-definitions (name) + "Return a list ((DSPEC LOCATION) ...) for NAME's definitions. + +NAME is a \"definition specifier\". + +DSPEC is a \"definition specifier\" describing the +definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or +\(DEFVAR FOO). + +LOCATION is the source location for the definition.") + +(definterface find-source-location (object) + "Returns the source location of OBJECT, or NIL. + +That is the source location of the underlying datastructure of +OBJECT. E.g. on a STANDARD-OBJECT, the source location of the +respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the +respective DEFSTRUCT definition, and so on." + ;; This returns one source location and not a list of locations. It's + ;; supposed to return the location of the DEFGENERIC definition on + ;; #'SOME-GENERIC-FUNCTION. + (declare (ignore object)) + (make-error-location "FIND-SOURCE-LOCATION is not yet implemented on ~ + this implementation.")) + +(definterface buffer-first-change (filename) + "Called for effect the first time FILENAME's buffer is modified. +CMUCL/SBCL use this to cache the unmodified file and use the +unmodified text to improve the precision of source locations." + (declare (ignore filename)) + nil) + + + +;;;; XREF + +(definterface who-calls (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...)." + (declare (ignore function-name)) + :not-implemented) + +(definterface calls-who (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...)." + (declare (ignore function-name)) + :not-implemented) + +(definterface who-references (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is referenced. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-binds (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is bound. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-sets (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is set. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-macroexpands (macro-name) + "Return the locations where MACRO-NAME (a symbol) is expanded. +See WHO-CALLS for a description of the return value." + (declare (ignore macro-name)) + :not-implemented) + +(definterface who-specializes (class-name) + "Return the locations where CLASS-NAME (a symbol) is specialized. +See WHO-CALLS for a description of the return value." + (declare (ignore class-name)) + :not-implemented) + +;;; Simpler variants. + +(definterface list-callers (function-name) + "List the callers of FUNCTION-NAME. +This function is like WHO-CALLS except that it is expected to use +lower-level means. Whereas WHO-CALLS is usually implemented with +special compiler support, LIST-CALLERS is usually implemented by +groveling for constants in function objects throughout the heap. + +The return value is as for WHO-CALLS.") + +(definterface list-callees (function-name) + "List the functions called by FUNCTION-NAME. +See LIST-CALLERS for a description of the return value.") + + +;;;; Profiling + +;;; The following functions define a minimal profiling interface. + +(definterface profile (fname) + "Marks symbol FNAME for profiling.") + +(definterface profiled-functions () + "Returns a list of profiled functions.") + +(definterface unprofile (fname) + "Marks symbol FNAME as not profiled.") + +(definterface unprofile-all () + "Marks all currently profiled functions as not profiled." + (dolist (f (profiled-functions)) + (unprofile f))) + +(definterface profile-report () + "Prints profile report.") + +(definterface profile-reset () + "Resets profile counters.") + +(definterface profile-package (package callers-p methods) + "Wrap profiling code around all functions in PACKAGE. If a function +is already profiled, then unprofile and reprofile (useful to notice +function redefinition.) + +If CALLERS-P is T names have counts of the most common calling +functions recorded. + +When called with arguments :METHODS T, profile all methods of all +generic functions having names in the given package. Generic functions +themselves, that is, their dispatch functions, are left alone.") + + +;;;; Trace + +(definterface toggle-trace (spec) + "Toggle tracing of the function(s) given with SPEC. +SPEC can be: + (setf NAME) ; a setf function + (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method + (:defgeneric NAME) ; a generic function with all methods + (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. + (:labels TOPLEVEL LOCAL) + (:flet TOPLEVEL LOCAL) ") + + +;;;; Inspector + +(defgeneric emacs-inspect (object) + (:documentation + "Explain to Emacs how to inspect OBJECT. + +Returns a list specifying how to render the object for inspection. + +Every element of the list must be either a string, which will be +inserted into the buffer as is, or a list of the form: + + (:value object &optional format) - Render an inspectable + object. If format is provided it must be a string and will be + rendered in place of the value, otherwise use princ-to-string. + + (:newline) - Render a \\n + + (:action label lambda &key (refresh t)) - Render LABEL (a text + string) which when clicked will call LAMBDA. If REFRESH is + non-NIL the currently inspected object will be re-inspected + after calling the lambda. +")) + +(defmethod emacs-inspect ((object t)) + "Generic method for inspecting any kind of object. + +Since we don't know how to deal with OBJECT we simply dump the +output of CL:DESCRIBE." + `("Type: " (:value ,(type-of object)) (:newline) + "Don't know how to inspect the object, dumping output of CL:DESCRIBE:" + (:newline) (:newline) + ,(with-output-to-string (desc) (describe object desc)))) + +(definterface eval-context (object) + "Return a list of bindings corresponding to OBJECT's slots." + (declare (ignore object)) + '()) + +;;; Utilities for inspector methods. +;;; + +(defun label-value-line (label value &key (newline t)) + "Create a control list which prints \"LABEL: VALUE\" in the inspector. +If NEWLINE is non-NIL a `(:newline)' is added to the result." + (list* (princ-to-string label) ": " `(:value ,value) + (if newline '((:newline)) nil))) + +(defmacro label-value-line* (&rest label-values) + ` (append ,@(loop for (label value) in label-values + collect `(label-value-line ,label ,value)))) + +(definterface describe-primitive-type (object) + "Return a string describing the primitive type of object." + (declare (ignore object)) + "N/A") + + +;;;; Multithreading +;;; +;;; The default implementations are sufficient for non-multiprocessing +;;; implementations. + +(definterface initialize-multiprocessing (continuation) + "Initialize multiprocessing, if necessary and then invoke CONTINUATION. + +Depending on the impleimentaion, this function may never return." + (funcall continuation)) + +(definterface spawn (fn &key name) + "Create a new thread to call FN.") + +(definterface thread-id (thread) + "Return an Emacs-parsable object to identify THREAD. + +Ids should be comparable with equal, i.e.: + (equal (thread-id ) (thread-id )) <==> (eq )" + thread) + +(definterface find-thread (id) + "Return the thread for ID. +ID should be an id previously obtained with THREAD-ID. +Can return nil if the thread no longer exists." + (declare (ignore id)) + (current-thread)) + +(definterface thread-name (thread) + "Return the name of THREAD. +Thread names are short strings meaningful to the user. They do not +have to be unique." + (declare (ignore thread)) + "The One True Thread") + +(definterface thread-status (thread) + "Return a string describing THREAD's state." + (declare (ignore thread)) + "") + +(definterface thread-attributes (thread) + "Return a plist of implementation-dependent attributes for THREAD" + (declare (ignore thread)) + '()) + +(definterface current-thread () + "Return the currently executing thread." + 0) + +(definterface all-threads () + "Return a fresh list of all threads." + '()) + +(definterface thread-alive-p (thread) + "Test if THREAD is termintated." + (member thread (all-threads))) + +(definterface interrupt-thread (thread fn) + "Cause THREAD to execute FN.") + +(definterface kill-thread (thread) + "Terminate THREAD immediately. +Don't execute unwind-protected sections, don't raise conditions. +(Do not pass go, do not collect $200.)" + (declare (ignore thread)) + nil) + +(definterface send (thread object) + "Send OBJECT to thread THREAD." + (declare (ignore thread)) + object) + +(definterface receive (&optional timeout) + "Return the next message from current thread's mailbox." + (receive-if (constantly t) timeout)) + +(definterface receive-if (predicate &optional timeout) + "Return the first message satisfiying PREDICATE.") + +(definterface wake-thread (thread) + "Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using +asynchronous interrupts." + (declare (ignore thread)) + ;; Doesn't have to implement this if RECEIVE-IF periodically calls + ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient + nil) + +(definterface register-thread (name thread) + "Associate the thread THREAD with the symbol NAME. +The thread can then be retrieved with `find-registered'. +If THREAD is nil delete the association." + (declare (ignore name thread)) + nil) + +(definterface find-registered (name) + "Find the thread that was registered for the symbol NAME. +Return nil if the no thread was registred or if the tread is dead." + (declare (ignore name)) + nil) + +(definterface set-default-initial-binding (var form) + "Initialize special variable VAR by default with FORM. + +Some implementations initialize certain variables in each newly +created thread. This function sets the form which is used to produce +the initial value." + (set var (eval form))) + +;; List of delayed interrupts. +;; This should only have thread-local bindings, so no init form. +(defvar *pending-slime-interrupts*) + +(defun check-slime-interrupts () + "Execute pending interrupts if any. +This should be called periodically in operations which +can take a long time to complete. +Return a boolean indicating whether any interrupts was processed." + (when (and (boundp '*pending-slime-interrupts*) + *pending-slime-interrupts*) + (funcall (pop *pending-slime-interrupts*)) + t)) + +(defvar *interrupt-queued-handler* nil + "Function to call on queued interrupts. +Interrupts get queued when an interrupt occurs while interrupt +handling is disabled. + +Backends can use this function to abort slow operations.") + +(definterface wait-for-input (streams &optional timeout) + "Wait for input on a list of streams. Return those that are ready. +STREAMS is a list of streams +TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams +which are ready (or have reached end-of-file) without waiting. +If TIMEOUT is a number and no streams is ready after TIMEOUT seconds, +return nil. + +Return :interrupt if an interrupt occurs while waiting." + (declare (ignore streams timeout)) + ;; Invoking the slime debugger will just endlessly loop. + (call-with-debugger-hook + nil + (lambda () + (error "~s not implemented. Check if ~s = ~s is supported by the implementation." + 'wait-for-input 'swank:*communication-style* swank:*communication-style*)))) + + +;;;; Locks + +;; Please use locks only in swank-gray.lisp. Locks are too low-level +;; for our taste. + +(definterface make-lock (&key name) + "Make a lock for thread synchronization. +Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time +but that thread may hold it more than once." + (declare (ignore name)) + :null-lock) + +(definterface call-with-lock-held (lock function) + "Call FUNCTION with LOCK held, queueing if necessary." + (declare (ignore lock) + (type function function)) + (funcall function)) + + +;;;; Weak datastructures + +(definterface make-weak-key-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the keys." + (apply #'make-hash-table args)) + +(definterface make-weak-value-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the values." + (apply #'make-hash-table args)) + +(definterface hash-table-weakness (hashtable) + "Return nil or one of :key :value :key-or-value :key-and-value" + (declare (ignore hashtable)) + nil) + + +;;;; Floating point + +(definterface float-nan-p (float) + "Return true if FLOAT is a NaN value (Not a Number)." + ;; When the float type implements IEEE-754 floats, two NaN values + ;; are never equal; when the implementation does not support NaN, + ;; the predicate should return false. An implementation can + ;; implement comparison with "unordered-signaling predicates", which + ;; emit floating point exceptions. + (handler-case (not (= float float)) + ;; Comparisons never signal an exception other than the invalid + ;; operation exception (5.11 Details of comparison predicates). + (floating-point-invalid-operation () t))) + +(definterface float-infinity-p (float) + "Return true if FLOAT is positive or negative infinity." + (not (< most-negative-long-float + float + most-positive-long-float))) + + +;;;; Character names + +(definterface character-completion-set (prefix matchp) + "Return a list of names of characters that match PREFIX." + ;; Handle the standard and semi-standard characters. + (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout" + "Linefeed" "Return" "Backspace") + when (funcall matchp prefix name) + collect name)) + + +(defparameter *type-specifier-arglists* + '((and . (&rest type-specifiers)) + (array . (&optional element-type dimension-spec)) + (base-string . (&optional size)) + (bit-vector . (&optional size)) + (complex . (&optional type-specifier)) + (cons . (&optional car-typespec cdr-typespec)) + (double-float . (&optional lower-limit upper-limit)) + (eql . (object)) + (float . (&optional lower-limit upper-limit)) + (function . (&optional arg-typespec value-typespec)) + (integer . (&optional lower-limit upper-limit)) + (long-float . (&optional lower-limit upper-limit)) + (member . (&rest eql-objects)) + (mod . (n)) + (not . (type-specifier)) + (or . (&rest type-specifiers)) + (rational . (&optional lower-limit upper-limit)) + (real . (&optional lower-limit upper-limit)) + (satisfies . (predicate-symbol)) + (short-float . (&optional lower-limit upper-limit)) + (signed-byte . (&optional size)) + (simple-array . (&optional element-type dimension-spec)) + (simple-base-string . (&optional size)) + (simple-bit-vector . (&optional size)) + (simple-string . (&optional size)) + (single-float . (&optional lower-limit upper-limit)) + (simple-vector . (&optional size)) + (string . (&optional size)) + (unsigned-byte . (&optional size)) + (values . (&rest typespecs)) + (vector . (&optional element-type size)) + )) + +;;; Heap dumps + +(definterface save-image (filename &optional restart-function) + "Save a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded.") + +(definterface background-save-image (filename &key restart-function + completion-function) + "Request saving a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded. +COMPLETION-FUNCTION, if non-nil, should be called after saving the image.") + +(defun deinit-log-output () + ;; Can't hang on to an fd-stream from a previous session. + (setf *log-output* nil)) + + +;;;; Wrapping + +(definterface wrap (spec indicator &key before after replace) + "Intercept future calls to SPEC and surround them in callbacks. + +INDICATOR is a symbol identifying a particular wrapping, and is used +to differentiate between multiple wrappings. + +Implementations intercept calls to SPEC and call, in this order: + +* the BEFORE callback, if it's provided, with a single argument set to + the list of arguments passed to the intercepted call; + +* the original definition of SPEC recursively honouring any wrappings + previously established under different values of INDICATOR. If the + compatible function REPLACE is provided, call that instead. + +* the AFTER callback, if it's provided, with a single set to the list + of values returned by the previous call, or, if that call exited + non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY." + (declare (ignore indicator)) + (assert (symbolp spec) nil + "The default implementation for WRAP allows only simple names") + (assert (null (get spec 'slime-wrap)) nil + "The default implementation for WRAP allows a single wrapping") + (let* ((saved (symbol-function spec)) + (replacement (lambda (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (apply (or replace + saved) args))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally)))))))) + (setf (get spec 'slime-wrap) (list saved replacement)) + (setf (symbol-function spec) replacement)) + spec) + +(definterface unwrap (spec indicator) + "Remove from SPEC any wrappings tagged with INDICATOR." + (if (wrapped-p spec indicator) + (setf (symbol-function spec) (first (get spec 'slime-wrap))) + (cerror "All right, so I did" + "Hmmm, ~a is not correctly wrapped, you probably redefined it" + spec)) + (setf (get spec 'slime-wrap) nil) + spec) + +(definterface wrapped-p (spec indicator) + "Returns true if SPEC is wrapped with INDICATOR." + (declare (ignore indicator)) + (and (symbolp spec) + (let ((prop-value (get spec 'slime-wrap))) + (cond ((and prop-value + (not (eq (second prop-value) + (symbol-function spec)))) + (warn "~a appears to be incorrectly wrapped" spec) + nil) + (prop-value t) + (t nil))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/ccl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/ccl.lisp new file mode 100644 index 0000000..61f3f5e --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/ccl.lisp @@ -0,0 +1,868 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-ccl.lisp --- SLIME backend for Clozure CL. +;;; +;;; Copyright (C) 2003, James Bielman +;;; +;;; This program is licensed under the terms of the Lisp Lesser GNU +;;; Public License, known as the LLGPL, and distributed with Clozure CL +;;; as the file "LICENSE". The LLGPL consists of a preamble and the +;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where +;;; these conflict, the preamble takes precedence. +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage swank/ccl + (:use cl swank/backend)) + +(in-package swank/ccl) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (assert (and (= ccl::*openmcl-major-version* 1) + (>= ccl::*openmcl-minor-version* 4)) + () "This file needs CCL version 1.4 or newer")) + +(defimplementation gray-package-name () + "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (multiple-value-bind (ok err) (ignore-errors (require 'xref)) + (unless ok + (warn "~a~%" err)))) + +;;; swank-mop + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + ccl:standard-slot-definition + cl:method + cl:standard-class + ccl:eql-specializer + openmcl-mop:finalize-inheritance + openmcl-mop:compute-applicable-methods-using-classes + ;; standard-class readers + openmcl-mop:class-default-initargs + openmcl-mop:class-direct-default-initargs + openmcl-mop:class-direct-slots + openmcl-mop:class-direct-subclasses + openmcl-mop:class-direct-superclasses + openmcl-mop:class-finalized-p + cl:class-name + openmcl-mop:class-precedence-list + openmcl-mop:class-prototype + openmcl-mop:class-slots + openmcl-mop:specializer-direct-methods + ;; eql-specializer accessors + openmcl-mop:eql-specializer-object + ;; generic function readers + openmcl-mop:generic-function-argument-precedence-order + openmcl-mop:generic-function-declarations + openmcl-mop:generic-function-lambda-list + openmcl-mop:generic-function-methods + openmcl-mop:generic-function-method-class + openmcl-mop:generic-function-method-combination + openmcl-mop:generic-function-name + ;; method readers + openmcl-mop:method-generic-function + openmcl-mop:method-function + openmcl-mop:method-lambda-list + openmcl-mop:method-specializers + openmcl-mop:method-qualifiers + ;; slot readers + openmcl-mop:slot-definition-allocation + openmcl-mop:slot-definition-documentation + openmcl-mop:slot-value-using-class + openmcl-mop:slot-definition-initargs + openmcl-mop:slot-definition-initform + openmcl-mop:slot-definition-initfunction + openmcl-mop:slot-definition-name + openmcl-mop:slot-definition-type + openmcl-mop:slot-definition-readers + openmcl-mop:slot-definition-writers + openmcl-mop:slot-boundp-using-class + openmcl-mop:slot-makunbound-using-class)) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ccl:encode-string-to-octets string :external-format :utf-8)) + +(defimplementation utf8-to-string (octets) + (ccl:decode-string-from-octets octets :external-format :utf-8)) + +;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (ccl:make-socket :connect :passive :local-port port + :local-host host :reuse-address t + :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (ccl:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format + buffering timeout) + (declare (ignore buffering timeout)) + (let ((stream-args (and external-format + `(:external-format ,external-format)))) + (ccl:accept-connection socket :wait t :stream-args stream-args))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation socket-fd (stream) + (ccl::ioblock-device (ccl::stream-ioblock stream t))) + +;;; Unix signals + +(defimplementation getpid () + (ccl::getpid)) + +(defimplementation lisp-implementation-type-name () + "ccl") + +;;; Arglist + +(defimplementation arglist (fname) + (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil)) + (ccl:arglist fname)) + (if binding + arglist + :not-available))) + +(defimplementation function-name (function) + (ccl:function-name function)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (let ((flags (ccl:declaration-information decl-identifier))) + (if flags + `(&any ,flags) + (call-next-method)))) + +;;; Compilation + +(defun handle-compiler-warning (condition) + "Resignal a ccl:compiler-warning as swank/backend:compiler-warning." + (signal 'compiler-condition + :original-condition condition + :message (compiler-warning-short-message condition) + :source-context nil + :severity (compiler-warning-severity condition) + :location (source-note-to-source-location + (ccl:compiler-warning-source-note condition) + (lambda () "Unknown source") + (ccl:compiler-warning-function-name condition)))) + +(defgeneric compiler-warning-severity (condition)) +(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning) +(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning) + +(defgeneric compiler-warning-short-message (condition)) + +;; Pretty much the same as ccl:report-compiler-warning but +;; without the source position and function name stuff. +(defmethod compiler-warning-short-message ((c ccl:compiler-warning)) + (with-output-to-string (stream) + (ccl:report-compiler-warning c stream :short t))) + +;; Needed because `ccl:report-compiler-warning' would return +;; "Nonspecific warning". +(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause)) + (princ-to-string c)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((ccl:compiler-warning 'handle-compiler-warning)) + (let ((ccl:*merge-compiler-warnings* nil)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (compile-file input-file + :output-file output-file + :load load-p + :external-format external-format))) + +;; Use a temp file rather than in-core compilation in order to handle +;; eval-when's as compile-time. +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((temp-file-name (ccl:temp-pathname)) + (ccl:*save-source-locations* t)) + (unwind-protect + (progn + (with-open-file (s temp-file-name :direction :output + :if-exists :error :external-format :utf-8) + (write-string string s)) + (let ((binary-filename (compile-temp-file + temp-file-name filename buffer position))) + (delete-file binary-filename))) + (delete-file temp-file-name))))) + +(defvar *temp-file-map* (make-hash-table :test #'equal) + "A mapping from tempfile names to Emacs buffer names.") + +(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset) + (compile-file temp-file-name + :load t + :compile-file-original-truename + (or buffer-file-name + (progn + (setf (gethash temp-file-name *temp-file-map*) + buffer-name) + temp-file-name)) + :compile-file-original-buffer-offset (1- offset) + :external-format :utf-8)) + +(defimplementation save-image (filename &optional restart-function) + (ccl:save-application filename :toplevel-function restart-function)) + +;;; Cross-referencing + +(defun xref-locations (relation name &optional inverse) + (delete-duplicates + (mapcan #'find-definitions + (if inverse + (ccl::get-relation relation name :wild :exhaustive t) + (ccl::get-relation relation :wild name :exhaustive t))) + :test 'equal)) + +(defimplementation who-binds (name) + (xref-locations :binds name)) + +(defimplementation who-macroexpands (name) + (xref-locations :macro-calls name t)) + +(defimplementation who-references (name) + (remove-duplicates + (append (xref-locations :references name) + (xref-locations :sets name) + (xref-locations :binds name)) + :test 'equal)) + +(defimplementation who-sets (name) + (xref-locations :sets name)) + +(defimplementation who-calls (name) + (remove-duplicates + (append + (xref-locations :direct-calls name) + (xref-locations :indirect-calls name) + (xref-locations :macro-calls name t)) + :test 'equal)) + +(defimplementation who-specializes (class) + (when (symbolp class) + (setq class (find-class class nil))) + (when class + (delete-duplicates + (mapcar (lambda (m) + (car (find-definitions m))) + (ccl:specializer-direct-methods class)) + :test 'equal))) + +(defimplementation list-callees (name) + (remove-duplicates + (append + (xref-locations :direct-calls name t) + (xref-locations :macro-calls name nil)) + :test 'equal)) + +(defimplementation list-callers (symbol) + (delete-duplicates + (mapcan #'find-definitions (ccl:caller-functions symbol)) + :test #'equal)) + +;;; Profiling (alanr: lifted from swank-clisp) + +(defimplementation profile (fname) + (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + swank-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (swank-monitor:unmonitor)) + +(defimplementation profile-report () + (swank-monitor:report-monitoring)) + +(defimplementation profile-reset () + (swank-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (swank-monitor:monitor-all package)) + +;;; Debugging + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(*debugger-hook* nil) + ;; don't let error while printing error take us down + (ccl:*signal-printing-errors* nil)) + (funcall debugger-loop-fn))) + +;; This is called for an async interrupt and is running in a random +;; thread not selected by the user, so don't use thread-local vars +;; such as *emacs-connection*. +(defun find-repl-thread () + (let* ((*break-on-signals* nil) + (conn (swank::default-connection))) + (and (swank::multithreaded-connection-p conn) + (swank::mconn.repl-thread conn)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ccl:*break-hook* hook) + (ccl:*select-interactive-process-hook* 'find-repl-thread)) + (funcall fun))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ccl:*break-hook* function) + (setq ccl:*select-interactive-process-hook* 'find-repl-thread) + ) + +(defun map-backtrace (function &optional + (start-frame-number 0) + end-frame-number) + "Call FUNCTION passing information about each stack frame + from frames START-FRAME-NUMBER to END-FRAME-NUMBER." + (let ((end-frame-number (or end-frame-number most-positive-fixnum))) + (ccl:map-call-frames function + :origin ccl:*top-error-frame* + :start-frame-number start-frame-number + :count (- end-frame-number start-frame-number)))) + +(defimplementation compute-backtrace (start-frame-number end-frame-number) + (let (result) + (map-backtrace (lambda (p context) + (push (list :frame p context) result)) + start-frame-number end-frame-number) + (nreverse result))) + +(defimplementation print-frame (frame stream) + (assert (eq (first frame) :frame)) + (destructuring-bind (p context) (rest frame) + (let ((lfun (ccl:frame-function p context))) + (format stream "(~S" (or (ccl:function-name lfun) lfun)) + (let* ((unavailable (cons nil nil)) + (args (ccl:frame-supplied-arguments p context + :unknown-marker unavailable))) + (declare (dynamic-extent unavailable)) + (if (eq args unavailable) + (format stream " #") + (dolist (arg args) + (if (eq arg unavailable) + (format stream " #") + (format stream " ~s" arg))))) + (format stream ")")))) + +(defmacro with-frame ((p context) frame-number &body body) + `(call/frame ,frame-number (lambda (,p ,context) . ,body))) + +(defun call/frame (frame-number if-found) + (map-backtrace + (lambda (p context) + (return-from call/frame + (funcall if-found p context))) + frame-number)) + +(defimplementation frame-call (frame-number) + (with-frame (p context) frame-number + (with-output-to-string (stream) + (print-frame (list :frame p context) stream)))) + +(defimplementation frame-var-value (frame var) + (with-frame (p context) frame + (cdr (nth var (ccl:frame-named-variables p context))))) + +(defimplementation frame-locals (index) + (with-frame (p context) index + (loop for (name . value) in (ccl:frame-named-variables p context) + collect (list :name name :value value :id 0)))) + +(defimplementation frame-source-location (index) + (with-frame (p context) index + (multiple-value-bind (lfun pc) (ccl:frame-function p context) + (if pc + (pc-source-location lfun pc) + (function-source-location lfun))))) + +(defun function-name-package (name) + (etypecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql ccl::traced)) (function-name-package (second name))) + ((cons (eql setf)) (symbol-package (second name))) + ((cons (eql :internal)) (function-name-package (car (last name)))) + ((cons (and symbol (not keyword)) (or (cons list null) + (cons keyword (cons list null)))) + (symbol-package (car name))) + (standard-method (function-name-package (ccl:method-name name))))) + +(defimplementation frame-package (frame-number) + (with-frame (p context) frame-number + (let* ((lfun (ccl:frame-function p context)) + (name (ccl:function-name lfun))) + (function-name-package name)))) + +(defimplementation eval-in-frame (form index) + (with-frame (p context) index + (let ((vars (ccl:frame-named-variables p context))) + (eval `(let ,(loop for (var . val) in vars collect `(,var ',val)) + (declare (ignorable ,@(mapcar #'car vars))) + ,form))))) + +(defimplementation return-from-frame (index form) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (with-frame (p context) index + (declare (ignore context)) + (ccl:apply-in-frame p #'values values)))) + +(defimplementation restart-frame (index) + (with-frame (p context) index + (ccl:apply-in-frame p + (ccl:frame-function p context) + (ccl:frame-supplied-arguments p context)))) + +(defimplementation disassemble-frame (the-frame-number) + (with-frame (p context) the-frame-number + (multiple-value-bind (lfun pc) (ccl:frame-function p context) + (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context) + (disassemble lfun)))) + +;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008) +;; contains some interesting details: +;; +;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects +;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, +;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end +;; positions are file positions (not character positions). The text will +;; be NIL unless text recording was on at read-time. If the original +;; file is still available, you can force missing source text to be read +;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT. +;; +;; Source-note's are associated with definitions (via record-source-file) +;; and also stored in function objects (including anonymous and nested +;; functions). The former can be retrieved via +;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE. +;; +;; The recording behavior is controlled by the new variable +;; CCL:*SAVE-SOURCE-LOCATIONS*: +;; +;; If NIL, don't store source-notes in function objects, and store only +;; the filename for definitions (the latter only if +;; *record-source-file* is true). +;; +;; If T, store source-notes, including a copy of the original source +;; text, for function objects and definitions (the latter only if +;; *record-source-file* is true). +;; +;; If :NO-TEXT, store source-notes, but without saved text, for +;; function objects and defintions (the latter only if +;; *record-source-file* is true). This is the default. +;; +;; PC to source mapping is controlled by the new variable +;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a +;; compressed table mapping pc offsets to corresponding source locations. +;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) +;; which returns a source-note for the source at offset pc in the +;; function. + +(defun function-source-location (function) + (source-note-to-source-location + (or (ccl:function-source-note function) + (function-name-source-note function)) + (lambda () + (format nil "Function has no source note: ~A" function)) + (ccl:function-name function))) + +(defun pc-source-location (function pc) + (source-note-to-source-location + (or (ccl:find-source-note-at-pc function pc) + (ccl:function-source-note function) + (function-name-source-note function)) + (lambda () + (format nil "No source note at PC: ~a[~d]" function pc)) + (ccl:function-name function))) + +(defun function-name-source-note (fun) + (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function))) + (and defs + (destructuring-bind ((type . name) srcloc . srclocs) (car defs) + (declare (ignore type name srclocs)) + srcloc)))) + +(defun source-note-to-source-location (source if-nil-thunk &optional name) + (labels ((filename-to-buffer (filename) + (cond ((gethash filename *temp-file-map*) + (list :buffer (gethash filename *temp-file-map*))) + ((probe-file filename) + (list :file (ccl:native-translated-namestring + (truename filename)))) + (t (error "File ~s doesn't exist" filename))))) + (handler-case + (cond ((ccl:source-note-p source) + (let* ((full-text (ccl:source-note-text source)) + (file-name (ccl:source-note-filename source)) + (start-pos (ccl:source-note-start-pos source))) + (make-location + (when file-name (filename-to-buffer (pathname file-name))) + (when start-pos (list :position (1+ start-pos))) + (when full-text + (list :snippet (subseq full-text 0 + (min 40 (length full-text)))))))) + ((and source name) + ;; This branch is probably never used + (make-location + (filename-to-buffer source) + (list :function-name (princ-to-string + (if (functionp name) + (ccl:function-name name) + name))))) + (t `(:error ,(funcall if-nil-thunk)))) + (error (c) `(:error ,(princ-to-string c)))))) + +(defun alphatizer-definitions (name) + (let ((alpha (gethash name ccl::*nx1-alphatizers*))) + (and alpha (ccl:find-definition-sources alpha)))) + +(defun p2-definitions (name) + (let ((nx1-op (gethash name ccl::*nx1-operators*))) + (and nx1-op + (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) ) + (and (array-in-bounds-p dispatch nx1-op) + (let ((p2 (aref dispatch nx1-op))) + (and p2 + (ccl:find-definition-sources p2)))))))) + +(defimplementation find-definitions (name) + (let ((defs (append (or (ccl:find-definition-sources name) + (and (symbolp name) + (fboundp name) + (ccl:find-definition-sources + (symbol-function name)))) + (alphatizer-definitions name) + (p2-definitions name)))) + (loop for ((type . name) . sources) in defs + collect (list (definition-name type name) + (source-note-to-source-location + (find-if-not #'null sources) + (lambda () "No source-note available") + name))))) + +(defimplementation find-source-location (obj) + (let* ((defs (ccl:find-definition-sources obj)) + (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal) + (car defs))) + (note (find-if-not #'null (cdr best-def)))) + (when note + (source-note-to-source-location + note + (lambda () "No source note available"))))) + +(defun definition-name (type object) + (case (ccl:definition-type-name type) + (method (ccl:name-of object)) + (t (list (ccl:definition-type-name type) (ccl:name-of object))))) + +;;; Utilities + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :setf (let ((setf-function-name (ccl:setf-function-spec-name + `(setf ,symbol)))) + (when (fboundp setf-function-name) + (doc 'function setf-function-name)))) + (maybe-push + :type (when (ccl:type-specifier-p symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:setf + (describe (ccl:setf-function-spec-name `(setf ,symbol)))) + (:class + (describe (find-class symbol))) + (:type + (describe (or (find-class symbol nil) symbol))))) + +;; spec ::= (:defmethod {}* ({}*)) +(defun parse-defmethod-spec (spec) + (values (second spec) + (subseq spec 2 (position-if #'consp spec)) + (find-if #'consp (cddr spec)))) + +(defimplementation toggle-trace (spec) + "We currently ignore just about everything." + (let ((what (ecase (first spec) + ((setf) + spec) + ((:defgeneric) + (second spec)) + ((:defmethod) + (multiple-value-bind (name qualifiers specializers) + (parse-defmethod-spec spec) + (find-method (fdefinition name) + qualifiers + specializers)))))) + (cond ((member what (trace) :test #'equal) + (ccl::%untrace what) + (format nil "~S is now untraced." what)) + (t + (ccl:trace-function what) + (format nil "~S is now traced." what))))) + +;;; Macroexpansion + +(defimplementation macroexpand-all (form &optional env) + (ccl:macroexpand-all form env)) + +;;;; Inspection + +(defun comment-type-p (type) + (or (eq type :comment) + (and (consp type) (eq (car type) :comment)))) + +(defmethod emacs-inspect ((o t)) + (let* ((inspector:*inspector-disassembly* t) + (i (inspector:make-inspector o)) + (count (inspector:compute-line-count i))) + (loop for l from 0 below count append + (multiple-value-bind (value label type) (inspector:line-n i l) + (etypecase type + ((member nil :normal) + `(,(or label "") (:value ,value) (:newline))) + ((member :colon) + (label-value-line label value)) + ((member :static) + (list (princ-to-string label) " " `(:value ,value) '(:newline))) + ((satisfies comment-type-p) + (list (princ-to-string label) '(:newline)))))))) + +(defmethod emacs-inspect :around ((o t)) + (if (or (uvector-inspector-p o) + (not (ccl:uvectorp o))) + (call-next-method) + (let ((value (call-next-method))) + (cond ((listp value) + (append value + `((:newline) + (:value ,(make-instance 'uvector-inspector :object o) + "Underlying UVECTOR")))) + (t value))))) + +(defmethod emacs-inspect ((f function)) + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(princ-to-string (arglist f)) (:newline)) + (label-value-line "Documentation" (documentation f t)) + (when (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f))) + (when (ccl:function-source-note f) + (label-value-line "Source note" + (ccl:function-source-note f))) + (when (typep f 'ccl:compiled-lexical-closure) + (append + (label-value-line "Inner function" (ccl::closure-function f)) + '("Closed over values:" (:newline)) + (loop for (name value) in (ccl::closure-closed-over-values f) + append (label-value-line (format nil " ~a" name) + value)))))) + +(defclass uvector-inspector () + ((object :initarg :object))) + +(defgeneric uvector-inspector-p (object) + (:method ((object t)) nil) + (:method ((object uvector-inspector)) t)) + +(defmethod emacs-inspect ((uv uvector-inspector)) + (with-slots (object) uv + (loop for i below (ccl:uvsize object) append + (label-value-line (princ-to-string i) (ccl:uvref object i))))) + +(defimplementation type-specifier-p (symbol) + (or (ccl:type-specifier-p symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +;;; Multiprocessing + +(defvar *known-processes* + (make-hash-table :size 20 :weak :key :test #'eq) + "A map from threads to mailboxes.") + +(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*")) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (ccl:make-lock "thread mailbox")) + (semaphore (ccl:make-semaphore)) + (queue '() :type list)) + +(defimplementation spawn (fun &key name) + (ccl:process-run-function (or name "Anonymous (Swank)") + fun)) + +(defimplementation thread-id (thread) + (ccl:process-serial-number thread)) + +(defimplementation find-thread (id) + (find id (ccl:all-processes) :key #'ccl:process-serial-number)) + +(defimplementation thread-name (thread) + (ccl:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A" (ccl:process-whostate thread))) + +(defimplementation thread-attributes (thread) + (list :priority (ccl:process-priority thread))) + +(defimplementation make-lock (&key name) + (ccl:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (ccl:with-lock-grabbed (lock) + (funcall function))) + +(defimplementation current-thread () + ccl:*current-process*) + +(defimplementation all-threads () + (ccl:all-processes)) + +(defimplementation kill-thread (thread) + ;;(ccl:process-kill thread) ; doesn't cut it + (ccl::process-initial-form-exited thread :kill)) + +(defimplementation thread-alive-p (thread) + (not (ccl:process-exhausted-p thread))) + +(defimplementation interrupt-thread (thread function) + (ccl:process-interrupt + thread + (lambda () + (let ((ccl:*top-error-frame* (ccl::%current-exception-frame))) + (funcall function))))) + +(defun mailbox (thread) + (ccl:with-lock-grabbed (*known-processes-lock*) + (or (gethash thread *known-processes*) + (setf (gethash thread *known-processes*) (make-mailbox))))) + +(defimplementation send (thread message) + (assert message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (ccl:with-lock-grabbed (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (ccl:signal-semaphore (mailbox.semaphore mbox))))) + +(defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (ccl:with-lock-grabbed (mutex) + (ccl:signal-semaphore (mailbox.semaphore mbox))))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox ccl:*current-process*)) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (ccl:with-lock-grabbed (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (ccl:wait-on-semaphore (mailbox.semaphore mbox))))) + +(let ((alist '()) + (lock (ccl:make-lock "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (ccl:with-lock-grabbed (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (ccl:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (ccl:with-lock-grabbed (lock) + (cdr (assoc name alist))))) + +(defimplementation set-default-initial-binding (var form) + (eval `(ccl::def-standard-initial-binding ,var ,form))) + +(defimplementation quit-lisp () + (ccl:quit)) + +(defimplementation set-default-directory (directory) + (let ((dir (truename (merge-pathnames directory)))) + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (ccl:cwd dir) + (default-directory))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation hash-table-weakness (hashtable) + (ccl:hash-table-weak-p hashtable)) + +(pushnew 'deinit-log-output ccl:*save-exit-functions*) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/clasp.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/clasp.lisp new file mode 100644 index 0000000..cc1705c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/clasp.lisp @@ -0,0 +1,809 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-clasp.lisp --- SLIME backend for CLASP. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/clasp + (:use cl swank/backend)) + +(in-package swank/clasp) + +#+(or) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq swank::*log-output* (open "/tmp/slime.log" :direction :output)) + (setq swank:*log-events* t)) + +(defmacro slime-dbg (fmt &rest args) + `(swank::log-event "slime-dbg ~a ~a~%" mp:*current-process* (apply #'format nil ,fmt ,args))) + +;; Hard dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) + +;; Soft dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (probe-file "sys:profile.fas") + (require :profile) + (pushnew :profile *features*)) + (when (probe-file "sys:serve-event") + (require :serve-event) + (pushnew :serve-event *features*))) + +(declaim (optimize (debug 3))) + +;;; Swank-mop + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import-swank-mop-symbols + :clos + nil + #+(or)`(:eql-specializer + :eql-specializer-object + :generic-function-declarations + :specializer-direct-methods + ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) + '(:compute-applicable-methods-using-classes))))) + +(defimplementation gray-package-name () + "GRAY") + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + ;; As of March 2017 CLASP provides threads. + ;; But it's experimental. + ;; ECLs swank implementation says that CLOS is not thread safe and + ;; I use ECLs CLOS implementation - this is a worry for the future. + ;; nil or :spawn + ;; nil + :spawn +#| #+threads :spawn + #-threads nil +|# + ) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t + :input t + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format)) +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (two-way-stream (socket-fd (two-way-stream-input-stream socket))) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (si:file-stream-fd socket)))) + +(defvar *external-format-to-coding-system* + '((:latin-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (ext:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, CLASP uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + +;;;; Unix Integration + +;;; If CLASP is built with thread support, it'll spawn a helper thread +;;; executing the SIGINT handler. We do not want to BREAK into that +;;; helper but into the main thread, though. This is coupled with the +;;; current choice of NIL as communication-style in so far as CLASP's +;;; main-thread is also the Slime's REPL thread. + +#+clasp-working +(defimplementation call-with-user-break-handler (real-handler function) + (let ((old-handler #'si:terminal-interrupt)) + (setf (symbol-function 'si:terminal-interrupt) + (make-interrupt-handler real-handler)) + (unwind-protect (funcall function) + (setf (symbol-function 'si:terminal-interrupt) old-handler)))) + +#+threads +(defun make-interrupt-handler (real-handler) + (let ((main-thread (find 'si:top-level (mp:all-processes) + :key #'mp:process-name))) + #'(lambda (&rest args) + (declare (ignore args)) + (mp:interrupt-process main-thread real-handler)))) + +#-threads +(defun make-interrupt-handler (real-handler) + #'(lambda (&rest args) + (declare (ignore args)) + (funcall real-handler))) + + +(defimplementation getpid () + (si:getpid)) + +(defimplementation set-default-directory (directory) + (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation quit-lisp () + (core:quit)) + + + +;;; Instead of busy waiting with communication-style NIL, use select() +;;; on the sockets' streams. +#+serve-event +(progn + (defun poll-streams (streams timeout) + (let* ((serve-event::*descriptor-handlers* + (copy-list serve-event::*descriptor-handlers*)) + (active-fds '()) + (fd-stream-alist + (loop for s in streams + for fd = (socket-fd s) + collect (cons fd s) + do (serve-event:add-fd-handler fd :input + #'(lambda (fd) + (push fd active-fds)))))) + (serve-event:serve-event timeout) + (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))) + + (defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (poll-streams streams 0))) + (t + (when-let (ready (poll-streams streams 0.2)) + (return ready)))))) + +) ; #+serve-event (progn ... + +#-serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (remove-if-not #'listen streams))) + (t + (let ((ready (remove-if-not #'listen streams))) + (if ready (return ready)) + (sleep 0.1)))))) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +#-clasp-bytecmp +(defun handle-compiler-message (condition) + ;; CLASP emits lots of noise in compiler-notes, like "Invoking + ;; external command". + (unless (typep condition 'c::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (cmp:compiler-fatal-error :error) + (cmp:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +#-clasp-bytecmp +(defun condition-location (condition) + (let ((file (cmp:compiler-message-file condition)) + (position (cmp:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) + +(defimplementation call-with-compilation-hooks (function) + (funcall function)) +#|| #-clasp-bytecmp + (handler-bind ((c:compiler-message #'handle-compiler-message)) + (funcall function))) +||# + + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file) + ;; Ignore the output-file and generate our own + (let ((tmp-output-file (compile-file-pathname (si:mkstemp "TMP:clasp-swank-compile-file-")))) + (format t "Using tmp-output-file: ~a~%" tmp-output-file) + (multiple-value-bind (fasl warnings-p failure-p) + (with-compilation-hooks () + (compile-file input-file :output-file tmp-output-file + :external-format external-format)) + (values fasl warnings-p + (or failure-p + (when load-p + (not (load fasl)))))))) + +(defvar *tmpfile-map* (make-hash-table :test #'equal)) + +(defun note-buffer-tmpfile (tmp-file buffer-name) + ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. + (let ((tmp-namestring (namestring (truename tmp-file)))) + (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) + tmp-namestring)) + +(defun tmpfile-to-buffer (tmp-file) + (gethash tmp-file *tmpfile-map*)) + +(defimplementation swank-compile-string (string &key buffer position filename policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) ; for compilation hooks + (*buffer-start-position* position)) + (let ((tmp-file (si:mkstemp "TMP:clasp-swank-tmpfile-")) + (fasl-file) + (warnings-p) + (failure-p)) + (unwind-protect + (with-open-file (tmp-stream tmp-file :direction :output + :if-exists :supersede) + (write-string string tmp-stream) + (finish-output tmp-stream) + (multiple-value-setq (fasl-file warnings-p failure-p) + (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer)))) + (compile-file tmp-file + :source-debug-pathname (pathname truename) + :source-debug-offset (1- position))))) + (when fasl-file (load fasl-file)) + (when (probe-file tmp-file) + (delete-file tmp-file)) + (when fasl-file + (delete-file fasl-file))) + (not failure-p))))) + +;;;; Documentation + +(defimplementation arglist (name) + (multiple-value-bind (arglist foundp) + (core:function-lambda-list name) ;; Uses bc-split + (if foundp arglist :not-available))) + +(defimplementation function-name (f) + (typecase f + (generic-function (clos::generic-function-name f)) + (function (ext:compiled-function-name f)))) + +;; FIXME +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (macroexpand form)) + +;;; modified from sbcl.lisp +(defimplementation collect-macro-forms (form &optional environment) + (let ((macro-forms '()) + (compiler-macro-forms '()) + (function-quoted-forms '())) + (format t "In collect-macro-forms~%") + (cmp:code-walk + form environment + :code-walker-function + (lambda (form environment) + (when (and (consp form) + (symbolp (car form))) + (cond ((eq (car form) 'function) + (push (cadr form) function-quoted-forms)) + ((member form function-quoted-forms) + nil) + ((macro-function (car form) environment) + (push form macro-forms)) + ((not (eq form (core:compiler-macroexpand-1 form environment))) + (push form compiler-macro-forms)))) + form)) + (values macro-forms compiler-macro-forms))) + + + + + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((frob (type boundp) + (when (funcall boundp symbol) + (let ((doc (describe-definition symbol type))) + (setf result (list* type doc result)))))) + (frob :VARIABLE #'boundp) + (frob :FUNCTION #'fboundp) + (frob :CLASS (lambda (x) (find-class x nil)))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +(defimplementation type-specifier-p (symbol) + (or (subtypep nil symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* +#+frs si::*frs-base* +#+frs si::*frs-top* + si::*tpl-commands* + si::*tpl-level* +#+frs si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env +#+frs si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(lambda (condition old-hook) + ;; Regard *debugger-hook* if set by user. + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)) + ) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun)) + ) + +(defvar *backtrace* '()) + +;;; Commented out; it's not clear this is a good way of doing it. In +;;; particular because it makes errors stemming from this file harder +;;; to debug, and given the "young" age of CLASP's swank backend, that's +;;; a bad idea. + +;; (defun in-swank-package-p (x) +;; (and +;; (symbolp x) +;; (member (symbol-package x) +;; (list #.(find-package :swank) +;; #.(find-package :swank/backend) +;; #.(ignore-errors (find-package :swank-mop)) +;; #.(ignore-errors (find-package :swank-loader)))) +;; t)) + +;; (defun is-swank-source-p (name) +;; (setf name (pathname name)) +;; (pathname-match-p +;; name +;; (make-pathname :defaults swank-loader::*source-directory* +;; :name (pathname-name name) +;; :type (pathname-type name) +;; :version (pathname-version name)))) + +;; (defun is-ignorable-fun-p (x) +;; (or +;; (in-swank-package-p (frame-name x)) +;; (multiple-value-bind (file position) +;; (ignore-errors (si::bc-file (car x))) +;; (declare (ignore position)) +;; (if file (is-swank-source-p file))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*ihs-top* 0) + (*ihs-current* *ihs-top*) + #+frs (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + #+frs (*frs-top* (frs-top)) + (*tpl-level* (1+ *tpl-level*))) + (core:call-with-backtrace + (lambda (raw-backtrace) + (let ((*backtrace* + (let ((backtrace (core::common-lisp-backtrace-frames + raw-backtrace + :gather-start-trigger + (lambda (frame) + (let ((function-name (core::backtrace-frame-function-name frame))) + (and (symbolp function-name) + (eq function-name 'core::universal-error-handler)))) + :gather-all-frames nil))) + (unless backtrace + (setq backtrace (core::common-lisp-backtrace-frames + :gather-all-frames nil))) + backtrace))) + (declare (special *ihs-current*)) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn))))))) + +(defimplementation compute-backtrace (start end) + (subseq *backtrace* start + (and (numberp end) + (min end (length *backtrace*))))) + +(defun frame-name (frame) + (let ((x (core::backtrace-frame-function-name frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun frame-function (frame-number) + (let ((x (core::backtrace-frame-function-name (elt *backtrace* frame-number)))) + (etypecase x + (symbol + (and (fboundp x) + (fdefinition x))) + (cons + (if (eq (car x) 'cl:setf) + (fdefinition x) + nil)) + (function + x)))) + +(defimplementation print-frame (frame stream) + (if (core::backtrace-frame-arguments frame) + (format stream "(~a~{ ~s~})" (core::backtrace-frame-print-name frame) + (coerce (core::backtrace-frame-arguments frame) 'list)) + (format stream "~a" (core::backtrace-frame-print-name frame)))) + +(defimplementation frame-source-location (frame-number) + (let* ((address (core::backtrace-frame-return-address (elt *backtrace* frame-number))) + (code-source-location (ext::code-source-position address))) + (format t "code-source-location ~s~%" code-source-location) + ;; (core::source-info-backtrace *backtrace*) + (make-location (list :file (namestring (ext::code-source-line-source-pathname code-source-location))) + (list :line (ext::code-source-line-line-number code-source-location)) + '(:align t)))) + +#+clasp-working +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defun ihs-frame-id (frame-number) + (- (core:ihs-top) frame-number)) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *backtrace* frame-number)) + (env nil) ; no env yet + (locals (loop for x = env then (core:get-parent-environment x) + while x + nconc (loop for name across (core:environment-debug-names x) + for value across (core:environment-debug-values x) + collect (list :name name :id 0 :value value))))) + (nconc + (loop for arg across (core::backtrace-frame-arguments frame) + for i from 0 + collect (list :name (intern (format nil "ARG~d" i) :cl-user) + :id 0 + :value arg)) + locals))) + +(defimplementation frame-var-value (frame-number var-number) + (let* ((frame (elt *backtrace* frame-number)) + (env nil) + (args (core::backtrace-frame-arguments frame))) + (if (< var-number (length args)) + (svref args var-number) + (elt (frame-locals frame-number) var-number)))) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-function frame-number))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let* ((frame (elt *backtrace* frame-number)) + (raw-arg-values (coerce (core::backtrace-frame-arguments frame) 'list))) + (if (and (= (length raw-arg-values) 2) (core:vaslistp (car raw-arg-values))) + (let* ((arg-values (core:list-from-va-list (car raw-arg-values))) + (bindings (append (loop for i from 0 for value in arg-values collect `(,(intern (core:bformat nil "ARG%d" i) :cl-user) ',value)) + (list (list (intern "NEXT-METHODS" :cl-user) (cadr raw-arg-values)))))) + (eval + `(let (,@bindings) ,form))) + (let* ((arg-values raw-arg-values) + (bindings (loop for i from 0 for value in arg-values collect `(,(intern (core:bformat nil "ARG%d" i) :cl-user) ',value)))) + (eval + `(let (,@bindings) ,form)))))) + + +#+clasp-working +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +#+clasp-working +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) + + +;;;; Inspector + +;;; FIXME: Would be nice if it was possible to inspect objects +;;; implemented in C. + + +;;;; Definitions + +(defun make-file-location (file file-position) + ;; File positions in CL start at 0, but Emacs' buffer positions + ;; start at 1. We specify (:ALIGN T) because the positions comming + ;; from CLASP point at right after the toplevel form appearing before + ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. + (make-location `(:file ,(namestring (translate-logical-pathname file))) + `(:position ,(1+ file-position)) + `(:align t))) + +(defun make-buffer-location (buffer-name start-position &optional (offset 0)) + (make-location `(:buffer ,buffer-name) + `(:offset ,start-position ,offset) + `(:align t))) + +(defun translate-location (location) + (make-location (list :file (namestring (ext:source-location-pathname location))) + (list :position (ext:source-location-offset location)) + '(:align t))) + +(defimplementation find-definitions (name) + (loop for kind in ext:*source-location-kinds* + for locations = (ext:source-location name kind) + when locations + nconc (loop for location in locations + collect (list kind (translate-location location))))) + +(defun source-location (object) + (let ((location (ext:source-location object t))) + (when location + (translate-location (car location))))) + +(defimplementation find-source-location (object) + (or (source-location object) + (make-error-location "Source definition of ~S not found." object))) + + +;;;; Profiling + +#+profile +(progn + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) +) ; #+profile (progn ... + + +;;;; Threads + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + + (defimplementation thread-id (target-thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + ;; Does TARGET-THREAD have an id already? + (maphash (lambda (id thread-pointer) + (let ((thread (si:weak-pointer-value thread-pointer))) + (cond ((not thread) + (remhash id *thread-id-map*)) + ((eq thread target-thread) + (return-from thread-id id))))) + *thread-id-map*) + ;; TARGET-THREAD not found in *THREAD-ID-MAP* + (let ((id (incf *thread-id-counter*)) + (thread-pointer (si:make-weak-pointer target-thread))) + (setf (gethash id *thread-id-map*) thread-pointer) + id)))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (let* ((thread-ptr (gethash id *thread-id-map*)) + (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) + (unless thread + (remhash id *thread-id-map*)) + thread))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (if (mp:process-active-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-lock :name name :recursive t)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mp:with-lock (lock) (funcall function))) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (mp:all-processes)) + + (defimplementation interrupt-thread (thread fn) + (mp:interrupt-process thread fn)) + + (defimplementation kill-thread (thread) + (mp:process-kill thread)) + + (defimplementation thread-alive-p (thread) + (mp:process-active-p thread)) + + (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mp:make-lock :name "SLIMELCK")) + (cvar (mp:make-condition-variable)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (format t "About to with-lock in wake-thread~%") + (mp:with-lock (mutex) + (format t "In wake-thread~%") + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (swank::log-event "clasp.lisp: send message ~a mutex: ~a~%" message mutex) + (swank::log-event "clasp.lisp: (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) + (swank::log-event "clasp.lisp: (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) + (mp:with-lock (mutex) + (swank::log-event "clasp.lisp: in with-lock (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) + (swank::log-event "clasp.lisp: in with-lock (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (swank::log-event "clasp.lisp: send about to broadcast~%") + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + + (defimplementation receive-if (test &optional timeout) + (slime-dbg "Entered receive-if") + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (slime-dbg "receive-if assert") + (assert (or (not timeout) (eq timeout t))) + (loop + (slime-dbg "receive-if check-slime-interrupts") + (check-slime-interrupts) + (slime-dbg "receive-if with-lock") + (mp:with-lock (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (slime-dbg "receive-if when (eq") + (when (eq timeout t) (return (values nil t))) + (slime-dbg "receive-if condition-variable-timedwait") + (mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2 + (slime-dbg "came out of condition-variable-timedwait") + (core:check-pending-interrupts))))) + + ) ; #+threads (progn ... + + +(defmethod emacs-inspect ((object core:cxx-object)) + (let ((encoded (core:encode object))) + (loop for (key . value) in encoded + append (list (string key) ": " (list :value value) (list :newline))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/clisp.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/clisp.lisp new file mode 100644 index 0000000..27ae688 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/clisp.lisp @@ -0,0 +1,930 @@ +;;;; -*- indent-tabs-mode: nil -*- + +;;;; SWANK support for CLISP. + +;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach + +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License as +;;;; published by the Free Software Foundation; either version 2 of +;;;; the License, or (at your option) any later version. + +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. + +;;;; You should have received a copy of the GNU General Public +;;;; License along with this program; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;;;; MA 02111-1307, USA. + +;;; This is work in progress, but it's already usable. Many things +;;; are adapted from other swank-*.lisp, in particular from +;;; swank-allegro (I don't use allegro at all, but it's the shortest +;;; one and I found Helmut Eller's code there enlightening). + +;;; This code will work better with recent versions of CLISP (say, the +;;; last release or CVS HEAD) while it may not work at all with older +;;; versions. It is reasonable to expect it to work on platforms with +;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like +;;; systems, but also on Win32. This backend uses the portable xref +;;; from the CMU AI repository and metering.lisp from CLOCC [1], which +;;; are conveniently included in SLIME. + +;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/ + +(defpackage swank/clisp + (:use cl swank/backend)) + +(in-package swank/clisp) + +(eval-when (:compile-toplevel) + (unless (string< "2.44" (lisp-implementation-version)) + (error "Need at least CLISP version 2.44"))) + +(defimplementation gray-package-name () + "GRAY") + +;;;; if this lisp has the complete CLOS then we use it, otherwise we +;;;; build up a "fake" swank-mop and then override the methods in the +;;;; inspector. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *have-mop* + (and (find-package :clos) + (eql :external + (nth-value 1 (find-symbol (string ':standard-slot-definition) + :clos)))) + "True in those CLISP images which have a complete MOP implementation.")) + +#+#.(cl:if swank/clisp::*have-mop* '(cl:and) '(cl:or)) +(progn + (import-swank-mop-symbols :clos '(:slot-definition-documentation)) + + (defun swank-mop:slot-definition-documentation (slot) + (clos::slot-definition-documentation slot))) + +#-#.(cl:if swank/clisp::*have-mop* '(and) '(or)) +(defclass swank-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that swank.lisp will compile and load.")) + +(let ((getpid (or (find-symbol "PROCESS-ID" :system) + ;; old name prior to 2005-03-01, clisp <= 2.33.2 + (find-symbol "PROGRAM-ID" :system) + #+win32 ; integrated into the above since 2005-02-24 + (and (find-package :win32) ; optional modules/win32 + (find-symbol "GetCurrentProcessId" :win32))))) + (defimplementation getpid () ; a required interface + (cond + (getpid (funcall getpid)) + #+win32 ((ext:getenv "PID")) ; where does that come from? + (t -1)))) + +(defimplementation call-with-user-break-handler (handler function) + (handler-bind ((system::simple-interrupt-condition + (lambda (c) + (declare (ignore c)) + (funcall handler) + (when (find-restart 'socket-status) + (invoke-restart (find-restart 'socket-status))) + (continue)))) + (funcall function))) + +(defimplementation lisp-implementation-type-name () + "clisp") + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) directory) + (namestring (setf *default-pathname-defaults* (ext:default-directory)))) + +(defimplementation filename-to-pathname (string) + (cond ((member :cygwin *features*) + (parse-cygwin-filename string)) + (t (parse-namestring string)))) + +(defun parse-cygwin-filename (string) + (multiple-value-bind (match _ drive absolute) + (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t) + (declare (ignore _)) + (assert (and match (if drive absolute t)) () + "Invalid filename syntax: ~a" string) + (let* ((sans-prefix (subseq string (regexp:match-end match))) + (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix))) + (path (loop for name in path collect + (cond ((equal name "..") ':back) + (t name)))) + (directoryp (or (equal string "") + (find (aref string (1- (length string))) "\\/")))) + (multiple-value-bind (file type) + (cond ((and (not directoryp) (last path)) + (let* ((file (car (last path))) + (pos (position #\. file :from-end t))) + (cond ((and pos (> pos 0)) + (values (subseq file 0 pos) + (subseq file (1+ pos)))) + (t file))))) + (make-pathname :host nil + :device nil + :directory (cons + (if absolute :absolute :relative) + (let ((path (if directoryp + path + (butlast path)))) + (if drive + (cons + (regexp:match-string string drive) + path) + path))) + :name file + :type type))))) + +;;;; UTF + +(defimplementation string-to-utf8 (string) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-to-bytes string enc))) + +(defimplementation utf8-to-string (octets) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-from-bytes octets enc))) + +;;;; TCP Server + +(defimplementation create-socket (host port &key backlog) + (socket:socket-server port :interface host :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (socket:socket-server-port socket)) + +(defimplementation close-socket (socket) + (socket:socket-server-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (socket:socket-accept socket + :buffered buffering ;; XXX may not work if t + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) + +#-win32 +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout + (socket:socket-status streams 0 0) + (return (loop for (s nil . x) in streams + if x collect s))) + (t + (with-simple-restart (socket-status "Return from socket-status.") + (socket:socket-status streams 0 500000)) + (let ((ready (loop for (s nil . x) in streams + if x collect s))) + (when ready (return ready)))))))) + +#+win32 +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (t + (let ((ready (remove-if-not #'input-available-p streams))) + (when ready (return ready))) + (when timeout (return nil)) + (sleep 0.1))))) + +#+win32 +;; Some facts to remember (for the next time we need to debug this): +;; - interactive-sream-p returns t for socket-streams +;; - listen returns nil for socket-streams +;; - (type-of ) is 'stream +;; - (type-of *terminal-io*) is 'two-way-stream +;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8) +;; - calling socket:socket-status on non sockets signals an error, +;; but seems to mess up something internally. +;; - calling read-char-no-hang on sockets does not signal an error, +;; but seems to mess up something internally. +(defun input-available-p (stream) + (case (stream-element-type stream) + (character + (let ((c (read-char-no-hang stream nil nil))) + (cond ((not c) + nil) + (t + (unread-char c stream) + t)))) + (t + (eq (socket:socket-status (cons stream :input) 0 0) + :input)))) + +;;;; Coding systems + +(defvar *external-format-to-coding-system* + '(((:charset "iso-8859-1" :line-terminator :unix) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ((:charset "iso-8859-1") + "latin-1" "iso-latin-1" "iso-8859-1") + ((:charset "utf-8") "utf-8") + ((:charset "utf-8" :line-terminator :unix) "utf-8-unix") + ((:charset "euc-jp") "euc-jp") + ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix") + ((:charset "us-ascii") "us-ascii") + ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((args (car (rassoc-if (lambda (x) + (member coding-system x :test #'equal)) + *external-format-to-coding-system*)))) + (and args (apply #'ext:make-encoding args)))) + + +;;;; Swank functions + +(defimplementation arglist (fname) + (block nil + (or (ignore-errors + (let ((exp (function-lambda-expression fname))) + (and exp (return (second exp))))) + (ignore-errors + (return (ext:arglist fname))) + :not-available))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (ext:expand-form form)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,form)))) + (values macro-forms nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result ())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push :variable (when (boundp symbol) (doc 'variable))) + (when (fboundp symbol) + (maybe-push + ;; Report WHEN etc. as macros, even though they may be + ;; implemented as special operators. + (if (macro-function symbol) :macro + (typecase (fdefinition symbol) + (generic-function :generic-function) + (function :function) + ;; (type-of 'progn) -> ext:special-operator + (t :special-operator))) + (doc 'function))) + (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt) + (get symbol 'system::setf-expander)); defsetf + (maybe-push :setf (doc 'setf))) + (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp + (get symbol 'system::defstruct-description) + (get symbol 'system::deftype-expander)) + (maybe-push :type (doc 'type))) ; even for 'structure + (when (find-class symbol nil) + (maybe-push :class (doc 'type))) + ;; Let this code work compiled in images without FFI + (let ((types (load-time-value + (and (find-package "FFI") + (symbol-value + (find-symbol "*C-TYPE-TABLE*" "FFI")))))) + ;; Use ffi::*c-type-table* so as not to suffer the overhead of + ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols + ;; which are not FFI type names. + (when (and types (nth-value 1 (gethash symbol types))) + ;; Maybe use (case (head (ffi:deparse-c-type))) + ;; to distinguish struct and union types? + (maybe-push :alien-type :not-documented))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable (describe symbol)) + (:macro (describe (macro-function symbol))) + (:function (describe (symbol-function symbol))) + (:class (describe (find-class symbol))))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defun fspec-pathname (spec) + (let ((path spec) + type + lines) + (when (consp path) + (psetq type (car path) + path (cadr path) + lines (cddr path))) + (when (and path + (member (pathname-type path) + custom:*compiled-file-types* :test #'equal)) + (setq path + (loop for suffix in custom:*source-file-types* + thereis (probe-file (make-pathname :defaults path + :type suffix))))) + (values path type lines))) + +(defun fspec-location (name fspec) + (multiple-value-bind (file type lines) + (fspec-pathname fspec) + (list (if type (list name type) name) + (cond (file + (multiple-value-bind (truename c) + (ignore-errors (truename file)) + (cond (truename + (make-location + (list :file (namestring truename)) + (if (consp lines) + (list* :line lines) + (list :function-name (string name))) + (when (consp type) + (list :snippet (format nil "~A" type))))) + (t (list :error (princ-to-string c)))))) + (t (list :error + (format nil "No source information available for: ~S" + fspec))))))) + +(defimplementation find-definitions (name) + (mapcar #'(lambda (e) (fspec-location name e)) + (documentation name 'sys::file))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defvar *sldb-backtrace*) + +(defun sldb-backtrace () + "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." + (let* ((modes '((:all-stack-elements 1) + (:all-frames 2) + (:only-lexical-frames 3) + (:only-eval-and-apply-frames 4) + (:only-apply-frames 5))) + (mode (cadr (assoc :all-stack-elements modes)))) + (do ((frames '()) + (last nil frame) + (frame (sys::the-frame) + (sys::frame-up 1 frame mode))) + ((eq frame last) (nreverse frames)) + (unless (boring-frame-p frame) + (push frame frames))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(sys::*break-count* (1+ sys::*break-count*)) + ;;(sys::*driver* debugger-loop-fn) + ;;(sys::*fasoutput-stream* nil) + (*sldb-backtrace* + (let* ((f (sys::the-frame)) + (bt (sldb-backtrace)) + (rest (member f bt))) + (if rest (nthcdr 8 rest) bt)))) + (funcall debugger-loop-fn))) + +(defun nth-frame (index) + (nth index *sldb-backtrace*)) + +(defun boring-frame-p (frame) + (member (frame-type frame) '(stack-value bind-var bind-env + compiled-tagbody compiled-block))) + +(defun frame-to-string (frame) + (with-output-to-string (s) + (sys::describe-frame s frame))) + +(defun frame-type (frame) + ;; FIXME: should bind *print-length* etc. to small values. + (frame-string-type (frame-to-string frame))) + +;; FIXME: they changed the layout in 2.44 and not all patterns have +;; been updated. +(defvar *frame-prefixes* + '(("\\[[0-9]\\+\\] frame binding variables" bind-var) + ("<1> # # # " fun) + ("<2> " 2nd-frame) + )) + +(defun frame-string-type (string) + (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string)) + *frame-prefixes*))) + +(defimplementation compute-backtrace (start end) + (let* ((bt *sldb-backtrace*) + (len (length bt))) + (loop for f in (subseq bt start (min (or end len) len)) + collect f))) + +(defimplementation print-frame (frame stream) + (let* ((str (frame-to-string frame))) + (write-string (extract-frame-line str) + stream))) + +(defun extract-frame-line (frame-string) + (let ((s frame-string)) + (trim-whitespace + (case (frame-string-type s) + ((eval special-op) + (string-match "EVAL frame .*for form \\(.*\\)" s 1)) + (apply + (string-match "APPLY frame for call \\(.*\\)" s 1)) + ((compiled-fun sys-fun fun) + (extract-function-name s)) + (t s))))) + +(defun extract-function-name (string) + (let ((1st (car (split-frame-string string)))) + (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>") + 1st + 1) + (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1) + 1st))) + +(defun split-frame-string (string) + (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)" + (mapcar #'car *frame-prefixes*)))) + (loop for pos = 0 then (1+ (regexp:match-start match)) + for match = (regexp:match rx string :start pos) + if match collect (subseq string pos (regexp:match-start match)) + else collect (subseq string pos) + while match))) + +(defun string-match (pattern string n) + (let* ((match (nth-value n (regexp:match pattern string)))) + (if match (regexp:match-string string match)))) + +(defimplementation eval-in-frame (form frame-number) + (sys::eval-at (nth-frame frame-number) form)) + +(defimplementation frame-locals (frame-number) + (let ((frame (nth-frame frame-number))) + (loop for i below (%frame-count-vars frame) + collect (list :name (%frame-var-name frame i) + :value (%frame-var-value frame i) + :id 0)))) + +(defimplementation frame-var-value (frame var) + (%frame-var-value (nth-frame frame) var)) + +;;; Interpreter-Variablen-Environment has the shape +;;; NIL or #(v1 val1 ... vn valn NEXT-ENV). + +(defun %frame-count-vars (frame) + (cond ((sys::eval-frame-p frame) + (do ((venv (frame-venv frame) (next-venv venv)) + (count 0 (+ count (/ (1- (length venv)) 2)))) + ((not venv) count))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (length (%parse-stack-values frame))) + (t 0))) + +(defun %frame-var-name (frame i) + (cond ((sys::eval-frame-p frame) + (nth-value 0 (venv-ref (frame-venv frame) i))) + (t (format nil "~D" i)))) + +(defun %frame-var-value (frame i) + (cond ((sys::eval-frame-p frame) + (let ((name (venv-ref (frame-venv frame) i))) + (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name)) + (if c + (format-sldb-condition c) + v)))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (let ((str (nth i (%parse-stack-values frame)))) + (trim-whitespace (subseq str 2)))) + (t (break "Not implemented")))) + +(defun frame-venv (frame) + (let ((env (sys::eval-at frame '(sys::the-environment)))) + (svref env 0))) + +(defun next-venv (venv) (svref venv (1- (length venv)))) + +(defun venv-ref (env i) + "Reference the Ith binding in ENV. +Return two values: NAME and VALUE" + (let ((idx (* i 2))) + (if (< idx (1- (length env))) + (values (svref env idx) (svref env (1+ idx))) + (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) + +(defun %parse-stack-values (frame) + (labels ((next (fp) (sys::frame-down 1 fp 1)) + (parse (fp accu) + (let ((str (frame-to-string fp))) + (cond ((is-prefix-p "- " str) + (parse (next fp) (cons str accu))) + ((is-prefix-p "<1> " str) + ;;(when (eq (frame-type frame) 'compiled-fun) + ;; (pop accu)) + (dolist (str (cdr (split-frame-string str))) + (when (is-prefix-p "- " str) + (push str accu))) + (nreverse accu)) + (t (parse (next fp) accu)))))) + (parse (next frame) '()))) + +(defun is-prefix-p (regexp string) + (if (regexp:match (concatenate 'string "^" regexp) string) t)) + +(defimplementation return-from-frame (index form) + (sys::return-from-eval-frame (nth-frame index) form)) + +(defimplementation restart-frame (index) + (sys::redo-eval-frame (nth-frame index))) + +(defimplementation frame-source-location (index) + `(:error + ,(format nil "frame-source-location not implemented. (frame: ~A)" + (nth-frame index)))) + +;;;; Profiling + +(defimplementation profile (fname) + (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + swank-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (swank-monitor:unmonitor)) + +(defimplementation profile-report () + (swank-monitor:report-monitoring)) + +(defimplementation profile-reset () + (swank-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (swank-monitor:monitor-all package)) + +;;;; Handle compiler conditions (find out location of error etc.) + +(defmacro compile-file-frobbing-notes ((&rest args) &body body) + "Pass ARGS to COMPILE-FILE, send the compiler notes to +*STANDARD-INPUT* and frob them in BODY." + `(let ((*error-output* (make-string-output-stream)) + (*compile-verbose* t)) + (multiple-value-prog1 + (compile-file ,@args) + (handler-case + (with-input-from-string + (*standard-input* (get-output-stream-string *error-output*)) + ,@body) + (sys::simple-end-of-file () nil))))) + +(defvar *orig-c-warn* (symbol-function 'system::c-warn)) +(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn)) +(defvar *orig-c-error* (symbol-function 'system::c-error)) +(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems)) + +(defmacro dynamic-flet (names-functions &body body) + "(dynamic-flet ((NAME FUNCTION) ...) BODY ...) +Execute BODY with NAME's function slot set to FUNCTION." + `(ext:letf* ,(loop for (name function) in names-functions + collect `((symbol-function ',name) ,function)) + ,@body)) + +(defvar *buffer-name* nil) +(defvar *buffer-offset*) + +(defun compiler-note-location () + "Return the current compiler location." + (let ((lineno1 sys::*compile-file-lineno1*) + (lineno2 sys::*compile-file-lineno2*) + (file sys::*compile-file-truename*)) + (cond ((and file lineno1 lineno2) + (make-location (list ':file (namestring file)) + (list ':line lineno1))) + (*buffer-name* + (make-location (list ':buffer *buffer-name*) + (list ':offset *buffer-offset* 0))) + (t + (list :error "No error location available"))))) + +(defun signal-compiler-warning (cstring args severity orig-fn) + (signal 'compiler-condition + :severity severity + :message (apply #'format nil cstring args) + :location (compiler-note-location)) + (apply orig-fn cstring args)) + +(defun c-warn (cstring &rest args) + (signal-compiler-warning cstring args :warning *orig-c-warn*)) + +(defun c-style-warn (cstring &rest args) + (dynamic-flet ((sys::c-warn *orig-c-warn*)) + (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*))) + +(defun c-error (&rest args) + (signal 'compiler-condition + :severity :error + :message (apply #'format nil + (if (= (length args) 3) + (cdr args) + args)) + :location (compiler-note-location)) + (apply *orig-c-error* args)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-notification-condition)) + (dynamic-flet ((system::c-warn #'c-warn) + (system::c-style-warn #'c-style-warn) + (system::c-error #'c-error)) + (funcall function)))) + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (signal 'compiler-condition + :original-condition condition + :severity :warning + :message (princ-to-string condition) + :location (compiler-note-location))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (with-compilation-unit () + (multiple-value-bind (fasl-file warningsp failurep) + (compile-file input-file + :output-file output-file + :external-format external-format) + (values fasl-file warningsp + (or failurep + (and load-p + (not (load fasl-file))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-offset* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t))) + +;;;; Portable XREF from the CMU AI repository. + +(setq pxref::*handle-package-forms* '(cl:in-package)) + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls pxref:list-callers) +(defxref who-references pxref:list-readers) +(defxref who-binds pxref:list-setters) +(defxref who-sets pxref:list-setters) +(defxref list-callers pxref:list-callers) +(defxref list-callees pxref:list-callees) + +(defun xref-results (symbols) + (let ((xrefs '())) + (dolist (symbol symbols) + (push (fspec-location symbol symbol) xrefs)) + xrefs)) + +(when (find-package :swank-loader) + (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader)) + (lambda () + (let ((home (user-homedir-pathname))) + (and (ext:probe-directory home) + (probe-file (format nil "~A/.swank.lisp" + (namestring (truename home))))))))) + +;;; Don't set *debugger-hook* to nil on break. +(ext:without-package-lock () + (defun break (&optional (format-string "Break") &rest args) + (if (not sys::*use-clcs*) + (progn + (terpri *error-output*) + (apply #'format *error-output* + (concatenate 'string "*** - " format-string) + args) + (funcall ext:*break-driver* t)) + (let ((condition + (make-condition 'simple-condition + :format-control format-string + :format-arguments args)) + ;;(*debugger-hook* nil) + ;; Issue 91 + ) + (ext:with-restarts + ((continue + :report (lambda (stream) + (format stream (sys::text "Return from ~S loop") + 'break)) + ())) + (with-condition-restarts condition (list (find-restart 'continue)) + (invoke-debugger condition))))) + nil)) + +;;;; Inspecting + +(defmethod emacs-inspect ((o t)) + (let* ((*print-array* nil) (*print-pretty* t) + (*print-circle* t) (*print-escape* t) + (*print-lines* custom:*inspect-print-lines*) + (*print-level* custom:*inspect-print-level*) + (*print-length* custom:*inspect-print-length*) + (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) + (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) + (*package* tmp-pack) + (sys::*inspect-unbound-value* (intern "#" tmp-pack))) + (let ((inspection (sys::inspect-backend o))) + (append (list + (format nil "~S~% ~A~{~%~A~}~%" o + (sys::insp-title inspection) + (sys::insp-blurb inspection))) + (loop with count = (sys::insp-num-slots inspection) + for i below count + append (multiple-value-bind (value name) + (funcall (sys::insp-nth-slot inspection) + i) + `((:value ,name) " = " (:value ,value) + (:newline)))))))) + +(defimplementation quit-lisp () + #+lisp=cl (ext:quit) + #-lisp=cl (lisp:quit)) + + +(defimplementation preferred-communication-style () + nil) + +;;; FIXME +;;; +;;; Clisp 2.48 added experimental support for threads. Basically, you +;;; can use :SPAWN now, BUT: +;;; +;;; - there are problems with GC, and threads stuffed into weak +;;; hash-tables as is the case for *THREAD-PLIST-TABLE*. +;;; +;;; See test case at +;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429 +;;; +;;; Even though said to be fixed, it's not: +;;; +;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443 +;;; +;;; - The DYNAMIC-FLET above is an implementation technique that's +;;; probably not sustainable in light of threads. This got to be +;;; rewritten. +;;; +;;; TCR (2009-07-30) + +#+#.(cl:if (cl:find-package "MP") '(:and) '(:or)) +(progn + (defimplementation spawn (fn &key name) + (mp:make-thread fn :name name)) + + (defvar *thread-plist-table-lock* + (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK")) + + (defvar *thread-plist-table* (make-hash-table :weak :key) + "A hashtable mapping threads to a plist.") + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (mp:with-mutex-lock (*thread-plist-table-lock*) + (or (getf (gethash thread *thread-plist-table*) 'thread-id) + (setf (getf (gethash thread *thread-plist-table*) 'thread-id) + (incf *thread-id-counter*))))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-plist-table*) 'thread-id)))) + + (defimplementation thread-name (thread) + ;; To guard against returning #. + (princ-to-string (mp:thread-name thread))) + + (defimplementation thread-status (thread) + (if (thread-alive-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-mutex :name name :recursive-p t)) + + (defimplementation call-with-lock-held (lock function) + (mp:with-mutex-lock (lock) + (funcall function))) + + (defimplementation current-thread () + (mp:current-thread)) + + (defimplementation all-threads () + (mp:list-threads)) + + (defimplementation interrupt-thread (thread fn) + (mp:thread-interrupt thread :function fn)) + + (defimplementation kill-thread (thread) + (mp:thread-interrupt thread :function t)) + + (defimplementation thread-alive-p (thread) + (mp:thread-active-p thread)) + + (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK")) + (defvar *mailboxes* (list)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-lock :name "MAILBOX.LOCK")) + (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-mutex-lock (*mailboxes-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (lock (mailbox.lock mbox))) + (mp:with-mutex-lock (lock) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:exemption-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (lock (mailbox.lock mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-mutex-lock (lock) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2)))))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation save-image (filename &optional restart-function) + (let ((args `(,filename + ,@(if restart-function + `((:init-function ,restart-function)))))) + (apply #'ext:saveinitmem args))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/cmucl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/cmucl.lisp new file mode 100644 index 0000000..12d4282 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/cmucl.lisp @@ -0,0 +1,2470 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; License: Public Domain +;;; +;;;; Introduction +;;; +;;; This is the CMUCL implementation of the `swank/backend' package. + +(defpackage swank/cmucl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache + fwrappers)) + +(in-package swank/cmucl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (let ((min-version #x20c)) + (assert (>= c:byte-fasl-file-version min-version) + () "This file requires CMUCL version ~x or newer" min-version)) + + (require 'gray-streams)) + + +(import-swank-mop-symbols :pcl '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +;;; UTF8 + +(locally (declare (optimize (ext:inhibit-warnings 3))) + ;; Compile and load the utf8 format, if not already loaded. + (stream::find-external-format :utf-8)) + +(defimplementation string-to-utf8 (string) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:string-to-octets string :external-format ef))) + +(defimplementation utf8-to-string (octets) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:octets-to-string octets :external-format ef))) + + +;;;; TCP server +;;; +;;; In CMUCL we support all communication styles. By default we use +;;; `:SIGIO' because it is the most responsive, but it's somewhat +;;; dangerous: CMUCL is not in general "signal safe", and you don't +;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and +;;; `:SPAWN' are reasonable alternatives. + +(defimplementation preferred-communication-style () + :sigio) + +#-(or darwin mips) +(defimplementation create-socket (host port &key backlog) + (let* ((addr (resolve-hostname host)) + (addr (if (not (find-symbol "SOCKET-ERROR" :ext)) + (ext:htonl addr) + addr))) + (ext:create-inet-listener port :stream :reuse-address t :host addr + :backlog (or backlog 5)))) + +;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix. +#+(or darwin mips) +(defimplementation create-socket (host port &key backlog) + (declare (ignore host)) + (ext:create-inet-listener port :stream :reuse-address t)) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (let ((fd (socket-fd socket))) + (sys:invalidate-descriptor fd) + (ext:close-socket fd))) + +(defimplementation accept-connection (socket &key + external-format buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (ext:accept-tcp-connection socket) + (ecase buffering + ((t) :full) + (:line :line) + ((nil) :none)) + external-format)) + +;;;;; Sockets + +(defimplementation socket-fd (socket) + "Return the filedescriptor for the socket represented by SOCKET." + (etypecase socket + (fixnum socket) + (sys:fd-stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of HOSTNAME as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 "iso-latin-1-unix") + #+unicode + (:utf-8 "utf-8-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd buffering external-format) + "Create a new input/output fd-stream for FD." + (cond (external-format + (sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering buffering + :external-format external-format)) + (t + (sys:make-fd-stream fd :input t :output t + :element-type '(unsigned-byte 8) + :buffering buffering)))) + +(defimplementation make-fd-stream (fd external-format) + (make-socket-io-stream fd :full external-format)) + +(defimplementation dup (fd) + (multiple-value-bind (clone error) (unix:unix-dup fd) + (unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error))) + clone)) + +(defimplementation command-line-args () + ext:*command-line-strings*) + +(defimplementation exec-image (image-file args) + (multiple-value-bind (ok error) + (unix:unix-execve (car (command-line-args)) + (list* (car (command-line-args)) + "-core" image-file + "-noinit" + args)) + (error "~a" (unix:get-unix-error-msg error)) + ok)) + +;;;;; Signal-driven I/O + +(defimplementation install-sigint-handler (function) + (sys:enable-interrupt :sigint (lambda (signal code scp) + (declare (ignore signal code scp)) + (funcall function)))) + +(defvar *sigio-handlers* '() + "List of (key . function) pairs. +All functions are called on SIGIO, and the key is used for removing +specific functions.") + +(defun reset-sigio-handlers () (setq *sigio-handlers* '())) +;; All file handlers are invalid afer reload. +(pushnew 'reset-sigio-handlers ext:*after-save-initializations*) + +(defun set-sigio-handler () + (sys:enable-interrupt :sigio (lambda (signal code scp) + (sigio-handler signal code scp)))) + +(defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (mapc #'funcall (mapcar #'cdr *sigio-handlers*))) + +(defun fcntl (fd command arg) + "fcntl(2) - manipulate a file descriptor." + (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg) + (cond (ok) + (t (error "fcntl: ~A" (unix:get-unix-error-msg error)))))) + +(defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (fcntl fd unix:f-setown (unix:unix-getpid)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logior old-flags unix:fasync))) + (assert (not (assoc fd *sigio-handlers*))) + (push (cons fd fn) *sigio-handlers*))) + +(defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (when (assoc fd *sigio-handlers*) + (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync))) + (sys:invalidate-descriptor fd)) + (assert (not (assoc fd *sigio-handlers*))) + (when (null *sigio-handlers*) + (sys:default-interrupt :sigio)))) + +;;;;; SERVE-EVENT + +(defimplementation add-fd-handler (socket fn) + (let ((fd (socket-fd socket))) + (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn))))) + +(defimplementation remove-fd-handlers (socket) + (sys:invalidate-descriptor (socket-fd socket))) + +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (let ((ready (remove-if-not #'listen streams))) + (when ready (return ready))) + (when timeout (return nil)) + (multiple-value-bind (in out) (make-pipe) + (let* ((f (constantly t)) + (handlers (loop for s in (cons in (mapcar #'to-fd-stream streams)) + collect (add-one-shot-handler s f)))) + (unwind-protect + (let ((*interrupt-queued-handler* (lambda () + (write-char #\! out)))) + (when (check-slime-interrupts) (return :interrupt)) + (sys:serve-event)) + (mapc #'sys:remove-fd-handler handlers) + (close in) + (close out)))))) + +(defun to-fd-stream (stream) + (etypecase stream + (sys:fd-stream stream) + (synonym-stream + (to-fd-stream + (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (to-fd-stream (two-way-stream-input-stream stream))))) + +(defun add-one-shot-handler (stream function) + (let (handler) + (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input + (lambda (fd) + (declare (ignore fd)) + (sys:remove-fd-handler handler) + (funcall function stream)))))) + +(defun make-pipe () + (multiple-value-bind (in out) (unix:unix-pipe) + (values (sys:make-fd-stream in :input t :buffering :none) + (sys:make-fd-stream out :output t :buffering :none)))) + + +;;;; Stream handling + +(defimplementation gray-package-name () + "EXT") + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. +NIL if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (clear-xref-info input-file) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file input-file :output-file output-file + :external-format external-format) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string) + (source-info (list :emacs-buffer buffer + :emacs-buffer-offset position + :emacs-buffer-string string))) + (with-input-from-string (stream string) + (let ((failurep (ext:compile-from-stream stream :source-info + source-info))) + (not failurep)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `SWANK:COMPILER-CONDITION's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (compiler-condition-message condition) + :source-context (compiler-error-context context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context)))) + +(defun severity-for-emacs (condition) + "Return the severity of CONDITION." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun compiler-condition-message (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (princ-to-string condition)) + +(defun compiler-error-context (error-context) + "Describe context information for Emacs." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (if (or enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A ~>~}~%~]~ + ~@[==>~{~&~A~}~]" + enclosing source)))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. +Return a `location' record, or (:error REASON) on failure." + (if (null context) + (note-error-location) + (with-struct (c::compiler-error-context- file-name + original-source + original-source-path) context + (or (locate-compiler-note file-name original-source + (reverse original-source-path)) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (cond (*compile-file-truename* + (make-location (list :file (unix-truename *compile-file-truename*)) + (list :eof))) + (*buffer-name* + (make-location (list :buffer *buffer-name*) + (list :position *buffer-start-position*))) + (t (list :error "No error location available.")))) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + +;;;; XREF +;;; +;;; Cross-reference support is based on the standard CMUCL `XREF' +;;; package. This package has some caveats: XREF information is +;;; recorded during compilation and not preserved in fasl files, and +;;; XREF recording is disabled by default. Redefining functions can +;;; also cause duplicate references to accumulate, but +;;; `swank-compile-file' will automatically clear out any old records +;;; from the same filename. +;;; +;;; To enable XREF recording, set `c:*record-xref-info*' to true. To +;;; clear out the XREF database call `xref:init-xref-database'. + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls xref:who-calls) +(defxref who-references xref:who-references) +(defxref who-binds xref:who-binds) +(defxref who-sets xref:who-sets) + +;;; More types of XREF information were added since 18e: +;;; + +(defxref who-macroexpands xref:who-macroexpands) +;; XXX +(defimplementation who-specializes (symbol) + (let* ((methods (xref::who-specializes (find-class symbol))) + (locations (mapcar #'method-location methods))) + (mapcar #'list methods locations))) + +(defun xref-results (contexts) + (mapcar (lambda (xref) + (list (xref:xref-context-name xref) + (resolve-xref-location xref))) + contexts)) + +(defun resolve-xref-location (xref) + (let ((name (xref:xref-context-name xref)) + (file (xref:xref-context-file xref)) + (source-path (xref:xref-context-source-path xref))) + (cond ((and file source-path) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (unix-truename file)) + (list :position (1+ position))))) + (file + (make-location (list :file (unix-truename file)) + (list :function-name (string name)))) + (t + `(:error ,(format nil "Unknown source location: ~S ~S ~S " + name file source-path)))))) + +(defun clear-xref-info (namestring) + "Clear XREF notes pertaining to NAMESTRING. +This is a workaround for a CMUCL bug: XREF records are cumulative." + (when c:*record-xref-info* + (let ((filename (truename namestring))) + (dolist (db (list xref::*who-calls* + xref::*who-is-called* + xref::*who-macroexpands* + xref::*who-references* + xref::*who-binds* + xref::*who-sets*)) + (maphash (lambda (target contexts) + ;; XXX update during traversal? + (setf (gethash target db) + (delete filename contexts + :key #'xref:xref-context-file + :test #'equalp))) + db))))) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t)) + (map-cpool (code fun) + (declare (type kernel:code-component code) (type function fun)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data code) + do (funcall fun (kernel:code-header-ref code i)))) + + (callees (fun) + (let ((callees (make-stack))) + (map-cpool (vm::find-code-object fun) + (lambda (o) + (when (kernel:fdefn-p o) + (vector-push-extend (kernel:fdefn-function o) + callees)))) + (coerce callees 'list))) + + (callers (fun) + (declare (function fun)) + (let ((callers (make-stack))) + (ext:gc :full t) + ;; scan :dynamic first to avoid the need for even more gcing + (dolist (space '(:dynamic :read-only :static)) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum header) (ignore size)) + (when (= vm:code-header-type header) + (map-cpool obj + (lambda (c) + (when (and (kernel:fdefn-p c) + (eq (kernel:fdefn-function c) fun)) + (vector-push-extend obj callers)))))) + space) + (ext:gc)) + (coerce callers 'list))) + + (entry-points (code) + (loop for entry = (kernel:%code-entry-points code) + then (kernel::%function-next entry) + while entry + collect entry)) + + (guess-main-entry-point (entry-points) + (or (find-if (lambda (fun) + (ext:valid-function-name-p + (kernel:%function-name fun))) + entry-points) + (car entry-points))) + + (fun-dspec (fun) + (list (kernel:%function-name fun) (function-location fun))) + + (code-dspec (code) + (let ((eps (entry-points code)) + (di (kernel:%code-debug-info code))) + (cond (eps (fun-dspec (guess-main-entry-point eps))) + (di (list (c::debug-info-name di) + (debug-info-function-name-location di))) + (t (list (princ-to-string code) + `(:error "No src-loc available"))))))) + (declare (inline map-cpool)) + + (defimplementation list-callers (symbol) + (mapcar #'code-dspec (callers (coerce symbol 'function) ))) + + (defimplementation list-callees (symbol) + (mapcar #'fun-dspec (callees symbol)))) + +(defun test-list-callers (count) + (let ((funsyms '())) + (do-all-symbols (s) + (when (and (fboundp s) + (functionp (symbol-function s)) + (not (macro-function s)) + (not (special-operator-p s))) + (push s funsyms))) + (let ((len (length funsyms))) + (dotimes (i count) + (let ((sym (nth (random len) funsyms))) + (format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym)))))))) + +;; (test-list-callers 100) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the CMUCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. +This is useful when debugging the definition-finding code.") + +(defmacro safe-definition-finding (&body body) + "Execute BODY and return the source-location it returns. +If an error occurs and `*debug-definition-finding*' is false, then +return an error pseudo-location. + +The second return value is NIL if no error occurs, otherwise it is the +condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values `(:error ,(trim-whitespace (princ-to-string c))) + c)))))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for CODE-LOCATION." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for CODE-LOCATION in FILENAME." + (let* ((code-date (di:debug-source-created debug-source)) + (root-number (di:debug-source-root-number debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s root-number))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a CODE-LOCATION from a stream. +This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :offset (getf info :emacs-buffer-offset) position) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for DEBUG-INFO. +Function-name source-locations are a fallback for when precise +positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location? +This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream root) + "Return the byte offset of CODE-LOCATION in STREAM. Extract the +toplevel-form-number and form-number from CODE-LOCATION and use that +to find the position of the corresponding form. + +Finish with STREAM positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (- (di:code-location-top-level-form-offset location) + root)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in STREAM. +TLF-NUMBER is the top-level-form number. +FORM-NUMBER is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of CODE-LOCATION in STRING. +See CODE-LOCATION-STREAM-POSITION." + (with-input-from-string (s string) + (code-location-stream-position code-location s 0))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name) + (template-definitions name) + (primitive-definitions name) + (vm-support-routine-definitions name) + )) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; CMUCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the CMUCL manual for more details. + +(defun function-definitions (name) + "Return definitions for NAME in the \"function namespace\", i.e., +regular functions, generic functions, methods and macros. +NAME can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (function? (and (ext:valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (gf-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for FUNCTION." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + +(defun byte-function-location (fun) + "Return the location of the byte-compiled function FUN." + (etypecase fun + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((di (kernel:%code-debug-info (c::byte-function-component fun)))) + (if di + (debug-info-function-name-location di) + `(:error + ,(format nil "Byte-function without debug-info: ~a" fun))))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fun))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is FUNCTION a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that FUNCTION belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + (let ((ctor (struct-constructor dd))) + (cond (ctor + (function-location (coerce ctor 'function))) + (t + (let ((name (kernel:dd-name dd))) + (multiple-value-bind (location foundp) + (ext:info :source-location :defvar name) + (cond (foundp + (resolve-source-location location)) + (t + (error "No location for defstruct: ~S" name))))))))) + +(defun struct-constructor (dd) + "Return the name of the constructor from a defstruct definition." + (let* ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (if (consp constructor) (car constructor) constructor))) + +;;;;;; Generic functions and methods + +(defun gf-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (pcl::generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (pcl::generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (pcl:method-generic-function method)) + (name (pcl:generic-function-name gf)) + (specializers (pcl:method-specializers method)) + (qualifiers (pcl:method-qualifiers method))) + `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers)))) + +(defun method-location (method) + (typecase method + (pcl::standard-accessor-method + (definition-source-location + (cond ((pcl::definition-source method) + method) + (t + (pcl::slot-definition-class + (pcl::accessor-method-slot-definition method)))) + (pcl::accessor-method-slot-name method))) + (t + (function-location (or (pcl::method-fast-function method) + (pcl:method-function method)))))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (kernel::find-class name nil))) + (etypecase class + (null '()) + (kernel::structure-class + (list (list `(defstruct ,name) (dd-location (find-dd name))))) + #+(or) + (conditions::condition-class + (list (list `(define-condition ,name) + (condition-class-location class)))) + (kernel::standard-class + (list (list `(defclass ,name) + (pcl-class-location (find-class name))))) + ((or kernel::built-in-class + conditions::condition-class + kernel:funcallable-structure-class) + (list (list `(class ,name) (class-location class)))))))) + +(defun pcl-class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (pcl:class-name class))) + +;; FIXME: eval used for backward compatibility. +(defun class-location (class) + (declare (type kernel::class class)) + (let ((name (kernel:%class-name class))) + (multiple-value-bind (loc found?) + (let ((x (ignore-errors + (multiple-value-list + (eval `(ext:info :source-location :class ',name)))))) + (values-list x)) + (cond (found? (resolve-source-location loc)) + (`(:error + ,(format nil "No location recorded for class: ~S" name))))))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((slots (conditions::condition-class-slots class)) + (name (conditions::condition-class-name class))) + (cond ((null slots) + `(:error ,(format nil "No location info for condition: ~A" name))) + (t + ;; Find the class via one of its slot-reader methods. + (let* ((slot (first slots)) + (gf (fdefinition + (first (conditions::condition-slot-readers slot))))) + (method-location + (first + (pcl:compute-applicable-methods-using-classes + gf (list (find-class name)))))))))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun source-location-form-numbers (location) + (c::decode-form-numbers (c::form-numbers-form-numbers location))) + +(defun source-location-tlf-number (location) + (nth-value 0 (source-location-form-numbers location))) + +(defun source-location-form-number (location) + (nth-value 1 (source-location-form-numbers location))) + +(defun resolve-file-source-location (location) + (let ((filename (c::file-source-location-pathname location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + (with-open-file (s filename) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:file ,(unix-truename filename)) + `(:position ,(1+ pos))))))) + +(defun resolve-stream-source-location (location) + (let ((info (c::stream-source-location-user-info location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + ;; XXX duplication in frame-source-location + (assert (info-from-emacs-buffer-p info)) + (destructuring-bind (&key emacs-buffer emacs-buffer-string + emacs-buffer-offset) info + (with-input-from-string (s emacs-buffer-string) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:buffer ,emacs-buffer) + `(:offset ,emacs-buffer-offset ,pos))))))) + +;; XXX predicates for 18e backward compatibilty. Remove them when +;; we're 19a only. +(defun file-source-location-p (object) + (when (fboundp 'c::file-source-location-p) + (c::file-source-location-p object))) + +(defun stream-source-location-p (object) + (when (fboundp 'c::stream-source-location-p) + (c::stream-source-location-p object))) + +(defun source-location-p (object) + (or (file-source-location-p object) + (stream-source-location-p object))) + +(defun resolve-source-location (location) + (etypecase location + ((satisfies file-source-location-p) + (resolve-file-source-location location)) + ((satisfies stream-source-location-p) + (resolve-stream-source-location location)))) + +(defun definition-source-location (object name) + (let ((source (pcl::definition-source object))) + (etypecase source + (null + `(:error ,(format nil "No source info for: ~A" object))) + ((satisfies source-location-p) + (resolve-source-location source)) + (pathname + (make-name-in-file-location source name)) + (cons + (destructuring-bind ((dg name) pathname) source + (declare (ignore dg)) + (etypecase pathname + (pathname (make-name-in-file-location pathname (string name))) + (null `(:error ,(format nil "Cannot resolve: ~S" source))))))))) + +(defun setf-definitions (name) + (let ((f (or (ext:info :setf :inverse name) + (ext:info :setf :expander name) + (and (symbolp name) + (fboundp `(setf ,name)) + (fdefinition `(setf ,name)))))) + (if f + `(((setf ,name) ,(function-location (cond ((functionp f) f) + ((macro-function f)) + ((fdefinition f))))))))) + +(defun variable-location (symbol) + (multiple-value-bind (location foundp) + ;; XXX for 18e compatibilty. rewrite this when we drop 18e + ;; support. + (ignore-errors (eval `(ext:info :source-location :defvar ',symbol))) + (if (and foundp location) + (resolve-source-location location) + `(:error ,(format nil "No source info for variable ~S" symbol))))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(,(type-of template) + ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + +(defun template-definitions (name) + (let* ((templates (c::backend-template-names c::*backend*)) + (template (gethash name templates))) + (etypecase template + (null) + (c::vop-info + (maybe-make-definition (c::vop-info-generator-function template) + (type-of template) name))))) + +;; for cases like: (%primitive NAME ...) +(defun primitive-definitions (name) + (let ((csym (find-symbol (string name) 'c))) + (and csym + (not (eq csym name)) + (template-definitions csym)))) + +(defun vm-support-routine-definitions (name) + (let ((sr (c::backend-support-routines c::*backend*)) + (name (find-symbol (string name) 'c))) + (and name + (slot-exists-p sr name) + (maybe-make-definition (slot-value sr name) + (find-symbol (string 'vm-support-routine) 'c) + name)))) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unkown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (etypecase fun + (function (function-arglist fun)) + (symbol (function-arglist (or (macro-function fun) + (symbol-function fun)))))) + +(defun function-arglist (fun) + (let ((arglist + (cond ((eval:interpreted-function-p fun) + (eval:interpreted-function-arglist fun)) + ((pcl::generic-function-p fun) + (pcl:generic-function-lambda-list fun)) + ((c::byte-function-or-closure-p fun) + (byte-code-function-arglist fun)) + ((kernel:%function-arglist (kernel:%function-self fun)) + (handler-case (read-arglist fun) + (error () :not-available))) + ;; this should work both for compiled-debug-function + ;; and for interpreted-debug-function + (t + (handler-case (debug-function-arglist + (di::function-debug-function fun)) + (di:unhandled-condition () :not-available)))))) + (check-type arglist (or list (member :not-available))) + arglist)) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((pcl::generic-function-p function) + (pcl::generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + +;;; A simple case: the arglist is available as a string that we can +;;; `read'. + +(defun read-arglist (fn) + "Parse the arglist-string of the function object FN." + (let ((string (kernel:%function-arglist + (kernel:%function-self fn))) + (package (find-package + (c::compiled-debug-info-package + (kernel:%code-debug-info + (vm::find-code-object fn)))))) + (with-standard-io-syntax + (let ((*package* (or package *package*))) + (read-from-string string))))) + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. +A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + +;;; Deriving arglists for byte-compiled functions: +;;; +(defun byte-code-function-arglist (fn) + ;; There doesn't seem to be much arglist information around for + ;; byte-code functions. Use the arg-count and return something like + ;; (arg0 arg1 ...) + (etypecase fn + (c::simple-byte-function + (loop for i from 0 below (c::simple-byte-function-num-args fn) + collect (make-arg-symbol i))) + (c::hairy-byte-function + (hairy-byte-function-arglist fn)) + (c::byte-closure + (byte-code-function-arglist (c::byte-closure-function fn))))) + +(defun make-arg-symbol (i) + (make-symbol (format nil "~A~D" (string 'arg) i))) + +;;; A "hairy" byte-function is one that takes a variable number of +;;; arguments. `hairy-byte-function' is a type from the bytecode +;;; interpreter. +;;; +(defun hairy-byte-function-arglist (fn) + (let ((counter -1)) + (flet ((next-arg () (make-arg-symbol (incf counter)))) + (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p + keywords-p keywords) fn + (let ((arglist '()) + (optional (- max-args min-args))) + ;; XXX isn't there a better way to write this? + ;; (Looks fine to me. -luke) + (dotimes (i min-args) + (push (next-arg) arglist)) + (when (plusp optional) + (push '&optional arglist) + (dotimes (i optional) + (push (next-arg) arglist))) + (when rest-arg-p + (push '&rest arglist) + (push (next-arg) arglist)) + (when keywords-p + (push '&key arglist) + (loop for (key _ __) in keywords + do (push key arglist)) + (when (eq keywords-p :allow-others) + (push '&allow-other-keys arglist))) + (nreverse arglist)))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form &optional env) + (walker:macroexpand-all form env)) + +(defimplementation compiler-macroexpand-1 (form &optional env) + (ext:compiler-macroexpand-1 form env)) + +(defimplementation compiler-macroexpand (form &optional env) + (ext:compiler-macroexpand form env)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + "cmucl") + +(defimplementation quit-lisp () + (ext::quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (unix:unix-sigsetmask 0) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error 'sldb-condition + :original-condition condition)))) + (unwind-protect + (progn + #+(or)(sys:scrub-control-stack) + (funcall debugger-loop-fn)) + #+(or)(sys:scrub-control-stack) + )))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location (index) + (let ((frame (nth-frame index))) + (cond ((foreign-frame-p frame) (foreign-frame-source-location frame)) + ((code-location-source-location (di:frame-code-location frame)))))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (let ((loc (di:frame-code-location frame))) + (remove-if + (lambda (v) + (not (eq (di:debug-variable-validity v loc) :valid))) + (di::debug-function-debug-variables (di:frame-debug-function frame))))) + +(defun debug-var-value (var frame) + (let* ((loc (di:frame-code-location frame)) + (validity (di:debug-variable-validity var loc))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for v across (frame-debug-vars frame) + collect (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (dbg-fun (di:frame-debug-function frame))) + (typecase dbg-fun + (di::compiled-debug-function + (let* ((comp (di::compiled-debug-function-component dbg-fun)) + (dbg-info (kernel:%code-debug-info comp))) + (typecase dbg-info + (c::compiled-debug-info + (find-package (c::compiled-debug-info-package dbg-info))))))))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (string 'find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of CMUCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext) + (let ((*breakpoint-sigcontext* sigcontext) + (*breakpoint-pc* offset)) + (call-next-function))) +(set-fwrappers 'di::handle-breakpoint '()) +(fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:sigcontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:sigcontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; CMUCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (speed 0))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in +;; newer versions of CMUCL (after ~March 2005). +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di))) + (cond (sym (funcall sym sigcontext)) + (t (funcall 'di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +(defimplementation condition-extras (condition) + (typecase condition + (breakpoint + ;; pop up the source buffer + `((:show-frame-source 0))) + (t '()))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + (di::interpreted-debug-function -1) + (di::bogus-debug-function + #-x86 + (let* ((real (di::frame-real-frame (di::frame-up frame))) + (fp (di::frame-pointer real))) + ;;#+(or) + (progn + (format *debug-io* "Frame-real-frame = ~S~%" real) + (format *debug-io* "fp = ~S~%" fp) + (format *debug-io* "lra = ~S~%" + (kernel:stack-ref fp vm::lra-save-offset))) + (values + (sys:int-sap + (- (kernel:get-lisp-obj-address + (kernel:stack-ref fp vm::lra-save-offset)) + (- (ash vm:function-code-offset vm:word-shift) + vm:function-pointer-type))) + 0)) + #+x86 + (let ((fp (di::frame-pointer (di:frame-up frame)))) + (multiple-value-bind (ra ofp) (di::x86-call-context fp) + (declare (ignore ofp)) + (values ra 0)))))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +~8X Stack Pointer +~8X Frame Pointer +~8X Instruction Pointer +~8X Saved Frame Pointer +~8X Saved Instruction Pointer~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + +(defvar *gdb-program-name* + (ext:enumerate-search-list (p "path:gdb") + (when (probe-file p) + (return p)))) + +(defimplementation disassemble-frame (frame-number) + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (cond ((probe-file *gdb-program-name*) + (let ((ip (sys:sap-int (frame-ip frame)))) + (princ (gdb-command "disas 0x~x" ip)))) + (t + (format t "~%[Disassembling bogus frames not implemented]"))))))) + +(defmacro with-temporary-file ((stream filename) &body body) + `(call/temporary-file (lambda (,stream ,filename) . ,body))) + +(defun call/temporary-file (fun) + (let ((name (system::pick-temporary-file-name))) + (unwind-protect + (with-open-file (stream name :direction :output :if-exists :supersede) + (funcall fun stream name)) + (delete-file name)))) + +(defun gdb-command (format-string &rest args) + (let ((str (gdb-exec (format nil + "interpreter-exec mi2 \"attach ~d\"~%~ + interpreter-exec console ~s~%detach" + (getpid) + (apply #'format nil format-string args)))) + (prompt (format nil + #-(and darwin x86) "~%^done~%(gdb) ~%" + #+(and darwin x86) +"~%^done,thread-id=\"1\"~%(gdb) ~%"))) + (subseq str (+ (or (search prompt str) 0) (length prompt))))) + +(defun gdb-exec (cmd) + (with-temporary-file (file filename) + (write-string cmd file) + (force-output file) + (let* ((output (make-string-output-stream)) + ;; gdb on sparc needs to know the executable to find the + ;; symbols. Without this, gdb can't disassemble anything. + ;; NOTE: We assume that the first entry in + ;; lisp::*cmucl-lib* is the bin directory where lisp is + ;; located. If this is not true, we'll have to do + ;; something better to find the lisp executable. + (lisp-path + #+sparc + (list + (namestring + (probe-file + (merge-pathnames "lisp" (car (lisp::parse-unix-search-path + lisp::*cmucl-lib*)))))) + #-sparc + nil) + (proc (ext:run-program *gdb-program-name* + `(,@lisp-path "-batch" "-x" ,filename) + :wait t + :output output))) + (assert (eq (ext:process-status proc) :exited)) + (assert (eq (ext:process-exit-code proc) 0)) + (get-output-stream-string output)))) + +(defun foreign-frame-p (frame) + #-x86 + (let ((ip (frame-ip frame))) + (and (sys:system-area-pointer-p ip) + (typep (di::frame-debug-function frame) 'di::bogus-debug-function))) + #+x86 + (let ((ip (frame-ip frame))) + (and (sys:system-area-pointer-p ip) + (multiple-value-bind (pc code) + (di::compute-lra-data-from-pc ip) + (declare (ignore pc)) + (not code))))) + +(defun foreign-frame-source-location (frame) + (let ((ip (sys:sap-int (frame-ip frame)))) + (cond ((probe-file *gdb-program-name*) + (parse-gdb-line-info (gdb-command "info line *0x~x" ip))) + (t `(:error "no srcloc available for ~a" frame))))) + +;; The output of gdb looks like: +;; Line 215 of "../../src/lisp/x86-assem.S" +;; starts at address 0x805318c +;; and ends at 0x805318e . +;; The ../../ are fixed up with the "target:" search list which might +;; be wrong sometimes. +(defun parse-gdb-line-info (string) + (with-input-from-string (*standard-input* string) + (let ((w1 (read-word))) + (cond ((equal w1 "Line") + (let ((line (read-word))) + (assert (equal (read-word) "of")) + (let* ((file (read-from-string (read-word))) + (pathname + (or (probe-file file) + (probe-file (format nil "target:lisp/~a" file)) + file))) + (make-location (list :file (unix-truename pathname)) + (list :line (parse-integer line)))))) + (t + `(:error ,string)))))) + +(defun read-word (&optional (stream *standard-input*)) + (peek-char t stream) + (concatenate 'string (loop until (whitespacep (peek-char nil stream)) + collect (read-char stream)))) + +(defun whitespacep (char) + (member char '(#\space #\newline))) + + +;;;; Inspecting + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:instance-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp "-TYPE" (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list "-TYPE" "VM") + (apropos-list "-TYPE" "BIGNUM")))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((di::indirect-value-cell-p o) + `("Value: " (:value ,(c:value-cell-ref o)))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (cmucl-inspect o)))) + +(defun cmucl-inspect (o) + (destructuring-bind (text labeledp . parts) (inspect::describe-parts o) + (list* (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s))))) + ((= header vm:closure-header-type) + (list* (format nil "~A is a closure.~%" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (1- (kernel:get-closure-length o)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (cmucl-inspect o)) + (t + (call-next-method))))) + +(defmethod emacs-inspect ((o kernel:funcallable-instance)) + (append (label-value-line* + (:function (kernel:%funcallable-instance-function o)) + (:lexenv (kernel:%funcallable-instance-lexenv o)) + (:layout (kernel:%funcallable-instance-layout o))) + (cmucl-inspect o))) + +(defmethod emacs-inspect ((o kernel:code-component)) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" + (:newline) + , (with-output-to-string (*standard-output*) + (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o)) + (disassem:disassemble-code-component o)) + ((or + (c::debug-info-p (kernel:%code-debug-info o)) + (consp (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + (c:disassem-byte-component o)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift)))))))) + +(defmethod emacs-inspect ((o kernel:fdefn)) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) + +#+(or) +(defmethod emacs-inspect ((o array)) + (if (typep o 'simple-array) + (call-next-method) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + +(defmethod emacs-inspect ((o simple-vector)) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (loop for i below (length o) + append (label-value-line i (aref o i))))) + +(defun inspect-alien-record (alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (declare (optimize (speed 0))) + (label-value-line slot (alien:slot alien slot)))))))) + +(defun inspect-alien-pointer (alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (cmucl-inspect alien)))) + +(defimplementation eval-context (obj) + (cond ((typep (class-of obj) 'structure-class) + (let* ((dd (kernel:layout-info (kernel:layout-of obj))) + (slots (kernel:dd-slots dd))) + (list* (cons '*package* + (symbol-package (if slots + (kernel:dsd-name (car slots)) + (kernel:dd-name dd)))) + (loop for slot in slots collect + (cons (kernel:dsd-name slot) + (funcall (kernel:dsd-accessor slot) obj)))))))) + + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + :methods methods)) + + +;;;; Multiprocessing + +#+mp +(progn + (defimplementation initialize-multiprocessing (continuation) + (mp::init-multi-processing) + (mp:make-process continuation :name "swank") + ;; Threads magic: this never returns! But top-level becomes + ;; available again. + (unless mp::*idle-process* + (mp::startup-idle-and-top-level-loops))) + + (defimplementation spawn (fn &key name) + (mp:make-process fn :name (or name "Anonymous"))) + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*)))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (mp:process-whostate thread)) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (copy-list mp:*all-processes*)) + + (defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + + (defimplementation kill-thread (thread) + (mp:destroy-process thread)) + + (defvar *mailbox-lock* (mp:make-lock "mailbox lock")) + + (defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock "process mailbox")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock-held (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + + (defimplementation send (thread message) + (check-slime-interrupts) + (let* ((mbox (mailbox thread))) + (mp:with-lock-held ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + + (defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox mp:*current-process*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock-held ((mailbox.mutex mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "receive-if" 0.5 + (lambda () (some test (mailbox.queue mbox))))))) + + + ) ;; #+mp + + + +;;;; GC hooks +;;; +;;; Display GC messages in the echo area to avoid cluttering the +;;; normal output. +;;; + +;; this should probably not be here, but where else? +(defun background-message (message) + (swank::background-message message)) + +(defun print-bytes (nbytes &optional stream) + "Print the number NBYTES to STREAM in KB, MB, or GB units." + (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb)))) + (multiple-value-bind (power name) + (loop for ((p1 n1) (p2 n2)) on names + while n2 do + (when (<= (expt 2 p1) nbytes (1- (expt 2 p2))) + (return (values p1 n1)))) + (cond (name + (format stream "~,1F ~A" (/ nbytes (expt 2 power)) name)) + (t + (format stream "~:D bytes" nbytes)))))) + +(defconstant gc-generations 6) + +#+gencgc +(defun generation-stats () + "Return a string describing the size distribution among the generations." + (let* ((alloc (loop for i below gc-generations + collect (lisp::gencgc-stats i))) + (sum (coerce (reduce #'+ alloc) 'float))) + (format nil "~{~3F~^/~}" + (mapcar (lambda (size) (/ size sum)) + alloc)))) + +(defvar *gc-start-time* 0) + +(defun pre-gc-hook (bytes-in-use) + (setq *gc-start-time* (get-internal-real-time)) + (let ((msg (format nil "[Commencing GC with ~A in use.]" + (print-bytes bytes-in-use)))) + (background-message msg))) + +(defun post-gc-hook (bytes-retained bytes-freed trigger) + (declare (ignore trigger)) + (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*) + internal-time-units-per-second)) + (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]" + (print-bytes bytes-freed) + (print-bytes bytes-retained) + #+gencgc(generation-stats) + #-gencgc"" + seconds))) + (background-message msg))) + +(defun install-gc-hooks () + (setq ext:*gc-notify-before* #'pre-gc-hook) + (setq ext:*gc-notify-after* #'post-gc-hook)) + +(defun remove-gc-hooks () + (setq ext:*gc-notify-before* #'lisp::default-gc-notify-before) + (setq ext:*gc-notify-after* #'lisp::default-gc-notify-after)) + +(defvar *install-gc-hooks* t + "If non-nil install GC hooks") + +(defimplementation emacs-connected () + (when *install-gc-hooks* + (install-gc-hooks))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;;In CMUCL, we have: +;; (trace ) +;; (trace (method ? (+))) +;; (trace :methods t ') ;;to trace all methods of the gf +;; can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + (cond ((fboundp `(method ,@(cdr spec))) + (toggle-trace-aux `(method ,(cdr spec)))) + ;; Man, is this ugly + ((fboundp `(pcl::fast-method ,@(cdr spec))) + (toggle-trace-aux `(pcl::fast-method ,@(cdr spec)))) + (t + (error 'undefined-function :name (cdr spec))))) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))) + ;; doesn't work properly + ;; ((:labels :flet) (toggle-trace-aux (process-fspec spec))) + )) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec)))) + ((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec)))))) + (t + fspec))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) + + +;;; Save image + +(defimplementation save-image (filename &optional restart-function) + (multiple-value-bind (pid error) (unix:unix-fork) + (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error))) + (cond ((= pid 0) + (apply #'ext:save-lisp + filename + (if restart-function + `(:init-function ,restart-function)))) + (t + (let ((status (waitpid pid))) + (destructuring-bind (&key exited? status &allow-other-keys) status + (assert (and exited? (equal status 0)) () + "Invalid exit status: ~a" status))))))) + +(defun waitpid (pid) + (alien:with-alien ((status c-call:int)) + (let ((code (alien:alien-funcall + (alien:extern-alien + waitpid (alien:function c-call:int c-call:int + (* c-call:int) c-call:int)) + pid (alien:addr status) 0))) + (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg))) + (t (assert (= code pid)) + (decode-wait-status status)))))) + +(defun decode-wait-status (status) + (let ((output (with-output-to-string (s) + (call-program (list (process-status-program) + (format nil "~d" status)) + :output s)))) + (read-from-string output))) + +(defun call-program (args &key output) + (destructuring-bind (program &rest args) args + (let ((process (ext:run-program program args :output output))) + (when (not program) (error "fork failed")) + (unless (and (eq (ext:process-status process) :exited) + (= (ext:process-exit-code process) 0)) + (error "Non-zero exit status"))))) + +(defvar *process-status-program* nil) + +(defun process-status-program () + (or *process-status-program* + (setq *process-status-program* + (compile-process-status-program)))) + +(defun compile-process-status-program () + (let ((infile (system::pick-temporary-file-name + "/tmp/process-status~d~c.c"))) + (with-open-file (stream infile :direction :output :if-exists :supersede) + (format stream " +#include +#include +#include +#include +#include + +#define FLAG(value) (value ? \"t\" : \"nil\") + +int main (int argc, char** argv) { + assert (argc == 2); + { + char* endptr = NULL; + char* arg = argv[1]; + long int status = strtol (arg, &endptr, 10); + assert (endptr != arg && *endptr == '\\0'); + printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\" + \" :stopped? %s :stopsig %d)\\n\", + FLAG(WIFEXITED(status)), WEXITSTATUS(status), + FLAG(WIFSIGNALED(status)), WTERMSIG(status), + FLAG(WCOREDUMP(status)), + FLAG(WIFSTOPPED(status)), WSTOPSIG(status)); + fflush (NULL); + return 0; + } +} +") + (finish-output stream)) + (let* ((outfile (system::pick-temporary-file-name)) + (args (list "cc" "-o" outfile infile))) + (warn "Running cc: ~{~a ~}~%" args) + (call-program args :output t) + (delete-file infile) + outfile))) + +;; FIXME: lisp:unicode-complete introduced in version 20d. +#+#.(swank/backend:with-symbol 'unicode-complete 'lisp) +(defun match-semi-standard (prefix matchp) + ;; Handle the CMUCL's short character names. + (loop for name in lisp::char-name-alist + when (funcall matchp prefix (car name)) + collect (car name))) + +#+#.(swank/backend:with-symbol 'unicode-complete 'lisp) +(defimplementation character-completion-set (prefix matchp) + (let ((names (lisp::unicode-complete prefix))) + ;; Match prefix against semistandard names. If there's a match, + ;; add it to our list of matches. + (let ((semi-standard (match-semi-standard prefix matchp))) + (when semi-standard + (setf names (append semi-standard names)))) + (setf names (mapcar #'string-capitalize names)) + (loop for n in names + when (funcall matchp prefix n) + collect n))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/corman.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/corman.lisp new file mode 100644 index 0000000..80d9ddd --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/corman.lisp @@ -0,0 +1,583 @@ +;;; +;;; swank-corman.lisp --- Corman Lisp specific code for SLIME. +;;; +;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org) +;;; +;;; License +;;; ======= +;;; This software is provided 'as-is', without any express or implied +;;; warranty. In no event will the author be held liable for any damages +;;; arising from the use of this software. +;;; +;;; Permission is granted to anyone to use this software for any purpose, +;;; including commercial applications, and to alter it and redistribute +;;; it freely, subject to the following restrictions: +;;; +;;; 1. The origin of this software must not be misrepresented; you must +;;; not claim that you wrote the original software. If you use this +;;; software in a product, an acknowledgment in the product documentation +;;; would be appreciated but is not required. +;;; +;;; 2. Altered source versions must be plainly marked as such, and must +;;; not be misrepresented as being the original software. +;;; +;;; 3. This notice may not be removed or altered from any source +;;; distribution. +;;; +;;; Notes +;;; ===== +;;; You will need CCL 2.51, and you will *definitely* need to patch +;;; CCL with the patches at +;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME +;;; will blow up in your face. You should also follow the +;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime. +;;; +;;; The only communication style currently supported is NIL. +;;; +;;; Starting CCL inside emacs (with M-x slime) seems to work for me +;;; with Corman Lisp 2.51, but I have seen random failures with 2.5 +;;; (sometimes it works, other times it hangs on start or hangs when +;;; initializing WinSock) - starting CCL externally and using M-x +;;; slime-connect always works fine. +;;; +;;; Sometimes CCL gets confused and starts giving you random memory +;;; access violation errors on startup; if this happens, try redumping +;;; your image. +;;; +;;; What works +;;; ========== +;;; * Basic editing and evaluation +;;; * Arglist display +;;; * Compilation +;;; * Loading files +;;; * apropos/describe +;;; * Debugger +;;; * Inspector +;;; +;;; TODO +;;; ==== +;;; * More debugger functionality (missing bits: restart-frame, +;;; return-from-frame, disassemble-frame, activate-stepping, +;;; toggle-trace) +;;; * XREF +;;; * Profiling +;;; * More sophisticated communication styles than NIL +;;; + +(in-package :swank/backend) + +;;; Pull in various needed bits +(require :composite-streams) +(require :sockets) +(require :winbase) +(require :lp) + +(use-package :gs) + +;; MOP stuff + +(defclass swank-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that swank.lisp will compile and load.")) + +(defun named-by-gensym-p (c) + (null (symbol-package (class-name c)))) + +(deftype swank-mop:eql-specializer () + '(satisfies named-by-gensym-p)) + +(defun swank-mop:eql-specializer-object (specializer) + (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*) + (loop (multiple-value-bind (more key value) + (next-entry) + (unless more (return nil)) + (when (eq specializer value) + (return key)))))) + +(defun swank-mop:class-finalized-p (class) + (declare (ignore class)) + t) + +(defun swank-mop:class-prototype (class) + (make-instance class)) + +(defun swank-mop:specializer-direct-methods (obj) + (declare (ignore obj)) + nil) + +(defun swank-mop:generic-function-argument-precedence-order (gf) + (generic-function-lambda-list gf)) + +(defun swank-mop:generic-function-method-combination (gf) + (declare (ignore gf)) + :standard) + +(defun swank-mop:generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun swank-mop:slot-definition-documentation (slot) + (declare (ignore slot)) + (getf slot :documentation nil)) + +(defun swank-mop:slot-definition-type (slot) + (declare (ignore slot)) + t) + +(import-swank-mop-symbols :cl '(;; classes + :standard-slot-definition + :eql-specializer + :eql-specializer-object + ;; standard class readers + :class-default-initargs + :class-direct-default-initargs + :class-finalized-p + :class-prototype + :specializer-direct-methods + ;; gf readers + :generic-function-argument-precedence-order + :generic-function-declarations + :generic-function-method-combination + ;; method readers + ;; slot readers + :slot-definition-documentation + :slot-definition-type)) + +;;;; swank implementations + +;;; Debugger + +(defvar *stack-trace* nil) +(defvar *frame-trace* nil) + +(defstruct frame + name function address debug-info variables) + +(defimplementation call-with-debugging-environment (fn) + (let* ((real-stack-trace (cl::stack-trace)) + (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace + :key #'car))) + (*frame-trace* + (let* ((db::*debug-level* (1+ db::*debug-level*)) + (db::*debug-frame-pointer* (db::stash-ebp + (ct:create-foreign-ptr))) + (db::*debug-max-level* (length real-stack-trace)) + (db::*debug-min-level* 1)) + (cdr (member #'cl:invoke-debugger + (cons + (make-frame :function nil) + (loop for i from db::*debug-min-level* + upto db::*debug-max-level* + until (eq (db::get-frame-function i) + cl::*top-level*) + collect + (make-frame + :function (db::get-frame-function i) + :address (db::get-frame-address i)))) + :key #'frame-function))))) + (funcall fn))) + +(defimplementation compute-backtrace (start end) + (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*))) + collect f)) + +(defimplementation print-frame (frame stream) + (format stream "~S" frame)) + +(defun get-frame-debug-info (frame) + (or (frame-debug-info frame) + (setf (frame-debug-info frame) + (db::prepare-frame-debug-info (frame-function frame) + (frame-address frame))))) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *frame-trace* frame-number)) + (info (get-frame-debug-info frame))) + (let ((var-list + (loop for i from 4 below (length info) by 2 + collect `(list :name ',(svref info i) :id 0 + :value (db::debug-filter ,(svref info i)))))) + (let ((vars (eval-in-frame `(list ,@var-list) frame-number))) + (setf (frame-variables frame) vars))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (elt *frame-trace* frame-number))) + (let ((cl::*compiler-environment* (get-frame-debug-info frame))) + (eval form)))) + +(defimplementation frame-var-value (frame-number var) + (let ((vars (frame-variables (elt *frame-trace* frame-number)))) + (when vars + (second (elt vars var))))) + +(defimplementation frame-source-location (frame-number) + (fspec-location (frame-function (elt *frame-trace* frame-number)))) + +(defun break (&optional (format-control "Break") &rest format-arguments) + (with-simple-restart (continue "Return from BREAK.") + (let ();(*debugger-hook* nil)) + (let ((condition + (make-condition 'simple-condition + :format-control format-control + :format-arguments format-arguments))) + ;;(format *debug-io* ";;; User break: ~A~%" condition) + (invoke-debugger condition)))) + nil) + +;;; Socket communication + +(defimplementation create-socket (host port &key backlog) + (sockets:start-sockets) + (sockets:make-server-socket :host host :port port)) + +(defimplementation local-port (socket) + (sockets:socket-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout external-format)) + (sockets:make-socket-stream (sockets:accept-socket socket))) + +;;; Misc + +(defimplementation preferred-communication-style () + nil) + +(defimplementation getpid () + ccl:*current-process-id*) + +(defimplementation lisp-implementation-type-name () + "cormanlisp") + +(defimplementation quit-lisp () + (sockets:stop-sockets) + (win32:exitprocess 0)) + +(defimplementation set-default-directory (directory) + (setf (ccl:current-directory) directory) + (directory-namestring (setf *default-pathname-defaults* + (truename (merge-pathnames directory))))) + +(defimplementation default-directory () + (directory-namestring (ccl:current-directory))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (ccl:macroexpand-all form)) + +;;; Documentation + +(defun fspec-location (fspec) + (when (symbolp fspec) + (setq fspec (symbol-function fspec))) + (let ((file (ccl::function-source-file fspec))) + (if file + (handler-case + (let ((truename (truename + (merge-pathnames file + ccl:*cormanlisp-directory*)))) + (make-location (list :file (namestring truename)) + (if (ccl::function-source-line fspec) + (list :line + (1+ (ccl::function-source-line fspec))) + (list :function-name + (princ-to-string + (function-name fspec)))))) + (error (c) (list :error (princ-to-string c)))) + (list :error (format nil "No source information available for ~S" + fspec))))) + +(defimplementation find-definitions (name) + (list (list name (fspec-location name)))) + +(defimplementation arglist (name) + (handler-case + (cond ((and (symbolp name) + (macro-function name)) + (ccl::macro-lambda-list (symbol-function name))) + (t + (when (symbolp name) + (setq name (symbol-function name))) + (if (eq (class-of name) cl::the-class-standard-gf) + (generic-function-lambda-list name) + (ccl:function-lambda-list name)))) + (error () :not-available))) + +(defimplementation function-name (fn) + (handler-case (getf (cl::function-info-list fn) 'cl::function-name) + (error () nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +;;; Compiler + +(defvar *buffer-name* nil) +(defvar *buffer-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +;; FIXME +(defimplementation call-with-compilation-hooks (FN) + (handler-bind ((error (lambda (c) + (signal 'compiler-condition + :original-condition c + :severity :warning + :message (format nil "~A" c) + :location + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :offset *buffer-position* 0))) + (*compile-filename* + (make-location + (list :file *compile-filename*) + (list :position 1))) + (t + (list :error "No location"))))))) + (funcall fn))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore external-format policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (multiple-value-bind (output-file warnings? failure?) + (compile-file input-file :output-file output-file) + (values output-file warnings? + (or failure? (and load-p (load output-file)))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-position* position) + (*buffer-string* string)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t))) + +;;;; Inspecting + +;; Hack to make swank.lisp load, at least +(defclass file-stream ()) + +(defun comma-separated (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast (loop for e in list + collect (funcall callback e) + collect ", "))) + +(defmethod emacs-inspect ((class standard-class)) + `("Name: " + (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(comma-separated (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(comma-separated + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot + ,(princ-to-string + (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(princ-to-string + (swank-mop:slot-definition-name slot))))) + '("#")) + (:newline) + ,@(when (documentation class t) + `("Documentation:" (:newline) ,(documentation class t) (:newline))) + "Sub classes: " + ,@(comma-separated (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub ,(princ-to-string (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated + (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class + ,(princ-to-string (class-name class))))) + '("#")) + (:newline))) + +(defmethod emacs-inspect ((slot cons)) + ;; Inspects slot definitions + (if (eq (car slot) :name) + `("Name: " (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" + (:newline) + (:value + ,(swank-mop:slot-definition-documentation slot)) + (:newline))) + "Init args: " (:value + ,(swank-mop:slot-definition-initargs slot)) + (:newline) + "Init form: " + ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#") (:newline) + "Init function: " + (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline)) + (call-next-method))) + +(defmethod emacs-inspect ((pathname pathnames::pathname-internal)) + (list* (if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + '(:newline) + (append (label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((cl::structurep o) (inspect-structure o)) + (t (call-next-method)))) + +(defun inspect-structure (o) + (let* ((template (cl::uref o 1)) + (num-slots (cl::struct-template-num-slots template))) + (cond ((symbolp template) + (loop for i below num-slots + append (label-value-line i (cl::uref o (+ 2 i))))) + (t + (loop for i below num-slots + append (label-value-line (elt template (+ 6 (* i 5))) + (cl::uref o (+ 2 i)))))))) + + +;;; Threads + +(require 'threads) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-instance 'threads:critical-section)) + (queue '() :type list)) + +(defvar *mailbox-lock* (make-instance 'threads:critical-section)) +(defvar *mailboxes* (list)) + +(defmacro with-lock (lock &body body) + `(threads:with-synchronization (threads:cs ,lock) + ,@body)) + +(defimplementation spawn (fun &key name) + (declare (ignore name)) + (th:create-thread + (lambda () + (handler-bind ((serious-condition #'invoke-debugger)) + (unwind-protect (funcall fun) + (with-lock *mailbox-lock* + (setq *mailboxes* (remove cormanlisp:*current-thread-id* + *mailboxes* :key #'mailbox.thread)))))))) + +(defimplementation thread-id (thread) + thread) + +(defimplementation find-thread (thread) + (if (thread-alive-p thread) + thread)) + +(defimplementation thread-alive-p (thread) + (if (threads:thread-handle thread) t nil)) + +(defimplementation current-thread () + cormanlisp:*current-thread-id*) + +;; XXX implement it +(defimplementation all-threads () + '()) + +;; XXX something here is broken +(defimplementation kill-thread (thread) + (threads:terminate-thread thread 'killed)) + +(defun mailbox (thread) + (with-lock *mailbox-lock* + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (with-lock (mailbox.lock mbox) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(defimplementation receive () + (let ((mbox (mailbox cormanlisp:*current-thread-id*))) + (loop + (with-lock (mailbox.lock mbox) + (when (mailbox.queue mbox) + (return (pop (mailbox.queue mbox))))) + (sleep 0.1)))) + + +;;; This is probably not good, but it WFM +(in-package :common-lisp) + +(defvar *old-documentation* #'documentation) +(defun documentation (thing &optional (type 'function)) + (if (symbolp thing) + (funcall *old-documentation* thing type) + (values))) + +(defmethod print-object ((restart restart) stream) + (if (or *print-escape* + *print-readably*) + (print-unreadable-object (restart stream :type t :identity t) + (princ (restart-name restart) stream)) + (when (functionp (restart-report-function restart)) + (funcall (restart-report-function restart) stream)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/ecl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/ecl.lisp new file mode 100644 index 0000000..743aa6e --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/ecl.lisp @@ -0,0 +1,1098 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-ecl.lisp --- SLIME backend for ECL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/ecl + (:use cl swank/backend)) + +(in-package swank/ecl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ecl-version () + (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT))) + (if version + (symbol-value version) + 0))) + (when (< (ecl-version) 100301) + (error "~&IMPORTANT:~% ~ + The version of ECL you're using (~A) is too old.~% ~ + Please upgrade to at least 10.3.1.~% ~ + Sorry for the inconvenience.~%~%" + (lisp-implementation-version)))) + +;; Hard dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) + +;; Soft dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (probe-file "sys:profile.fas") + (require :profile) + (pushnew :profile *features*)) + (when (probe-file "sys:serve-event.fas") + (require :serve-event) + (pushnew :serve-event *features*))) + +(declaim (optimize (debug 3))) + +;;; Swank-mop + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import-swank-mop-symbols + :clos + (and (< (ecl-version) 121201) + `(:eql-specializer + :eql-specializer-object + :generic-function-declarations + :specializer-direct-methods + ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) + '(:compute-applicable-methods-using-classes)))))) + +(defimplementation gray-package-name () + "GRAY") + + +;;;; UTF8 + +;;; Convert the string STRING to a (simple-array (unsigned-byte 8)). +;;; +;;; string-to-utf8 (string) + +;;; Convert the (simple-array (unsigned-byte 8)) OCTETS to a string. +;;; +;;; utf8-to-string (octets) + + +;;;; TCP Server + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t + :input t + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format)) + +;;; Call FN whenever SOCKET is readable. +;;; +;;; add-sigio-handler (socket fn) + +;;; Remove all sigio handlers for SOCKET. +;;; +;;; remove-sigio-handlers (socket) + +;;; Call FN when Lisp is waiting for input and SOCKET is readable. +;;; +;;; add-fd-handler (socket fn) + +;;; Remove all fd-handlers for SOCKET. +;;; +;;; remove-fd-handlers (socket) + +(defimplementation preferred-communication-style () + (cond + ((member :threads *features*) :spawn) + ((member :windows *features*) nil) + (t #|:fd-handler|# nil))) + +;;; Set the 'stream 'timeout. The timeout is either the real number +;;; specifying the timeout in seconds or 'nil for no timeout. +;;; +;;; set-stream-timeout (stream timeout) + + +;;; Hook called when the first connection from Emacs is established. +;;; Called from the INIT-FN of the socket server that accepts the +;;; connection. +;;; +;;; This is intended for setting up extra context, e.g. to discover +;;; that the calling thread is the one that interacts with Emacs. +;;; +;;; emacs-connected () + + +;;;; Unix Integration + +(defimplementation getpid () + (si:getpid)) + +;;; Call FUNCTION on SIGINT (instead of invoking the debugger). +;;; Return old signal handler. +;;; +;;; install-sigint-handler (function) + +;;; XXX! +;;; If ECL is built with thread support, it'll spawn a helper thread +;;; executing the SIGINT handler. We do not want to BREAK into that +;;; helper but into the main thread, though. This is coupled with the +;;; current choice of NIL as communication-style in so far as ECL's +;;; main-thread is also the Slime's REPL thread. + +(defun make-interrupt-handler (real-handler) + #+threads + (let ((main-thread (find 'si:top-level (mp:all-processes) + :key #'mp:process-name))) + #'(lambda (&rest args) + (declare (ignore args)) + (mp:interrupt-process main-thread real-handler))) + #-threads + #'(lambda (&rest args) + (declare (ignore args)) + (funcall real-handler))) + +(defimplementation call-with-user-break-handler (real-handler function) + (let ((old-handler #'si:terminal-interrupt)) + (setf (symbol-function 'si:terminal-interrupt) + (make-interrupt-handler real-handler)) + (unwind-protect (funcall function) + (setf (symbol-function 'si:terminal-interrupt) old-handler)))) + +(defimplementation quit-lisp () + (ext:quit)) + +;;; Default implementation is fine. +;;; +;;; lisp-implementation-type-name +;;; lisp-implementation-program + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (two-way-stream (socket-fd (two-way-stream-input-stream socket))) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (si:file-stream-fd socket)))) + +;;; Create a character stream for the file descriptor FD. This +;;; interface implementation requires either `ffi:c-inline' or has to +;;; wait for the exported interface. +;;; +;;; make-fd-stream (socket-stream) + +;;; Duplicate a file descriptor. If the syscall fails, signal a +;;; condition. See dup(2). This interface requiers `ffi:c-inline' or +;;; has to wait for the exported interface. +;;; +;;; dup (fd) + +;;; Does not apply to ECL which doesn't dump images. +;;; +;;; exec-image (image-file args) + +(defimplementation command-line-args () + (ext:command-args)) + + +;;;; pathnames + +;;; Return a pathname for FILENAME. +;;; A filename in Emacs may for example contain asterisks which should not +;;; be translated to wildcards. +;;; +;;; filename-to-pathname (filename) + +;;; Return the filename for PATHNAME. +;;; +;;; pathname-to-filename (pathname) + +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation set-default-directory (directory) + (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. + (default-directory)) + + +;;; Call FN with hooks to handle special syntax. Can we use it for +;;; `ffi:c-inline' to be handled as C/C++ code? +;;; +;;; call-with-syntax-hooks + +;;; Return a suitable initial value for SWANK:*READTABLE-ALIST*. +;;; +;;; default-readtable-alist + + +;;;; Packages + +#+package-local-nicknames +(defimplementation package-local-nicknames (package) + (ext:package-local-nicknames package)) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +#-ecl-bytecmp +(defun handle-compiler-message (condition) + ;; ECL emits lots of noise in compiler-notes, like "Invoking + ;; external command". + (unless (typep condition 'c::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (c:compiler-fatal-error :error) + (c:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +#-ecl-bytecmp +(defun condition-location (condition) + (let ((file (c:compiler-message-file condition)) + (position (c:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) + +(defimplementation call-with-compilation-hooks (function) + #+ecl-bytecmp + (funcall function) + #-ecl-bytecmp + (handler-bind ((c:compiler-message #'handle-compiler-message)) + (funcall function))) + +(defvar *tmpfile-map* (make-hash-table :test #'equal)) + +(defun note-buffer-tmpfile (tmp-file buffer-name) + ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. + (let ((tmp-namestring (namestring (truename tmp-file)))) + (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) + tmp-namestring)) + +(defun tmpfile-to-buffer (tmp-file) + (gethash tmp-file *tmpfile-map*)) + +(defimplementation swank-compile-string + (string &key buffer position filename policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) ; for compilation hooks + (*buffer-start-position* position)) + (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-")) + (fasl-file) + (warnings-p) + (failure-p)) + (unwind-protect + (with-open-file (tmp-stream tmp-file :direction :output + :if-exists :supersede) + (write-string string tmp-stream) + (finish-output tmp-stream) + (multiple-value-setq (fasl-file warnings-p failure-p) + (compile-file tmp-file + :load t + :source-truename (or filename + (note-buffer-tmpfile tmp-file buffer)) + :source-offset (1- position)))) + (when (probe-file tmp-file) + (delete-file tmp-file)) + (when fasl-file + (delete-file fasl-file))) + (not failure-p))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (compile-file input-file :output-file output-file + :load load-p + :external-format external-format))) + +(defvar *external-format-to-coding-system* + '((:latin-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (ext:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, ECL uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + +;;; Default implementation is fine +;;; +;;; guess-external-format + + +;;;; Streams + +;;; Implemented in `gray' +;;; +;;; make-output-stream +;;; make-input-stream + + +;;;; Documentation + +(defimplementation arglist (name) + (multiple-value-bind (arglist foundp) + (ext:function-lambda-list name) + (if foundp arglist :not-available))) + +(defimplementation type-specifier-p (symbol) + (or (subtypep nil symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defimplementation function-name (f) + (typecase f + (generic-function (clos:generic-function-name f)) + (function (si:compiled-function-name f)))) + +;;; Default implementation is fine (CL). +;;; +;;; valid-function-name-p (form) + +#+walker +(defimplementation macroexpand-all (form &optional env) + (walker:macroexpand-all form env)) + +;;; Default implementation is fine. +;;; +;;; compiler-macroexpand-1 +;;; compiler-macroexpand + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,form)))) + (values macro-forms nil))) + +;;; Expand the format string CONTROL-STRING. +;;; Default implementation is fine. +;;; +;;; format-string-expand + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((frob (type boundp) + (when (funcall boundp symbol) + (let ((doc (describe-definition symbol type))) + (setf result (list* type doc result)))))) + (frob :VARIABLE #'boundp) + (frob :FUNCTION #'fboundp) + (frob :CLASS (lambda (x) (find-class x nil)))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + + +;;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(lambda (condition old-hook) + ;; Regard *debugger-hook* if set by user. + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defvar *backtrace* '()) + +(defun in-swank-package-p (x) + (and + (symbolp x) + (member (symbol-package x) + (list #.(find-package :swank) + #.(find-package :swank/backend) + #.(ignore-errors (find-package :swank-mop)) + #.(ignore-errors (find-package :swank-loader)))) + t)) + +(defun is-swank-source-p (name) + (setf name (pathname name)) + (pathname-match-p + name + (make-pathname :defaults swank-loader::*source-directory* + :name (pathname-name name) + :type (pathname-type name) + :version (pathname-version name)))) + +(defun is-ignorable-fun-p (x) + (or + (in-swank-package-p (frame-name x)) + (multiple-value-bind (file position) + (ignore-errors (si::bc-file (car x))) + (declare (ignore position)) + (if file (is-swank-source-p file))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*ihs-top* (ihs-top)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + nil)))) + (declare (special *ihs-current*)) + (loop for f from *frs-base* until *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (si::fixnump name) + (push name (third x))))))) + (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation compute-backtrace (start end) + (subseq *backtrace* start + (and (numberp end) + (min end (length *backtrace*))))) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::bc-file fun) + (when file + (make-file-location file position)))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (setf frame (si::decode-ihs-env (second frame))) + (dolist (record (remove-if-not #'consp frame)) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((or (symbolp record0) (stringp record0)) + (setq variables (acons record0 record1 variables))) + ((not (si::fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) + +(defimplementation print-frame (frame stream) + (format stream "~A" (first frame))) + +;;; Is the frame FRAME restartable?. +;;; Return T if `restart-frame' can safely be called on the frame. +;;; +;;; frame-restartable-p (frame) + +(defimplementation frame-source-location (frame-number) + (let ((frame (elt *backtrace* frame-number))) + (or (nth-value 1 (frame-function frame)) + (make-error-location "Unknown source location for ~A." (car frame))))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env + (elt *backtrace* frame-number))) + collect (list :name name :id 0 :value value))) + +(defimplementation frame-var-value (frame-number var-number) + (destructuring-bind (name . value) + (elt + (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + var-number) + (declare (ignore name)) + value)) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-function (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-with-env form env))) + +;;; frame-package +;;; frame-call +;;; return-from-frame +;;; restart-frame +;;; print-condition +;;; condition-extras + +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +;;; active-stepping +;;; sldb-break-on-return +;;; sldb-break-at-start +;;; sldb-stepper-condition-p +;;; sldb-setp-into +;;; sldb-step-next +;;; sldb-step-out + + +;;;; Definition finding + +(defvar +TAGS+ (namestring + (merge-pathnames "TAGS" (translate-logical-pathname "SYS:")))) + +(defun make-file-location (file file-position) + ;; File positions in CL start at 0, but Emacs' buffer positions + ;; start at 1. We specify (:ALIGN T) because the positions comming + ;; from ECL point at right after the toplevel form appearing before + ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. + (make-location `(:file ,(namestring (translate-logical-pathname file))) + `(:position ,(1+ file-position)) + `(:align t))) + +(defun make-buffer-location (buffer-name start-position &optional (offset 0)) + (make-location `(:buffer ,buffer-name) + `(:offset ,start-position ,offset) + `(:align t))) + +(defun make-TAGS-location (&rest tags) + (make-location `(:etags-file ,+TAGS+) + `(:tag ,@tags))) + +(defimplementation find-definitions (name) + (let ((annotations (ext:get-annotation name 'si::location :all))) + (cond (annotations + (loop for annotation in annotations + collect (destructuring-bind (dspec file . pos) annotation + `(,dspec ,(make-file-location file pos))))) + (t + (mapcan #'(lambda (type) (find-definitions-by-type name type)) + (classify-definition-name name)))))) + +(defun classify-definition-name (name) + (let ((types '())) + (when (fboundp name) + (cond ((special-operator-p name) + (push :special-operator types)) + ((macro-function name) + (push :macro types)) + ((typep (fdefinition name) 'generic-function) + (push :generic-function types)) + ((si:mangle-name name t) + (push :c-function types)) + (t + (push :lisp-function types)))) + (when (boundp name) + (cond ((constantp name) + (push :constant types)) + (t + (push :global-variable types)))) + types)) + +(defun find-definitions-by-type (name type) + (ecase type + (:lisp-function + (when-let (loc (source-location (fdefinition name))) + (list `((defun ,name) ,loc)))) + (:c-function + (when-let (loc (source-location (fdefinition name))) + (list `((c-source ,name) ,loc)))) + (:generic-function + (loop for method in (clos:generic-function-methods (fdefinition name)) + for specs = (clos:method-specializers method) + for loc = (source-location method) + when loc + collect `((defmethod ,name ,specs) ,loc))) + (:macro + (when-let (loc (source-location (macro-function name))) + (list `((defmacro ,name) ,loc)))) + (:constant + (when-let (loc (source-location name)) + (list `((defconstant ,name) ,loc)))) + (:global-variable + (when-let (loc (source-location name)) + (list `((defvar ,name) ,loc)))) + (:special-operator))) + +;;; FIXME: There ought to be a better way. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun c-function-name-p (name) + (and (symbolp name) (si:mangle-name name t) t)) + (defun c-function-p (object) + (and (functionp object) + (let ((fn-name (function-name object))) + (and fn-name (c-function-name-p fn-name)))))) + +(deftype c-function () + `(satisfies c-function-p)) + +(defun assert-source-directory () + (unless (probe-file #P"SRC:") + (error "ECL's source directory ~A does not exist. ~ + You can specify a different location via the environment ~ + variable `ECLSRCDIR'." + (namestring (translate-logical-pathname #P"SYS:"))))) + +(defun assert-TAGS-file () + (unless (probe-file +TAGS+) + (error "No TAGS file ~A found. It should have been installed with ECL." + +TAGS+))) + +(defun package-names (package) + (cons (package-name package) (package-nicknames package))) + +(defun source-location (object) + (converting-errors-to-error-location + (typecase object + (c-function + (assert-source-directory) + (assert-TAGS-file) + (let ((lisp-name (function-name object))) + (assert lisp-name) + (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t) + (assert flag) + ;; In ECL's code base sometimes the mangled name is used + ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or + ;; @EXT::SYMBOL is used. We cannot predict here, so we just + ;; provide several candidates. + (apply #'make-TAGS-location + c-name + (loop with s = (symbol-name lisp-name) + for p in (package-names (symbol-package lisp-name)) + collect (format nil "~A::~A" p s) + collect (format nil "~(~A::~A~)" p s)))))) + (function + (multiple-value-bind (file pos) (ext:compiled-function-file object) + (cond ((not file) + (return-from source-location nil)) + ((tmpfile-to-buffer file) + (make-buffer-location (tmpfile-to-buffer file) pos)) + (t + (assert (probe-file file)) + (assert (not (minusp pos))) + (make-file-location file pos))))) + (method + ;; FIXME: This will always return NIL at the moment; ECL does not + ;; store debug information for methods yet. + (source-location (clos:method-function object))) + ((member nil t) + (multiple-value-bind (flag c-name) (si:mangle-name object) + (assert flag) + (make-TAGS-location c-name)))))) + +(defimplementation find-source-location (object) + (or (source-location object) + (make-error-location "Source definition of ~S not found." object))) + +;;; buffer-first-change + + +;;;; XREF + +;;; who-calls +;;; calls-who +;;; who-references +;;; who-binds +;;; who-sets +;;; who-macroexpands +;;; who-specializes +;;; list-callers +;;; list-callees + + +;;;; Profiling + +;;; XXX: use monitor.lisp (ccl,clisp) + +#+profile +(progn + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) +) ; #+profile (progn ... + + +;;;; Trace + +;;; Toggle tracing of the function(s) given with SPEC. +;;; SPEC can be: +;;; (setf NAME) ; a setf function +;;; (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method +;;; (:defgeneric NAME) ; a generic function with all methods +;;; (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. +;;; (:labels TOPLEVEL LOCAL) +;;; (:flet TOPLEVEL LOCAL) +;;; +;;; toggle-trace (spec) + + +;;;; Inspector + +;;; FIXME: Would be nice if it was possible to inspect objects +;;; implemented in C. + +;;; Return a list of bindings corresponding to OBJECT's slots. +;;; eval-context (object) + +;;; Return a string describing the primitive type of object. +;;; describe-primitive-type (object) + + +;;;; Multithreading + +;;; Not needed in ECL +;;; +;;; initialize-multiprocessing + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + + (defimplementation thread-id (target-thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + ;; Does TARGET-THREAD have an id already? + (maphash (lambda (id thread-pointer) + (let ((thread (si:weak-pointer-value thread-pointer))) + (cond ((not thread) + (remhash id *thread-id-map*)) + ((eq thread target-thread) + (return-from thread-id id))))) + *thread-id-map*) + ;; TARGET-THREAD not found in *THREAD-ID-MAP* + (let ((id (incf *thread-id-counter*)) + (thread-pointer (si:make-weak-pointer target-thread))) + (setf (gethash id *thread-id-map*) thread-pointer) + id)))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (let* ((thread-ptr (gethash id *thread-id-map*)) + (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) + (unless thread + (remhash id *thread-id-map*)) + thread))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (if (mp:process-active-p thread) + "RUNNING" + "STOPPED")) + + ;; thread-attributes + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (mp:all-processes)) + + (defimplementation thread-alive-p (thread) + (mp:process-active-p thread)) + + (defimplementation interrupt-thread (thread fn) + (mp:interrupt-process thread fn)) + + (defimplementation kill-thread (thread) + (mp:process-kill thread)) + + (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mp:make-lock)) + (cvar (mp:make-condition-variable)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (mp:with-lock (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + ;; receive + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:condition-variable-wait (mailbox.cvar mbox) mutex))))) + + ;; Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using + ;; asynchronous interrupts. + ;; + ;; Doesn't have to implement this if RECEIVE-IF periodically calls + ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient. + ;; + ;; wake-thread (thread) + + ;; Copied from sbcl.lisp and adjusted to ECL. + (let ((alist '()) + (mutex (mp:make-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-lock (mutex) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-lock (mutex) + (cdr (assoc name alist))))) + + ;; Not needed in ECL (?). + ;; + ;; set-default-initial-binding (var form) + + ) ; #+threads + +;;; Instead of busy waiting with communication-style NIL, use select() +;;; on the sockets' streams. +#+serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (flet ((poll-streams (streams timeout) + (let* ((serve-event::*descriptor-handlers* + (copy-list serve-event::*descriptor-handlers*)) + (active-fds '()) + (fd-stream-alist + (loop for s in streams + for fd = (socket-fd s) + collect (cons fd s) + do (serve-event:add-fd-handler fd :input + #'(lambda (fd) + (push fd active-fds)))))) + (serve-event:serve-event timeout) + (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (poll-streams streams 0))) + (t + (when-let (ready (poll-streams streams 0.2)) + (return ready))))))) + +#-serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (remove-if-not #'listen streams))) + (t + (let ((ready (remove-if-not #'listen streams))) + (if ready (return ready)) + (sleep 0.1)))))) + + +;;;; Locks + +#+threads +(defimplementation make-lock (&key name) + (mp:make-lock :name name :recursive t)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mp:with-lock (lock) (funcall function))) + + +;;;; Weak datastructures + +;;; XXX: this should work but causes SLIME REPL hang at some point of time. May +;;; be ECL or SLIME bug - disabling for now. +#+(and ecl-weak-hash (or)) +(progn + (defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weakness :key args)) + + (defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weakness :value args)) + + (defimplementation hash-table-weakness (hashtable) + (ext:hash-table-weakness hashtable))) + + +;;;; Character names + +;;; Default implementation is fine. +;;; +;;; character-completion-set (prefix matchp) + + +;;;; Heap dumps + +;;; Doesn't apply to ECL. +;;; +;;; save-image (filename &optional restart-function) +;;; background-save-image (filename &key restart-function completion-function) + + +;;;; Wrapping + +;;; Intercept future calls to SPEC and surround them in callbacks. +;;; Very much similar to so-called advices for normal functions. +;;; +;;; wrap (spec indicator &key before after replace) +;;; unwrap (spec indicator) +;;; wrapped-p (spec indicator) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/gray.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/gray.lisp new file mode 100644 index 0000000..3c6c697 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/gray.lisp @@ -0,0 +1,207 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; swank-gray.lisp --- Gray stream based IO redirection. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package swank/backend) + +#.(progn + (defvar *gray-stream-symbols* + '(fundamental-character-output-stream + stream-write-char + stream-write-string + stream-fresh-line + stream-force-output + stream-finish-output + + fundamental-character-input-stream + stream-read-char + stream-peek-char + stream-read-line + stream-listen + stream-unread-char + stream-clear-input + stream-line-column + stream-read-char-no-hang)) + nil) + +(defpackage swank/gray + (:use cl swank/backend) + (:import-from #.(gray-package-name) . #.*gray-stream-symbols*) + (:export . #.*gray-stream-symbols*)) + +(in-package swank/gray) + +(defclass slime-output-stream (fundamental-character-output-stream) + ((output-fn :initarg :output-fn) + (buffer :initform (make-string 8000)) + (fill-pointer :initform 0) + (column :initform 0) + (lock :initform (make-lock :name "buffer write lock")) + (flush-thread :initarg :flush-thread + :initform nil + :accessor flush-thread) + (flush-scheduled :initarg :flush-scheduled + :initform nil + :accessor flush-scheduled))) + +(defun maybe-schedule-flush (stream) + (when (and (flush-thread stream) + (not (flush-scheduled stream))) + (setf (flush-scheduled stream) t) + (send (flush-thread stream) t))) + +(defmacro with-slime-output-stream (stream &body body) + `(with-slots (lock output-fn buffer fill-pointer column) ,stream + (call-with-lock-held lock (lambda () ,@body)))) + +(defmethod stream-write-char ((stream slime-output-stream) char) + (with-slime-output-stream stream + (setf (schar buffer fill-pointer) char) + (incf fill-pointer) + (incf column) + (when (char= #\newline char) + (setf column 0)) + (if (= fill-pointer (length buffer)) + (finish-output stream) + (maybe-schedule-flush stream))) + char) + +(defmethod stream-write-string ((stream slime-output-stream) string + &optional start end) + (with-slime-output-stream stream + (let* ((start (or start 0)) + (end (or end (length string))) + (len (length buffer)) + (count (- end start)) + (free (- len fill-pointer))) + (when (>= count free) + (stream-finish-output stream)) + (cond ((< count len) + (replace buffer string :start1 fill-pointer + :start2 start :end2 end) + (incf fill-pointer count) + (maybe-schedule-flush stream)) + (t + (funcall output-fn (subseq string start end)))) + (let ((last-newline (position #\newline string :from-end t + :start start :end end))) + (setf column (if last-newline + (- end last-newline 1) + (+ column count)))))) + string) + +(defmethod stream-line-column ((stream slime-output-stream)) + (with-slime-output-stream stream column)) + +(defmethod stream-finish-output ((stream slime-output-stream)) + (with-slime-output-stream stream + (unless (zerop fill-pointer) + (funcall output-fn (subseq buffer 0 fill-pointer)) + (setf fill-pointer 0)) + (setf (flush-scheduled stream) nil)) + nil) + +#+(and sbcl sb-thread) +(defmethod stream-force-output :around ((stream slime-output-stream)) + ;; Workaround for deadlocks between the world-lock and auto-flush-thread + ;; buffer write lock. + ;; + ;; Another alternative would be to grab the world-lock here, but that's less + ;; future-proof, and could introduce other lock-ordering issues in the + ;; future. + (handler-case + (sb-sys:with-deadline (:seconds 0.1) + (call-next-method)) + (sb-sys:deadline-timeout () + nil))) + +(defmethod stream-force-output ((stream slime-output-stream)) + (stream-finish-output stream)) + +(defmethod stream-fresh-line ((stream slime-output-stream)) + (with-slime-output-stream stream + (cond ((zerop column) nil) + (t (terpri stream) t)))) + +(defclass slime-input-stream (fundamental-character-input-stream) + ((input-fn :initarg :input-fn) + (buffer :initform "") (index :initform 0) + (lock :initform (make-lock :name "buffer read lock")))) + +(defmethod stream-read-char ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index input-fn) s + (when (= index (length buffer)) + (let ((string (funcall input-fn))) + (cond ((zerop (length string)) + (return-from stream-read-char :eof)) + (t + (setf buffer string) + (setf index 0))))) + (assert (plusp (length buffer))) + (prog1 (aref buffer index) (incf index)))))) + +(defmethod stream-listen ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (< index (length buffer)))))) + +(defmethod stream-unread-char ((s slime-input-stream) char) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (decf index) + (cond ((eql (aref buffer index) char) + (setf (aref buffer index) char)) + (t + (warn "stream-unread-char: ignoring ~S (expected ~S)" + char (aref buffer index))))))) + nil) + +(defmethod stream-clear-input ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (setf buffer "" + index 0)))) + nil) + +(defmethod stream-line-column ((s slime-input-stream)) + nil) + +(defmethod stream-read-char-no-hang ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (when (< index (length buffer)) + (prog1 (aref buffer index) (incf index))))))) + + +;;; + +(defimplementation make-auto-flush-thread (stream) + (if (typep stream 'slime-output-stream) + (setf (flush-thread stream) + (spawn (lambda () (auto-flush-loop stream 0.08 t)) + :name "auto-flush-thread")) + (spawn (lambda () (auto-flush-loop stream *auto-flush-interval*)) + :name "auto-flush-thread"))) + +(defimplementation make-output-stream (write-string) + (make-instance 'slime-output-stream :output-fn write-string)) + +(defimplementation make-input-stream (read-string) + (make-instance 'slime-input-stream :input-fn read-string)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/lispworks.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/lispworks.lisp new file mode 100644 index 0000000..8b2d2ed --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/lispworks.lisp @@ -0,0 +1,1020 @@ +;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-lispworks.lisp --- LispWorks specific code for SLIME. +;;; +;;; Created 2003, Helmut Eller +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/lispworks + (:use cl swank/backend)) + +(in-package swank/lispworks) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +(defimplementation gray-package-name () + "STREAM") + +(import-swank-mop-symbols :clos '(:slot-definition-documentation + :slot-boundp-using-class + :slot-value-using-class + :slot-makunbound-using-class + :eql-specializer + :eql-specializer-object + :compute-applicable-methods-using-classes)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +(defun swank-mop:slot-boundp-using-class (class object slotd) + (clos:slot-boundp-using-class class object + (clos:slot-definition-name slotd))) + +(defun swank-mop:slot-value-using-class (class object slotd) + (clos:slot-value-using-class class object + (clos:slot-definition-name slotd))) + +(defun (setf swank-mop:slot-value-using-class) (value class object slotd) + (setf (clos:slot-value-using-class class object + (clos:slot-definition-name slotd)) + value)) + +(defun swank-mop:slot-makunbound-using-class (class object slotd) + (clos:slot-makunbound-using-class class object + (clos:slot-definition-name slotd))) + +(defun swank-mop:compute-applicable-methods-using-classes (gf classes) + (clos::compute-applicable-methods-from-classes gf classes)) + +;; lispworks doesn't have the eql-specializer class, it represents +;; them as a list of `(EQL ,OBJECT) +(deftype swank-mop:eql-specializer () 'cons) + +(defun swank-mop:eql-specializer-object (eql-spec) + (second eql-spec)) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (defvar *original-defimplementation* (macro-function 'defimplementation)) + (defmacro defimplementation (&whole whole name args &body body + &environment env) + (declare (ignore args body)) + `(progn + (dspec:record-definition '(defun ,name) (dspec:location) + :check-redefinition-p nil) + ,(funcall *original-defimplementation* whole env)))) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ef:encode-lisp-string string '(:utf-8 :eol-style :lf))) + +(defimplementation utf8-to-string (octets) + (ef:decode-external-string octets '(:utf-8 :eol-style :lf))) + +;;; TCP server + +(defimplementation preferred-communication-style () + :spawn) + +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (comm:socket-stream (comm:socket-stream-socket socket)))) + +(defimplementation create-socket (host port &key backlog) + (multiple-value-bind (socket where errno) + #-(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port :address host + :backlog (or backlog 5)) + #+(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port) + (cond (socket socket) + (t (error 'network-error + :format-control "~A failed: ~A (~D)" + :format-arguments (list where + (list #+unix (lw:get-unix-error errno)) + errno)))))) + +(defimplementation local-port (socket) + (nth-value 1 (comm:get-socket-address (socket-fd socket)))) + +(defimplementation close-socket (socket) + (comm::close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering)) + (let* ((fd (comm::get-fd-from-socket socket))) + (assert (/= fd -1)) + (cond ((not external-format) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8))) + (t + (assert (valid-external-format-p external-format)) + (ecase (first external-format) + ((:latin-1 :ascii) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type 'base-char)) + (:utf-8 + (make-flexi-stream + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8)) + external-format))))))) + +(defun make-flexi-stream (stream external-format) + (unless (member :flexi-streams *features*) + (error "Cannot use external format ~A~ + without having installed flexi-streams in the inferior-lisp." + external-format)) + (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM") + stream + :external-format + (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT") + external-format))) + +;;; Coding Systems + +(defun valid-external-format-p (external-format) + (member external-format *external-format-to-coding-system* + :test #'equal :key #'car)) + +(defvar *external-format-to-coding-system* + '(((:latin-1 :eol-style :lf) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1") + ;;((:utf-8) "utf-8") + ((:utf-8 :eol-style :lf) "utf-8-unix") + ;;((:euc-jp) "euc-jp") + ((:euc-jp :eol-style :lf) "euc-jp-unix") + ;;((:ascii) "us-ascii") + ((:ascii :eol-style :lf) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +;;; Unix signals + +(defun sigint-handler () + (with-simple-restart (continue "Continue from SIGINT handler.") + (invoke-debugger "SIGINT"))) + +(defun make-sigint-handler (process) + (lambda (&rest args) + (declare (ignore args)) + (mp:process-interrupt process #'sigint-handler))) + +(defun set-sigint-handler () + ;; Set SIGINT handler on Swank request handler thread. + #-win32 + (sys::set-signal-handler +sigint+ + (make-sigint-handler mp:*current-process*))) + +#-win32 +(defimplementation install-sigint-handler (handler) + (sys::set-signal-handler +sigint+ + (let ((self mp:*current-process*)) + (lambda (&rest args) + (declare (ignore args)) + (mp:process-interrupt self handler))))) + +(defimplementation getpid () + #+win32 (win32:get-current-process-id) + #-win32 (system::getpid)) + +(defimplementation lisp-implementation-type-name () + "lispworks") + +(defimplementation set-default-directory (directory) + (namestring (hcl:change-directory directory))) + +;;;; Documentation + +(defun map-list (function list) + "Map over proper and not proper lists." + (loop for (car . cdr) on list + collect (funcall function car) into result + when (null cdr) return result + when (atom cdr) return (nconc result (funcall function cdr)))) + +(defun replace-strings-with-symbols (tree) + (map-list + (lambda (x) + (typecase x + (list + (replace-strings-with-symbols x)) + (symbol + x) + (string + (intern x)) + (t + (intern (write-to-string x))))) + tree)) + +(defimplementation arglist (symbol-or-function) + (let ((arglist (lw:function-lambda-list symbol-or-function))) + (etypecase arglist + ((member :dont-know) + :not-available) + (list + (replace-strings-with-symbols arglist))))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (walker:walk-form form)) + +(defun generic-function-p (object) + (typep object 'generic-function)) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (labels ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos)))) + (doc (kind &optional (sym symbol)) + (let ((string (or (documentation sym kind)))) + (if string + (first-line string) + :not-documented))) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :generic-function (if (and (fboundp symbol) + (generic-function-p (fdefinition symbol))) + (doc 'function))) + (maybe-push + :function (if (and (fboundp symbol) + (not (generic-function-p (fdefinition symbol)))) + (doc 'function))) + (maybe-push + :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol)))) + (if (fboundp setf-name) + (doc 'setf)))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol type) + (ecase type + (:variable (describe-symbol symbol)) + (:class (describe (find-class symbol))) + ((:function :generic-function) (describe-function symbol)) + (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol)))))) + +(defun describe-function (symbol) + (cond ((fboundp symbol) + (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%" + symbol + (lispworks:function-lambda-list symbol) + (documentation symbol 'function)) + (describe (fdefinition symbol))) + (t (format t "~S is not fbound" symbol)))) + +(defun describe-symbol (sym) + (format t "~A is a symbol in package ~A." sym (symbol-package sym)) + (when (boundp sym) + (format t "~%~%Value: ~A" (symbol-value sym))) + (let ((doc (documentation sym 'variable))) + (when doc + (format t "~%~%Variable documentation:~%~A" doc))) + (when (fboundp sym) + (describe-function sym))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +;;; Debugging + +(defclass slime-env (env:environment) + ((debugger-hook :initarg :debugger-hoook))) + +(defun slime-env (hook io-bindings) + (make-instance 'slime-env :name "SLIME Environment" + :io-bindings io-bindings + :debugger-hoook hook)) + +(defmethod env-internals:environment-display-notifier + ((env slime-env) &key restarts condition) + (declare (ignore restarts condition)) + (swank:swank-debugger-hook condition *debugger-hook*)) + +(defmethod env-internals:environment-display-debugger ((env slime-env)) + *debug-io*) + +(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) + (apply #'swank:y-or-n-p-in-emacs msg args)) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook)) + (env:with-environment ((slime-env hook '())) + (funcall fun)))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setf (env:environment) (slime-env function '()))) + +(defvar *sldb-top-frame*) + +(defun interesting-frame-p (frame) + (cond ((or (dbg::call-frame-p frame) + (dbg::derived-call-frame-p frame) + (dbg::foreign-frame-p frame) + (dbg::interpreted-call-frame-p frame)) + t) + ((dbg::catch-frame-p frame) dbg:*print-catch-frames*) + ((dbg::binding-frame-p frame) dbg:*print-binding-frames*) + ((dbg::handler-frame-p frame) dbg:*print-handler-frames*) + ((dbg::restart-frame-p frame) dbg:*print-restart-frames*) + (t nil))) + +(defun nth-next-frame (frame n) + "Unwind FRAME N times." + (do ((frame frame (dbg::frame-next frame)) + (i n (if (interesting-frame-p frame) (1- i) i))) + ((or (not frame) + (and (interesting-frame-p frame) (zerop i))) + frame))) + +(defun nth-frame (index) + (nth-next-frame *sldb-top-frame* index)) + +(defun find-top-frame () + "Return the most suitable top-frame for the debugger." + (flet ((find-named-frame (name) + (do ((frame (dbg::debugger-stack-current-frame + dbg::*debugger-stack*) + (nth-next-frame frame 1))) + ((or (null frame) ; no frame found! + (and (dbg::call-frame-p frame) + (eq (dbg::call-frame-function-name frame) + name))) + (nth-next-frame frame 1))))) + (or (find-named-frame 'invoke-debugger) + (find-named-frame 'swank::safe-backtrace) + ;; if we can't find a likely top frame, take any old frame + ;; at the top + (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))) + +(defimplementation call-with-debugging-environment (fn) + (dbg::with-debugger-stack () + (let ((*sldb-top-frame* (find-top-frame))) + (funcall fn)))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum)) + (backtrace '())) + (do ((frame (nth-frame start) (dbg::frame-next frame)) + (i start)) + ((or (not frame) (= i end)) (nreverse backtrace)) + (when (interesting-frame-p frame) + (incf i) + (push frame backtrace))))) + +(defun frame-actual-args (frame) + (let ((*break-on-signals* nil) + (kind nil)) + (loop for arg in (dbg::call-frame-arglist frame) + if (eq kind '&rest) + nconc (handler-case + (dbg::dbg-eval arg frame) + (error (e) (list (format nil "<~A>" arg)))) + and do (loop-finish) + else + if (member arg '(&rest &optional &key)) + do (setq kind arg) + else + nconc + (handler-case + (nconc (and (eq kind '&key) + (list (cond ((symbolp arg) + (intern (symbol-name arg) :keyword)) + ((and (consp arg) (symbolp (car arg))) + (intern (symbol-name (car arg)) + :keyword)) + (t (caar arg))))) + (list (dbg::dbg-eval + (cond ((symbolp arg) arg) + ((and (consp arg) (symbolp (car arg))) + (car arg)) + (t (cadar arg))) + frame))) + (error (e) (list (format nil "<~A>" arg))))))) + +(defimplementation print-frame (frame stream) + (cond ((dbg::call-frame-p frame) + (prin1 (cons (dbg::call-frame-function-name frame) + (frame-actual-args frame)) + stream)) + (t (princ frame stream)))) + +(defun frame-vars (frame) + (first (dbg::frame-locals-format-list frame #'list 75 0))) + +(defimplementation frame-locals (n) + (let ((frame (nth-frame n))) + (if (dbg::call-frame-p frame) + (mapcar (lambda (var) + (destructuring-bind (name value symbol location) var + (declare (ignore name location)) + (list :name symbol :id 0 + :value value))) + (frame-vars frame))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (destructuring-bind (_n value _s _l) (nth var (frame-vars frame)) + (declare (ignore _n _s _l)) + value))) + +(defimplementation frame-source-location (frame) + (let ((frame (nth-frame frame)) + (callee (if (plusp frame) (nth-frame (1- frame))))) + (if (dbg::call-frame-p frame) + (let ((dspec (dbg::call-frame-function-name frame)) + (cname (and (dbg::call-frame-p callee) + (dbg::call-frame-function-name callee))) + (path (and (dbg::call-frame-p frame) + (dbg::call-frame-edit-path frame)))) + (if dspec + (frame-location dspec cname path)))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::dbg-eval form frame))) + +(defun function-name-package (name) + (typecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql hcl:subfunction)) + (destructuring-bind (name parent) (cdr name) + (declare (ignore name)) + (function-name-package parent))) + ((cons (eql lw:top-level-form)) nil) + (t nil))) + +(defimplementation frame-package (frame-number) + (let ((frame (nth-frame frame-number))) + (if (dbg::call-frame-p frame) + (function-name-package (dbg::call-frame-function-name frame))))) + +(defimplementation return-from-frame (frame-number form) + (let* ((frame (nth-frame frame-number)) + (return-frame (dbg::find-frame-for-return frame))) + (dbg::dbg-return-from-call-frame frame form return-frame + dbg::*debugger-stack*))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::restart-frame frame :same-args t))) + +(defimplementation disassemble-frame (frame-number) + (let* ((frame (nth-frame frame-number))) + (when (dbg::call-frame-p frame) + (let ((function (dbg::get-call-frame-function frame))) + (disassemble function))))) + +;;; Definition finding + +(defun frame-location (dspec callee-name edit-path) + (let ((infos (dspec:find-dspec-locations dspec))) + (cond (infos + (destructuring-bind ((rdspec location) &rest _) infos + (declare (ignore _)) + (let ((name (and callee-name (symbolp callee-name) + (string callee-name))) + (path (edit-path-to-cmucl-source-path edit-path))) + (make-dspec-location rdspec location + `(:call-site ,name :edit-path ,path))))) + (t + (list :error (format nil "Source location not available for: ~S" + dspec)))))) + +;; dbg::call-frame-edit-path is not documented but lets assume the +;; binary representation of the integer EDIT-PATH should be +;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the +;; same as cadadddr. Something is odd with the highest bit. +(defun edit-path-to-cmucl-source-path (edit-path) + (and edit-path + (cons 0 + (let ((n -1)) + (loop for i from (1- (integer-length edit-path)) downto 0 + if (logbitp i edit-path) do (incf n) + else collect (prog1 n (setq n 0))))))) + +;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1) + +(defimplementation find-definitions (name) + (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name))) + (loop for (dspec location) in locations + collect (list dspec (make-dspec-location dspec location))))) + + +;;; Compilation + +(defmacro with-swank-compilation-unit ((location &rest options) &body body) + (lw:rebinding (location) + `(let ((compiler::*error-database* '())) + (with-compilation-unit ,options + (multiple-value-prog1 (progn ,@body) + (signal-error-data-base compiler::*error-database* + ,location) + (signal-undefined-functions compiler::*unknown-functions* + ,location)))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-swank-compilation-unit (input-file) + (compile-file input-file + :output-file output-file + :load load-p + :external-format external-format))) + +(defvar *within-call-with-compilation-hooks* nil + "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.") + +(defvar *undefined-functions-hash* nil + "Hash table to map info about undefined functions to pathnames.") + +(lw:defadvice (compile-file compile-file-and-collect-notes :around) + (pathname &rest rest) + (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest) + (when *within-call-with-compilation-hooks* + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (let ((unfun-info (list unfun dspec))) + (unless (gethash unfun-info *undefined-functions-hash*) + (setf (gethash unfun-info *undefined-functions-hash*) + pathname))))) + compiler::*unknown-functions*)))) + +(defimplementation call-with-compilation-hooks (function) + (let ((compiler::*error-database* '()) + (*undefined-functions-hash* (make-hash-table :test 'equal)) + (*within-call-with-compilation-hooks* t)) + (with-compilation-unit () + (prog1 (funcall function) + (signal-error-data-base compiler::*error-database*) + (signal-undefined-functions compiler::*unknown-functions*))))) + +(defun map-error-database (database fn) + (loop for (filename . defs) in database do + (loop for (dspec . conditions) in defs do + (dolist (c conditions) + (multiple-value-bind (condition path) + (if (consp c) (values (car c) (cdr c)) (values c nil)) + (funcall fn filename dspec condition path)))))) + +(defun lispworks-severity (condition) + (cond ((not condition) :warning) + (t (etypecase condition + #-(or lispworks4 lispworks5) + (conditions:compiler-note :note) + (error :error) + (style-warning :warning) + (warning :warning))))) + +(defun signal-compiler-condition (message location condition) + (check-type message string) + (signal + (make-instance 'compiler-condition :message message + :severity (lispworks-severity condition) + :location location + :original-condition condition))) + +(defvar *temp-file-format* '(:utf-8 :eol-style :lf)) + +(defun compile-from-temp-file (string filename) + (unwind-protect + (progn + (with-open-file (s filename :direction :output + :if-exists :supersede + :external-format *temp-file-format*) + + (write-string string s) + (finish-output s)) + (multiple-value-bind (binary-filename warnings? failure?) + (compile-file filename :load t + :external-format *temp-file-format*) + (declare (ignore warnings?)) + (when binary-filename + (delete-file binary-filename)) + (not failure?))) + (delete-file filename))) + +(defun dspec-function-name-position (dspec fallback) + (etypecase dspec + (cons (let ((name (dspec:dspec-primary-name dspec))) + (typecase name + ((or symbol string) + (list :function-name (string name))) + (t fallback)))) + (null fallback) + (symbol (list :function-name (string dspec))))) + +(defmacro with-fairly-standard-io-syntax (&body body) + "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*." + (let ((package (gensym)) + (readtable (gensym))) + `(let ((,package *package*) + (,readtable *readtable*)) + (with-standard-io-syntax + (let ((*package* ,package) + (*readtable* ,readtable)) + ,@body))))) + +(defun skip-comments (stream) + (let ((pos0 (file-position stream))) + (cond ((equal (ignore-errors (list (read-delimited-list #\( stream))) + '(())) + (file-position stream (1- (file-position stream)))) + (t (file-position stream pos0))))) + +#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3 +(defun dspec-stream-position (stream dspec) + (with-fairly-standard-io-syntax + (loop (let* ((pos (progn (skip-comments stream) (file-position stream))) + (form (read stream nil '#1=#:eof))) + (when (eq form '#1#) + (return nil)) + (labels ((check-dspec (form) + (when (consp form) + (let ((operator (car form))) + (case operator + ((progn) + (mapcar #'check-dspec + (cdr form))) + ((eval-when locally macrolet symbol-macrolet) + (mapcar #'check-dspec + (cddr form))) + ((in-package) + (let ((package (find-package (second form)))) + (when package + (setq *package* package)))) + (otherwise + (let ((form-dspec (dspec:parse-form-dspec form))) + (when (dspec:dspec-equal dspec form-dspec) + (return pos))))))))) + (check-dspec form)))))) + +(defun dspec-file-position (file dspec) + (let* ((*compile-file-pathname* (pathname file)) + (*compile-file-truename* (truename *compile-file-pathname*)) + (*load-pathname* *compile-file-pathname*) + (*load-truename* *compile-file-truename*)) + (with-open-file (stream file) + (let ((pos + #-(or lispworks4.1 lispworks4.2) + (ignore-errors (dspec-stream-position stream dspec)))) + (if pos + (list :position (1+ pos)) + (dspec-function-name-position dspec `(:position 1))))))) + +(defun emacs-buffer-location-p (location) + (and (consp location) + (eq (car location) :emacs-buffer))) + +(defun make-dspec-location (dspec location &optional hints) + (etypecase location + ((or pathname string) + (multiple-value-bind (file err) + (ignore-errors (namestring (truename location))) + (if err + (list :error (princ-to-string err)) + (make-location `(:file ,file) + (dspec-file-position file dspec) + hints)))) + (symbol + `(:error ,(format nil "Cannot resolve location: ~S" location))) + ((satisfies emacs-buffer-location-p) + (destructuring-bind (_ buffer offset) location + (declare (ignore _)) + (make-location `(:buffer ,buffer) + (dspec-function-name-position dspec `(:offset ,offset 0)) + hints))))) + +(defun make-dspec-progenitor-location (dspec location edit-path) + (let ((canon-dspec (dspec:canonicalize-dspec dspec))) + (make-dspec-location + (if canon-dspec + (if (dspec:local-dspec-p canon-dspec) + (dspec:dspec-progenitor canon-dspec) + canon-dspec) + nil) + location + (if edit-path + (list :edit-path (edit-path-to-cmucl-source-path edit-path)))))) + +(defun signal-error-data-base (database &optional location) + (map-error-database + database + (lambda (filename dspec condition edit-path) + (signal-compiler-condition + (format nil "~A" condition) + (make-dspec-progenitor-location dspec (or location filename) edit-path) + condition)))) + +(defun unmangle-unfun (symbol) + "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to +function names like \(SETF GET)." + (cond ((sys::setf-symbol-p symbol) + (sys::setf-pair-from-underlying-name symbol)) + (t symbol))) + +(defun signal-undefined-functions (htab &optional filename) + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (signal-compiler-condition + (format nil "Undefined function ~A" (unmangle-unfun unfun)) + (make-dspec-progenitor-location + dspec + (or filename + (gethash (list unfun dspec) *undefined-functions-hash*)) + nil) + nil))) + htab)) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (assert buffer) + (assert position) + (let* ((location (list :emacs-buffer buffer position)) + (tmpname (hcl:make-temp-file nil "lisp"))) + (with-swank-compilation-unit (location) + (compile-from-temp-file + (with-output-to-string (s) + (let ((*print-radix* t)) + (print `(eval-when (:compile-toplevel) + (setq dspec::*location* (list ,@location))) + s)) + (write-string string s)) + tmpname)))) + +;;; xref + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls hcl:who-calls) +(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too +(defxref calls-who hcl:calls-who) +(defxref list-callers list-callers-internal) +(defxref list-callees list-callees-internal) + +(defun list-callers-internal (name) + (let ((callers (make-array 100 + :fill-pointer 0 + :adjustable t))) + (hcl:sweep-all-objects + #'(lambda (object) + (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object) + #+Harlequin-Unix-Lisp (sys:callablep object) + #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) + (sys:compiled-code-p object) + (system::find-constant$funcallable name object)) + (vector-push-extend object callers)))) + ;; Delay dspec:object-dspec until after sweep-all-objects + ;; to reduce allocation problems. + (loop for object across callers + collect (if (symbolp object) + (list 'function object) + (or (dspec:object-dspec object) object))))) + +(defun list-callees-internal (name) + (let ((callees '())) + (system::find-constant$funcallable + 'junk name + :test #'(lambda (junk constant) + (declare (ignore junk)) + (when (and (symbolp constant) + (fboundp constant)) + (pushnew (list 'function constant) callees :test 'equal)) + ;; Return nil so we iterate over all constants. + nil)) + callees)) + +;; only for lispworks 4.2 and above +#-lispworks4.1 +(progn + (defxref who-references hcl:who-references) + (defxref who-binds hcl:who-binds) + (defxref who-sets hcl:who-sets)) + +(defimplementation who-specializes (classname) + (let ((class (find-class classname nil))) + (when class + (let ((methods (clos:class-direct-methods class))) + (xref-results (mapcar #'dspec:object-dspec methods)))))) + +(defun xref-results (dspecs) + (flet ((frob-locs (dspec locs) + (cond (locs + (loop for (name loc) in locs + collect (list name (make-dspec-location name loc)))) + (t `((,dspec (:error "Source location not available"))))))) + (loop for dspec in dspecs + append (frob-locs dspec (dspec:dspec-definition-locations dspec))))) + +;;; Inspector + +(defmethod emacs-inspect ((o t)) + (lispworks-inspect o)) + +(defmethod emacs-inspect ((o function)) + (lispworks-inspect o)) + +;; FIXME: slot-boundp-using-class in LW works with names so we can't +;; use our method in swank.lisp. +(defmethod emacs-inspect ((o standard-object)) + (lispworks-inspect o)) + +(defun lispworks-inspect (o) + (multiple-value-bind (names values _getter _setter type) + (lw:get-inspector-values o nil) + (declare (ignore _getter _setter)) + (append + (label-value-line "Type" type) + (loop for name in names + for value in values + append (label-value-line name value))))) + +;;; Miscellaneous + +(defimplementation quit-lisp () + (lispworks:quit)) + +;;; Tracing + +(defun parse-fspec (fspec) + "Return a dspec for FSPEC." + (ecase (car fspec) + ((:defmethod) `(method ,(cdr fspec))))) + +(defun tracedp (dspec) + (member dspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (dspec) + (cond ((tracedp dspec) + (eval `(untrace ,dspec)) + (format nil "~S is now untraced." dspec)) + (t + (eval `(trace (,dspec))) + (format nil "~S is now traced." dspec)))) + +(defimplementation toggle-trace (fspec) + (toggle-trace-aux (parse-fspec fspec))) + +;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (cond ((not mp::*multiprocessing*) + (push (list "Initialize SLIME" '() continuation) + mp:*initial-processes*) + (mp:initialize-multiprocessing)) + (t (funcall continuation)))) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name () fn)) + +(defvar *id-lock* (mp:make-lock)) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-lock (*id-lock*) + (or (getf (mp:process-plist thread) 'id) + (setf (getf (mp:process-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (mp:list-all-processes) + :key (lambda (p) (getf (mp:process-plist p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A ~D" + (mp:process-whostate thread) + (mp:process-priority thread))) + +(defimplementation make-lock (&key name) + (mp:make-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (mp:list-all-processes)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defimplementation thread-alive-p (thread) + (mp:process-alive-p thread)) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock :name "thread mailbox")) + (queue '() :type list)) + +(defvar *mailbox-lock* (mp:make-lock)) + +(defun mailbox (thread) + (mp:with-lock (*mailbox-lock*) + (or (getf (mp:process-plist thread) 'mailbox) + (setf (getf (mp:process-plist thread) 'mailbox) + (make-mailbox))))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox mp:*current-process*)) + (lock (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mp:with-lock (lock "receive-if/try") + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox))))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (mp:with-lock ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(let ((alist '()) + (lock (mp:make-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-lock (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-lock (lock) + (cdr (assoc name alist))))) + + +(defimplementation set-default-initial-binding (var form) + (setq mp:*process-initial-bindings* + (acons var `(eval (quote ,form)) + mp:*process-initial-bindings* ))) + +(defimplementation thread-attributes (thread) + (list :priority (mp:process-priority thread) + :idle (mp:process-idle-time thread))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :value args)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/match.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/match.lisp new file mode 100644 index 0000000..d6200db --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/match.lisp @@ -0,0 +1,242 @@ +;; +;; SELECT-MATCH macro (and IN macro) +;; +;; Copyright 1990 Stephen Adams +;; +;; You are free to copy, distribute and make derivative works of this +;; source provided that this copyright notice is displayed near the +;; beginning of the file. No liability is accepted for the +;; correctness or performance of the code. If you modify the code +;; please indicate this fact both at the place of modification and in +;; this copyright message. +;; +;; Stephen Adams +;; Department of Electronics and Computer Science +;; University of Southampton +;; SO9 5NH, UK +;; +;; sra@ecs.soton.ac.uk +;; + +;; +;; Synopsis: +;; +;; (select-match expression +;; (pattern action+)*) +;; +;; --- or --- +;; +;; (select-match expression +;; pattern => expression +;; pattern => expression +;; ...) +;; +;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1) +;; | symbol ;matches anything +;; | 'anything ;must be EQUAL +;; | (pattern = pattern) ;both patterns must match +;; | (#'function pattern) ;predicate test +;; | (pattern . pattern) ;cons cell +;; + +;; Example +;; +;; (select-match item +;; (('if e1 e2 e3) 'if-then-else) ;(1) +;; ((#'oddp k) 'an-odd-integer) ;(2) +;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3) +;; (other 'anything-else)) ;(4) +;; +;; Notes +;; +;; . Each pattern is tested in turn. The first match is taken. +;; +;; . If no pattern matches, an error is signalled. +;; +;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e. +;; numbers, strings, characters, etc.) match things which are EQUAL. +;; +;; . Quoted patterns (which are CONSTANTP) are constants. +;; +;; . Symbols match anything. The symbol is bound to the matched item +;; for the execution of the actions. +;; For example, (SELECT-MATCH '(1 2 3) +;; (1 . X) => X) +;; returns (2 3) because X is bound to the cdr of the candidate. +;; +;; . The two pattern match (p1 = p2) can be used to name parts +;; of the matched structure. For example, (ALL = (HD . TL)) +;; matches a cons cell. ALL is bound to the cons cell, HD to its car +;; and TL to its tail. +;; +;; . A predicate test applies the predicate to the item being matched. +;; If the predicate returns NIL then the match fails. +;; If it returns truth, then the nested pattern is matched. This is +;; often just a symbol like K in the example. +;; +;; . Care should be taken with the domain values for predicate matches. +;; If, in the above eg, item is not an integer, an error would occur +;; during the test. A safer pattern would be +;; (#'integerp (#'oddp k)) +;; This would only test for oddness of the item was an integer. +;; +;; . A single symbol will match anything so it can be used as a default +;; case, like OTHER above. +;; + +(in-package swank/match) + +(defmacro match (expression &body patterns) + `(select-match ,expression ,@patterns)) + +(defmacro select-match (expression &rest patterns) + (let* ((do-let (not (atom expression))) + (key (if do-let (gensym) expression)) + (cbody (expand-select-patterns key patterns)) + (cform `(cond . ,cbody))) + (if do-let + `(let ((,key ,expression)) ,cform) + cform))) + +(defun expand-select-patterns (key patterns) + (if (eq (second patterns) '=>) + (expand-select-patterns-style-2 key patterns) + (expand-select-patterns-style-1 key patterns))) + +(defun expand-select-patterns-style-1 (key patterns) + (if (null patterns) + `((t (error "Case select pattern match failure on ~S" ,key))) + (let* ((pattern (caar patterns)) + (actions (cdar patterns)) + (rest (cdr patterns)) + (test (compile-select-test key pattern)) + (bindings (compile-select-bindings key pattern actions))) + `(,(if bindings `(,test (let ,bindings . ,actions)) + `(,test . ,actions)) + . ,(unless (eq test t) + (expand-select-patterns-style-1 key rest)))))) + +(defun expand-select-patterns-style-2 (key patterns) + (cond ((null patterns) + `((t (error "Case select pattern match failure on ~S" ,key)))) + (t (when (or (< (length patterns) 3) + (not (eq (second patterns) '=>))) + (error "Illegal patterns: ~S" patterns)) + (let* ((pattern (first patterns)) + (actions (list (third patterns))) + (rest (cdddr patterns)) + (test (compile-select-test key pattern)) + (bindings (compile-select-bindings key pattern actions))) + `(,(if bindings `(,test (let ,bindings . ,actions)) + `(,test . ,actions)) + . ,(unless (eq test t) + (expand-select-patterns-style-2 key rest))))))) + +(defun compile-select-test (key pattern) + (let ((tests (remove t (compile-select-tests key pattern)))) + (cond + ;; note AND does this anyway, but this allows us to tell if + ;; the pattern will always match. + ((null tests) t) + ((= (length tests) 1) (car tests)) + (t `(and . ,tests))))) + +(defun compile-select-tests (key pattern) + (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql) + ((symbolp pattern) 'eq) + (t 'equal)) + ,key ,pattern))) + ((symbolp pattern) '(t)) + ((select-double-match? pattern) + (append + (compile-select-tests key (first pattern)) + (compile-select-tests key (third pattern)))) + ((select-predicate? pattern) + (append + `((,(second (first pattern)) ,key)) + (compile-select-tests key (second pattern)))) + ((consp pattern) + (append + `((consp ,key)) + (compile-select-tests (cs-car key) (car + pattern)) + (compile-select-tests (cs-cdr key) (cdr + pattern)))) + (t (error "Illegal select pattern: ~S" pattern)))) + + +(defun compile-select-bindings (key pattern action) + (cond ((constantp pattern) '()) + ((symbolp pattern) + (if (select-in-tree pattern action) + `((,pattern ,key)) + '())) + ((select-double-match? pattern) + (append + (compile-select-bindings key (first pattern) action) + (compile-select-bindings key (third pattern) action))) + ((select-predicate? pattern) + (compile-select-bindings key (second pattern) action)) + ((consp pattern) + (append + (compile-select-bindings (cs-car key) (car pattern) + action) + (compile-select-bindings (cs-cdr key) (cdr pattern) + action))))) + +(defun select-in-tree (atom tree) + (or (eq atom tree) + (if (consp tree) + (or (select-in-tree atom (car tree)) + (select-in-tree atom (cdr tree)))))) + +(defun select-double-match? (pattern) + ;; ( = ) + (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern)) + (null (cdddr pattern)) + (eq (second pattern) '=))) + +(defun select-predicate? (pattern) + ;; ((function ) ) + (and (consp pattern) + (consp (cdr pattern)) + (null (cddr pattern)) + (consp (first pattern)) + (consp (cdr (first pattern))) + (null (cddr (first pattern))) + (eq (caar pattern) 'function))) + +(defun cs-car (exp) + (cs-car/cdr 'car exp + '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr) + (cdar . cadar) (cddr . caddr) + (caaar . caaaar) (caadr . caaadr) (cadar . caadar) + (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr) + (cddar . caddar) (cdddr . cadddr)))) + +(defun cs-cdr (exp) + (cs-car/cdr 'cdr exp + '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr) + (cdar . cddar) (cddr . cdddr) + (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) + (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr) + (cddar . cdddar) (cdddr . cddddr)))) + +(defun cs-car/cdr (op exp table) + (if (and (consp exp) (= (length exp) 2)) + (let ((replacement (assoc (car exp) table))) + (if replacement + `(,(cdr replacement) ,(second exp)) + `(,op ,exp))) + `(,op ,exp))) + +;; (setf c1 '(select-match x (a 1) (b 2 3 4))) +;; (setf c2 '(select-match (car y) +;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ +;; else)))) +;; (setf c3 '(select-match (caddr y) +;; ((all = (x y)) (list x y all)) +;; ((a '= b) (list 'assign a b)) +;; ((#'oddp k) (1+ k))))) + + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/mezzano.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/mezzano.lisp new file mode 100644 index 0000000..b4d8feb --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/mezzano.lisp @@ -0,0 +1,730 @@ +;;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-mezzano.lisp --- SLIME backend for Mezzano +;;; +;;; This code has been placed in the Public Domain. All warranties are +;;; disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/mezzano + (:use cl swank/backend)) + +(in-package swank/mezzano) + +;;; swank-mop + +(import-swank-mop-symbols :mezzano.clos '(:class-default-initargs + :class-direct-default-initargs + :specializer-direct-methods + :generic-function-declarations)) + +(defun swank-mop:specializer-direct-methods (obj) + (declare (ignore obj)) + '()) + +(defun swank-mop:generic-function-declarations (gf) + (declare (ignore gf)) + '()) + +(defimplementation gray-package-name () + "MEZZANO.GRAY") + +;;;; TCP server + +(defclass listen-socket () + ((%host :initarg :host) + (%port :initarg :port) + (%connection-fifo :initarg :connections) + (%callback :initarg :callback))) + +(defimplementation create-socket (host port &key backlog) + (let* ((connections (mezzano.supervisor:make-fifo (or backlog 10))) + (sock (make-instance 'listen-socket + :host host + :port port + :connections connections + :callback (lambda (conn) + (do-connection conn connections)))) + (listen-fn (slot-value sock '%callback))) + (when (find port mezzano.network.tcp::*server-alist* + :key #'first) + (error "Server already listening on port ~D" port)) + (push (list port listen-fn) mezzano.network.tcp::*server-alist*) + sock)) + +(defun do-connection (conn connections) + (when (not (mezzano.supervisor:fifo-push + (make-instance 'mezzano.network.tcp::tcp-stream :connection conn) + connections + nil)) + ;; Drop connections when they can't be handled. + (close conn))) + +(defimplementation local-port (socket) + (slot-value socket '%port)) + +(defimplementation close-socket (socket) + (setf mezzano.network.tcp::*server-alist* + (remove (slot-value socket '%callback) + mezzano.network.tcp::*server-alist* + :key #'second)) + (let ((fifo (slot-value socket '%connection-fifo))) + (loop + (let ((conn (mezzano.supervisor:fifo-pop fifo nil))) + (when (not conn) + (return)) + (close conn)))) + (setf (slot-value socket '%connection-fifo) nil)) + +(defimplementation accept-connection (socket &key external-format + buffering timeout) + (declare (ignore external-format buffering timeout)) + (loop + (let ((value (mezzano.supervisor:fifo-pop + (slot-value socket '%connection-fifo) + nil))) + (when value + (return value))) + ;; Poke standard-input every now and then to keep the console alive. + (listen) + (sleep 0.05))) + +(defimplementation preferred-communication-style () + :spawn) + +;;;; Unix signals +;;;; ???? + +(defimplementation getpid () + 0) + +;;;; Compilation + +(defun signal-compiler-condition (condition severity) + (signal 'compiler-condition + :original-condition condition + :severity severity + :message (format nil "~A" condition) + :location nil)) + +(defimplementation call-with-compilation-hooks (func) + (handler-bind + ((error + (lambda (c) + (signal-compiler-condition c :error))) + (warning + (lambda (c) + (signal-compiler-condition c :warning))) + (style-warning + (lambda (c) + (signal-compiler-condition c :style-warning)))) + (funcall func))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore buffer policy)) + (let* ((*load-pathname* (ignore-errors (pathname filename))) + (*load-truename* (when *load-pathname* + (ignore-errors (truename *load-pathname*)))) + (sys.int::*top-level-form-number* `(:position ,position))) + (with-compilation-hooks () + (eval (read-from-string (concatenate 'string "(progn " string " )"))))) + t) + +(defimplementation swank-compile-file (input-file output-file load-p + external-format + &key policy) + (with-compilation-hooks () + (multiple-value-prog1 + (compile-file input-file + :output-file output-file + :external-format external-format) + (when load-p + (load output-file))))) + +(defimplementation find-external-format (coding-system) + (if (or (equal coding-system "utf-8") + (equal coding-system "utf-8-unix")) + :default + nil)) + +;;;; Debugging + +;; Definitely don't allow this. +(defimplementation install-debugger-globally (function) + (declare (ignore function)) + nil) + +(defvar *current-backtrace*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let ((*current-backtrace* '())) + (let ((prev-fp nil)) + (sys.int::map-backtrace + (lambda (i fp) + (push (list (1- i) fp prev-fp) *current-backtrace*) + (setf prev-fp fp)))) + (setf *current-backtrace* (reverse *current-backtrace*)) + ;; Drop the topmost frame, which is finished call to MAP-BACKTRACE. + (pop *current-backtrace*) + ;; And the next one for good measure. + (pop *current-backtrace*) + (funcall debugger-loop-fn))) + +(defimplementation compute-backtrace (start end) + (subseq *current-backtrace* start end)) + +(defimplementation print-frame (frame stream) + (format stream "~S" (sys.int::function-from-frame frame))) + +(defimplementation frame-source-location (frame-number) + (let* ((frame (nth frame-number *current-backtrace*)) + (fn (sys.int::function-from-frame frame))) + (function-location fn))) + +(defimplementation frame-locals (frame-number) + (loop + with frame = (nth frame-number *current-backtrace*) + for (name id location repr) in (sys.int::frame-locals frame) + collect (list :name name + :id id + :value (sys.int::read-frame-slot frame location repr)))) + +(defimplementation frame-var-value (frame-number var-id) + (let* ((frame (nth frame-number *current-backtrace*)) + (locals (sys.int::frame-locals frame)) + (info (nth var-id locals))) + (if info + (destructuring-bind (name id location repr) + info + (declare (ignore id)) + (values (sys.int::read-frame-slot frame location repr) name)) + (error "Invalid variable id ~D for frame number ~D." + var-id frame-number)))) + +;;;; Definition finding + +(defun top-level-form-position (pathname tlf) + (ignore-errors + (with-open-file (s pathname) + (loop + repeat tlf + do (with-standard-io-syntax + (let ((*read-suppress* t) + (*read-eval* nil)) + (read s nil)))) + (let ((default (make-pathname :host (pathname-host s)))) + (make-location `(:file ,(enough-namestring s default)) + `(:position ,(1+ (file-position s)))))))) + +(defun function-location (function) + "Return a location object for FUNCTION." + (let* ((info (sys.int::function-debug-info function)) + (pathname (sys.int::debug-info-source-pathname info)) + (tlf (sys.int::debug-info-source-top-level-form-number info))) + (cond ((and (consp tlf) + (eql (first tlf) :position)) + (let ((default (make-pathname :host (pathname-host pathname)))) + (make-location `(:file ,(enough-namestring pathname default)) + `(:position ,(second tlf))))) + (t + (top-level-form-position pathname tlf))))) + +(defun method-definition-name (name method) + `(defmethod ,name + ,@(mezzano.clos:method-qualifiers method) + ,(mapcar (lambda (x) + (typecase x + (mezzano.clos:class + (mezzano.clos:class-name x)) + (mezzano.clos:eql-specializer + `(eql ,(mezzano.clos:eql-specializer-object x))) + (t x))) + (mezzano.clos:method-specializers method)))) + +(defimplementation find-definitions (name) + (let ((result '())) + (labels + ((frob-fn (dspec fn) + (let ((loc (function-location fn))) + (when loc + (push (list dspec loc) result)))) + (try-fn (name) + (when (valid-function-name-p name) + (when (and (fboundp name) + (not (and (symbolp name) + (or (special-operator-p name) + (macro-function name))))) + (let ((fn (fdefinition name))) + (cond ((typep fn 'mezzano.clos:standard-generic-function) + (dolist (m (mezzano.clos:generic-function-methods fn)) + (frob-fn (method-definition-name name m) + (mezzano.clos:method-function m)))) + (t + (frob-fn `(defun ,name) fn))))) + (when (compiler-macro-function name) + (frob-fn `(define-compiler-macro ,name) + (compiler-macro-function name)))))) + (try-fn name) + (try-fn `(setf name)) + (try-fn `(sys.int::cas name)) + (when (and (symbolp name) + (get name 'sys.int::setf-expander)) + (frob-fn `(define-setf-expander ,name) + (get name 'sys.int::setf-expander))) + (when (and (symbolp name) + (macro-function name)) + (frob-fn `(defmacro ,name) + (macro-function name)))) + result)) + +;;;; XREF +;;; Simpler variants. + +(defun find-all-frefs () + (let ((frefs (make-array 500 :adjustable t :fill-pointer 0)) + (keep-going t)) + (loop + (when (not keep-going) + (return)) + (adjust-array frefs (* (array-dimension frefs 0) 2)) + (setf keep-going nil + (fill-pointer frefs) 0) + ;; Walk the wired area looking for FREFs. + (sys.int::walk-area + :wired + (lambda (object address size) + (when (sys.int::function-reference-p object) + (when (not (vector-push object frefs)) + (setf keep-going t)))))) + (remove-duplicates (coerce frefs 'list)))) + +(defimplementation list-callers (function-name) + (let ((fref-for-fn (sys.int::function-reference function-name)) + (callers '())) + (loop + for fref in (find-all-frefs) + for fn = (sys.int::function-reference-function fref) + for name = (sys.int::function-reference-name fref) + when fn + do + (cond ((typep fn 'standard-generic-function) + (dolist (m (mezzano.clos:generic-function-methods fn)) + (let* ((mf (mezzano.clos:method-function m)) + (mf-frefs (get-all-frefs-in-function mf))) + (when (member fref-for-fn mf-frefs) + (push `((defmethod ,name + ,@(mezzano.clos:method-qualifiers m) + ,(mapcar #'specializer-name + (mezzano.clos:method-specializers m))) + ,(function-location mf)) + callers))))) + ((member fref-for-fn + (get-all-frefs-in-function fn)) + (push `((defun ,name) ,(function-location fn)) callers)))) + callers)) + +(defun specializer-name (specializer) + (if (typep specializer 'standard-class) + (mezzano.clos:class-name specializer) + specializer)) + +(defun get-all-frefs-in-function (function) + (when (sys.int::funcallable-std-instance-p function) + (setf function (sys.int::funcallable-std-instance-function function))) + (when (sys.int::closure-p function) + (setf function (sys.int::%closure-function function))) + (loop + for i below (sys.int::function-pool-size function) + for entry = (sys.int::function-pool-object function i) + when (sys.int::function-reference-p entry) + collect entry + when (compiled-function-p entry) ; closures + append (get-all-frefs-in-function entry))) + +(defimplementation list-callees (function-name) + (let* ((fn (fdefinition function-name)) + ;; Grovel around in the function's constant pool looking for + ;; function-references. These may be for #', but they're + ;; probably going to be for normal calls. + ;; TODO: This doesn't work well on interpreted functions or + ;; funcallable instances. + (callees (remove-duplicates (get-all-frefs-in-function fn)))) + (loop + for fref in callees + for name = (sys.int::function-reference-name fref) + for fn = (sys.int::function-reference-function fref) + when fn + collect `((defun ,name) ,(function-location fn))))) + +;;;; Documentation + +(defimplementation arglist (name) + (let ((macro (when (symbolp name) + (macro-function name))) + (fn (if (functionp name) + name + (ignore-errors (fdefinition name))))) + (cond + (macro + (get name 'sys.int::macro-lambda-list)) + (fn + (cond + ((typep fn 'mezzano.clos:standard-generic-function) + (mezzano.clos:generic-function-lambda-list fn)) + (t + (function-lambda-list fn)))) + (t :not-available)))) + +(defun function-lambda-list (function) + (sys.int::debug-info-lambda-list + (sys.int::function-debug-info function))) + +(defimplementation type-specifier-p (symbol) + (cond + ((or (get symbol 'sys.int::type-expander) + (get symbol 'sys.int::compound-type) + (get symbol 'sys.int::type-symbol)) + t) + (t :not-available))) + +(defimplementation function-name (function) + (sys.int::function-name function)) + +(defimplementation valid-function-name-p (form) + "Is FORM syntactically valid to name a function? + If true, FBOUNDP should not signal a type-error for FORM." + (flet ((length=2 (list) + (and (not (null (cdr list))) (null (cddr list))))) + (or (symbolp form) + (and (consp form) (length=2 form) + (or (eq (first form) 'setf) + (eq (first form) 'sys.int::cas)) + (symbolp (second form)))))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (when (boundp symbol) + (setf (getf result :variable) nil)) + (when (and (fboundp symbol) + (not (macro-function symbol))) + (setf (getf result :function) + (function-docstring symbol))) + (when (fboundp `(setf ,symbol)) + (setf (getf result :setf) + (function-docstring `(setf ,symbol)))) + (when (get symbol 'sys.int::setf-expander) + (setf (getf result :setf) nil)) + (when (special-operator-p symbol) + (setf (getf result :special-operator) nil)) + (when (macro-function symbol) + (setf (getf result :macro) nil)) + (when (compiler-macro-function symbol) + (setf (getf result :compiler-macro) nil)) + (when (type-specifier-p symbol) + (setf (getf result :type) nil)) + (when (find-class symbol nil) + (setf (getf result :class) nil)) + result)) + +(defun function-docstring (function-name) + (let* ((definition (fdefinition function-name)) + (debug-info (sys.int::function-debug-info definition))) + (sys.int::debug-info-docstring debug-info))) + +;;;; Multithreading + +;; FIXME: This should be a weak table. +(defvar *thread-ids-for-emacs* (make-hash-table)) +(defvar *next-thread-id-for-emacs* 0) +(defvar *thread-id-for-emacs-lock* (mezzano.supervisor:make-mutex + "SWANK thread ID table")) + +(defimplementation spawn (fn &key name) + (mezzano.supervisor:make-thread fn :name name)) + +(defimplementation thread-id (thread) + (mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*) + (let ((id (gethash thread *thread-ids-for-emacs*))) + (when (null id) + (setf id (incf *next-thread-id-for-emacs*) + (gethash thread *thread-ids-for-emacs*) id + (gethash id *thread-ids-for-emacs*) thread)) + id))) + +(defimplementation find-thread (id) + (mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*) + (gethash id *thread-ids-for-emacs*))) + +(defimplementation thread-name (thread) + (mezzano.supervisor:thread-name thread)) + +(defimplementation thread-status (thread) + (format nil "~:(~A~)" (mezzano.supervisor:thread-state thread))) + +(defimplementation current-thread () + (mezzano.supervisor:current-thread)) + +(defimplementation all-threads () + (mezzano.supervisor:all-threads)) + +(defimplementation thread-alive-p (thread) + (not (eql (mezzano.supervisor:thread-state thread) :dead))) + +(defimplementation interrupt-thread (thread fn) + (mezzano.supervisor:establish-thread-foothold thread fn)) + +(defimplementation kill-thread (thread) + ;; Documentation says not to execute unwind-protected sections, but there's + ;; no way to do that. + ;; And killing threads at arbitrary points without unwinding them is a good + ;; way to hose the system. + (mezzano.supervisor:terminate-thread thread)) + +(defvar *mailbox-lock* (mezzano.supervisor:make-mutex "mailbox lock")) +(defvar *mailboxes* (list)) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mezzano.supervisor:make-mutex)) + (queue '() :type list)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + ;; Use weak pointers to avoid holding on to dead threads forever. + (mezzano.supervisor:with-mutex (*mailbox-lock*) + ;; Flush forgotten threads. + (setf *mailboxes* + (remove-if-not #'sys.int::weak-pointer-value *mailboxes*)) + (loop + for entry in *mailboxes* + do + (multiple-value-bind (key value livep) + (sys.int::weak-pointer-pair entry) + (when (eql key thread) + (return value))) + finally + (let ((mb (make-mailbox :thread thread))) + (push (sys.int::make-weak-pointer thread mb) *mailboxes*) + (return mb))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (mezzano.supervisor:with-mutex (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(defvar *receive-if-sleep-time* 0.02) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (mezzano.supervisor:with-mutex (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t)))) + (sleep *receive-if-sleep-time*)))) + +(defvar *registered-threads* (make-hash-table)) +(defvar *registered-threads-lock* + (mezzano.supervisor:make-mutex "registered threads lock")) + +(defimplementation register-thread (name thread) + (declare (type symbol name)) + (mezzano.supervisor:with-mutex (*registered-threads-lock*) + (etypecase thread + (null + (remhash name *registered-threads*)) + (mezzano.supervisor:thread + (setf (gethash name *registered-threads*) thread)))) + nil) + +(defimplementation find-registered (name) + (mezzano.supervisor:with-mutex (*registered-threads-lock*) + (values (gethash name *registered-threads*)))) + +(defimplementation wait-for-input (streams &optional timeout) + (loop + (let ((ready '())) + (dolist (s streams) + (when (or (listen s) + (and (typep s 'mezzano.network.tcp::tcp-stream) + (mezzano.network.tcp::tcp-connection-closed-p s))) + (push s ready))) + (when ready + (return ready)) + (when (check-slime-interrupts) + (return :interrupt)) + (when timeout + (return '())) + (sleep 1) + (when (numberp timeout) + (decf timeout 1) + (when (not (plusp timeout)) + (return '())))))) + +;;;; Locks + +(defstruct recursive-lock + mutex + (depth 0)) + +(defimplementation make-lock (&key name) + (make-recursive-lock + :mutex (mezzano.supervisor:make-mutex name))) + +(defimplementation call-with-lock-held (lock function) + (cond ((mezzano.supervisor:mutex-held-p + (recursive-lock-mutex lock)) + (unwind-protect + (progn (incf (recursive-lock-depth lock)) + (funcall function)) + (decf (recursive-lock-depth lock)))) + (t + (mezzano.supervisor:with-mutex ((recursive-lock-mutex lock)) + (multiple-value-prog1 + (funcall function) + (assert (eql (recursive-lock-depth lock) 0))))))) + +;;;; Character names + +(defimplementation character-completion-set (prefix matchp) + ;; TODO: Unicode characters too. + (loop + for names in sys.int::*char-name-alist* + append + (loop + for name in (rest names) + when (funcall matchp prefix name) + collect name))) + +;;;; Inspector + +(defmethod emacs-inspect ((o function)) + (case (sys.int::%object-tag o) + (#.sys.int::+object-tag-function+ + (label-value-line* + (:name (sys.int::function-name o)) + (:arglist (arglist o)) + (:debug-info (sys.int::function-debug-info o)))) + (#.sys.int::+object-tag-closure+ + (append + (label-value-line :function (sys.int::%closure-function o)) + `("Closed over values:" (:newline)) + (loop + for i below (sys.int::%closure-length o) + append (label-value-line i (sys.int::%closure-value o i))))) + (t + (call-next-method)))) + +(defmethod emacs-inspect ((o sys.int::weak-pointer)) + (label-value-line* + (:key (sys.int::weak-pointer-key o)) + (:value (sys.int::weak-pointer-value o)))) + +(defmethod emacs-inspect ((o sys.int::function-reference)) + (label-value-line* + (:name (sys.int::function-reference-name o)) + (:function (sys.int::function-reference-function o)))) + +(defmethod emacs-inspect ((object structure-object)) + (let ((class (class-of object))) + `("Class: " (:value ,class) (:newline) + ,@(swank::all-slots-for-inspector object)))) + +(in-package :swank) + +(defmethod all-slots-for-inspector ((object structure-object)) + (let* ((class (class-of object)) + (direct-slots (swank-mop:class-direct-slots class)) + (effective-slots (swank-mop:class-slots class)) + (longest-slot-name-length + (loop for slot :in effective-slots + maximize (length (symbol-name + (swank-mop:slot-definition-name slot))))) + (checklist + (reinitialize-checklist + (ensure-istate-metadata object :checklist + (make-checklist (length effective-slots))))) + (grouping-kind + ;; We box the value so we can re-set it. + (ensure-istate-metadata object :grouping-kind + (box *inspector-slots-default-grouping*))) + (sort-order + (ensure-istate-metadata object :sort-order + (box *inspector-slots-default-order*))) + (sort-predicate (ecase (ref sort-order) + (:alphabetically #'string<) + (:unsorted (constantly nil)))) + (sorted-slots (sort (copy-seq effective-slots) + sort-predicate + :key #'swank-mop:slot-definition-name)) + (effective-slots + (ecase (ref grouping-kind) + (:all sorted-slots) + (:inheritance (stable-sort-by-inheritance sorted-slots + class sort-predicate))))) + `("--------------------" + (:newline) + " Group slots by inheritance " + (:action ,(ecase (ref grouping-kind) + (:all "[ ]") + (:inheritance "[X]")) + ,(lambda () + ;; We have to do this as the order of slots will + ;; be sorted differently. + (fill (checklist.buttons checklist) nil) + (setf (ref grouping-kind) + (ecase (ref grouping-kind) + (:all :inheritance) + (:inheritance :all)))) + :refreshp t) + (:newline) + " Sort slots alphabetically " + (:action ,(ecase (ref sort-order) + (:unsorted "[ ]") + (:alphabetically "[X]")) + ,(lambda () + (fill (checklist.buttons checklist) nil) + (setf (ref sort-order) + (ecase (ref sort-order) + (:unsorted :alphabetically) + (:alphabetically :unsorted)))) + :refreshp t) + (:newline) + ,@ (case (ref grouping-kind) + (:all + `((:newline) + "All Slots:" + (:newline) + ,@(make-slot-listing checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:inheritance + (list-all-slots-by-inheritance checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:newline) + (:action "[set value]" + ,(lambda () + (do-checklist (idx checklist) + (query-and-set-slot class object + (nth idx effective-slots)))) + :refreshp t) + " " + (:action "[make unbound]" + ,(lambda () + (do-checklist (idx checklist) + (swank-mop:slot-makunbound-using-class + class object (nth idx effective-slots)))) + :refreshp t) + (:newline)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/mkcl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/mkcl.lisp new file mode 100644 index 0000000..53696fb --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/mkcl.lisp @@ -0,0 +1,933 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-mkcl.lisp --- SLIME backend for MKCL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage swank/mkcl + (:use cl swank/backend)) + +(in-package swank/mkcl) + +;;(declaim (optimize (debug 3))) + +(defvar *tmp*) + +(defimplementation gray-package-name () + '#:gray) + +(eval-when (:compile-toplevel :load-toplevel) + + (swank/backend::import-swank-mop-symbols :clos + ;; '(:eql-specializer + ;; :eql-specializer-object + ;; :generic-function-declarations + ;; :specializer-direct-methods + ;; :compute-applicable-methods-using-classes) + nil + )) + + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (mkcl:octets (si:utf-8 string))) + +(defimplementation utf8-to-string (octets) + (string (si:utf-8 octets))) + + +;;;; TCP Server + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the sb-bsd-sockets package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'sockets)) + + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defun accept (socket) + "Like socket-accept, but retry on EINTR." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t ;; bogus + :input t ;; bogus + :buffering buffering ;; bogus + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format + )) + +(defimplementation preferred-communication-style () + :spawn + ) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (si:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, MKCL uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SWANK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + + +;;;; Unix signals + +(defimplementation install-sigint-handler (handler) + (let ((old-handler (symbol-function 'si:terminal-interrupt))) + (setf (symbol-function 'si:terminal-interrupt) + (if (consp handler) + (car handler) + (lambda (&rest args) + (declare (ignore args)) + (funcall handler) + (continue)))) + (list old-handler))) + + +(defimplementation getpid () + (mkcl:getpid)) + +(defimplementation set-default-directory (directory) + (mk-ext::chdir (namestring directory)) + (default-directory)) + +(defimplementation default-directory () + (namestring (mk-ext:getcwd))) + +(defmacro progf (plist &rest forms) + `(let (_vars _vals) + (do ((p ,plist (cddr p))) + ((endp p)) + (push (car p) _vars) + (push (cadr p) _vals)) + (progv _vars _vals ,@forms) + ) + ) + +(defvar *inferior-lisp-sleeping-post* nil) + +(defimplementation quit-lisp () + (progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO streams. + (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*)) + ;;(mk-ext:quit :verbose t) + )) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defun signal-compiler-condition (&rest args) + (signal (apply #'make-condition 'compiler-condition args))) + +#| +(defun handle-compiler-warning (condition) + (signal-compiler-condition + :original-condition condition + :message (format nil "~A" condition) + :severity :warning + :location + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0)) + ;; ;; compiler::*current-form* + ;; (if compiler::*current-function* + ;; (make-location (list :file *compile-filename*) + ;; (list :function-name + ;; (symbol-name + ;; (slot-value compiler::*current-function* + ;; 'compiler::name)))) + (list :error "No location found.") + ;; ) + ))) +|# + +#| +(defun condition-location (condition) + (let ((file (compiler:compiler-message-file condition)) + (position (compiler:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) +|# + +(defun condition-location (condition) + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0)) + ;; ;; compiler::*current-form* ; + ;; (if compiler::*current-function* ; + ;; (make-location (list :file *compile-filename*) ; + ;; (list :function-name ; + ;; (symbol-name ; + ;; (slot-value compiler::*current-function* ; + ;; 'compiler::name)))) ; + (if (typep condition 'compiler::compiler-message) + (make-location (list :file (namestring (compiler:compiler-message-file condition))) + (list :end-position (compiler:compiler-message-file-end-position condition))) + (list :error "No location found.")) + ) + ) + +(defun handle-compiler-message (condition) + (unless (typep condition 'compiler::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (compiler:compiler-fatal-error :error) + (compiler:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((compiler:compiler-message #'handle-compiler-message)) + (funcall function))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (handler-bind (#| + (compiler::compiler-note + #'(lambda (n) + (format t "~%swank saw a compiler note: ~A~%" n) (finish-output) nil)) + (compiler::compiler-warning + #'(lambda (w) + (format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil)) + (compiler::compiler-error + #'(lambda (e) + (format t "~%swank saw a compiler error: ~A~%" e) (finish-output) nil)) + |# + ) + (multiple-value-bind (output-truename warnings-p failure-p) + (compile-file input-file :output-file output-file :external-format external-format) + (values output-truename warnings-p + (or failure-p + (and load-p (not (load output-truename)))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (with-input-from-string (s string) + (when position (file-position position)) + (compile-from-stream s))))) + +(defun compile-from-stream (stream) + (let ((file (mkcl:mkstemp "TMP:MKCL-SWANK-TMPXXXXXX")) + output-truename + warnings-p + failure-p + ) + (with-open-file (s file :direction :output :if-exists :overwrite) + (do ((line (read-line stream nil) (read-line stream nil))) + ((not line)) + (write-line line s))) + (unwind-protect + (progn + (multiple-value-setq (output-truename warnings-p failure-p) + (compile-file file)) + (and (not failure-p) (load output-truename))) + (when (probe-file file) (delete-file file)) + (when (probe-file output-truename) (delete-file output-truename))))) + + +;;;; Documentation + +(defun grovel-docstring-for-arglist (name type) + (flet ((compute-arglist-offset (docstring) + (when docstring + (let ((pos1 (search "Args: " docstring))) + (if pos1 + (+ pos1 6) + (let ((pos2 (search "Syntax: " docstring))) + (when pos2 + (+ pos2 8)))))))) + (let* ((docstring (si::get-documentation name type)) + (pos (compute-arglist-offset docstring))) + (if pos + (multiple-value-bind (arglist errorp) + (ignore-errors + (values (read-from-string docstring t nil :start pos))) + (if (or errorp (not (listp arglist))) + :not-available + arglist + )) + :not-available )))) + +(defimplementation arglist (name) + (cond ((and (symbolp name) (special-operator-p name)) + (let ((arglist (grovel-docstring-for-arglist name 'function))) + (if (consp arglist) (cdr arglist) arglist))) + ((and (symbolp name) (macro-function name)) + (let ((arglist (grovel-docstring-for-arglist name 'function))) + (if (consp arglist) (cdr arglist) arglist))) + ((or (functionp name) (fboundp name)) + (multiple-value-bind (name fndef) + (if (functionp name) + (values (function-name name) name) + (values name (fdefinition name))) + (let ((fle (function-lambda-expression fndef))) + (case (car fle) + (si:lambda-block (caddr fle)) + (t (typecase fndef + (generic-function (clos::generic-function-lambda-list fndef)) + (compiled-function (grovel-docstring-for-arglist name 'function)) + (function :not-available))))))) + (t :not-available))) + +(defimplementation function-name (f) + (si:compiled-function-name f) + ) + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the walker package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'walker)) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (walker:macroexpand-all form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (dolist (type '(:VARIABLE :FUNCTION :CLASS)) + (let ((doc (describe-definition symbol type))) + (when doc + (setf result (list* type doc result))))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defvar *backtrace* '()) + +(defun in-swank-package-p (x) + (and + (symbolp x) + (member (symbol-package x) + (list #.(find-package :swank) + #.(find-package :swank/backend) + #.(ignore-errors (find-package :swank-mop)) + #.(ignore-errors (find-package :swank-loader)))) + t)) + +(defun is-swank-source-p (name) + (setf name (pathname name)) + #+(or) + (pathname-match-p + name + (make-pathname :defaults swank-loader::*source-directory* + :name (pathname-name name) + :type (pathname-type name) + :version (pathname-version name))) + nil) + +(defun is-ignorable-fun-p (x) + (or + (in-swank-package-p (frame-name x)) + (multiple-value-bind (file position) + (ignore-errors (si::compiled-function-file (car x))) + (declare (ignore position)) + (if file (is-swank-source-p file))))) + +(defmacro find-ihs-top (x) + (declare (ignore x)) + '(si::ihs-top)) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* (;;(*tpl-commands* si::tpl-commands) + (*ihs-base* 0) + (*ihs-top* (find-ihs-top 'call-with-debugging-environment)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*read-suppress* nil) + ;;(*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + nil)))) + (declare (special *ihs-current*)) + (loop for f from *frs-base* to *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (mkcl:fixnump name) + (push name (third x))))))) + (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) + (setf *tmp* *backtrace*) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (*ihs-base* (find-ihs-top 'call-with-debugger-hook))) + (funcall fun))) + +(defimplementation compute-backtrace (start end) + (when (numberp end) + (setf end (min end (length *backtrace*)))) + (loop for f in (subseq *backtrace* start end) + collect f)) + +(defimplementation format-sldb-condition (condition) + "Format a condition for display in SLDB." + ;;(princ-to-string condition) + (format nil "~A~%In thread: ~S" condition mt:*thread*) + ) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::compiled-function-file fun) + (and file (make-location + `(:file ,(if (stringp file) file (namestring file))) + ;;`(:position ,position) + `(:end-position , position))))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (setf frame (si::decode-ihs-env (second frame))) + (dolist (record frame) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((or (symbolp record0) (stringp record0)) + (setq variables (acons record0 record1 variables))) + ((not (mkcl:fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) + +(defimplementation print-frame (frame stream) + (let ((function (first frame))) + (let ((fname +;;; (cond ((symbolp function) function) +;;; ((si:instancep function) (slot-value function 'name)) +;;; ((compiled-function-p function) +;;; (or (si::compiled-function-name function) 'lambda)) +;;; (t :zombi)) + (si::get-fname function) + )) + (if (eq fname 'si::bytecode) + (format stream "~A [Evaluation of: ~S]" + fname (function-lambda-expression function)) + (format stream "~A" fname) + ) + (when (si::closurep function) + (format stream + ", closure generated from ~A" + (si::get-fname (si:closure-producer function))) + ) + ) + ) + ) + +(defimplementation frame-source-location (frame-number) + (nth-value 1 (frame-function (elt *backtrace* frame-number)))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + with i = 0 + collect (list :name name :id (prog1 i (incf i)) :value value))) + +(defimplementation frame-var-value (frame-number var-id) + (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id))) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-fun (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-in-env form env))) + +#| +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) +|# + +;;;; Inspector + +(defmethod emacs-inspect ((o t)) + ; ecl clos support leaves some to be desired + (cond + ((streamp o) + (list* + (format nil "~S is an ordinary stream~%" o) + (append + (list + "Open for " + (cond + ((ignore-errors (interactive-stream-p o)) "Interactive") + ((and (input-stream-p o) (output-stream-p o)) "Input and output") + ((input-stream-p o) "Input") + ((output-stream-p o) "Output")) + `(:newline) `(:newline)) + (label-value-line* + ("Element type" (stream-element-type o)) + ("External format" (stream-external-format o))) + (ignore-errors (label-value-line* + ("Broadcast streams" (broadcast-stream-streams o)))) + (ignore-errors (label-value-line* + ("Concatenated streams" (concatenated-stream-streams o)))) + (ignore-errors (label-value-line* + ("Echo input stream" (echo-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Echo output stream" (echo-stream-output-stream o)))) + (ignore-errors (label-value-line* + ("Output String" (get-output-stream-string o)))) + (ignore-errors (label-value-line* + ("Synonym symbol" (synonym-stream-symbol o)))) + (ignore-errors (label-value-line* + ("Input stream" (two-way-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Output stream" (two-way-stream-output-stream o))))))) + ((si:instancep o) ;;t + (let* ((cl (si:instance-class o)) + (slots (clos::class-slots cl))) + (list* (format nil "~S is an instance of class ~A~%" + o (clos::class-name cl)) + (loop for x in slots append + (let* ((name (clos::slot-definition-name x)) + (value (if (slot-boundp o name) + (clos::slot-value o name) + "Unbound" + ))) + (list + (format nil "~S: " name) + `(:value ,value) + `(:newline))))))) + (t (list (format nil "~A" o))))) + +;;;; Definitions + +(defimplementation find-definitions (name) + (if (fboundp name) + (let ((tmp (find-source-location (symbol-function name)))) + `(((defun ,name) ,tmp))))) + +(defimplementation find-source-location (obj) + (setf *tmp* obj) + (or + (typecase obj + (function + (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj)) + (if (and file pos) + (make-location + `(:file ,(if (stringp file) file (namestring file))) + `(:end-position ,pos) ;; `(:position ,pos) + `(:snippet + ,(with-open-file (s file) + (file-position s pos) + (skip-comments-and-whitespace s) + (read-snippet s)))))))) + `(:error (format nil "Source definition of ~S not found" obj)))) + +;;;; Profiling + + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the profile package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'profile)) + + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) + + +;;;; Threads + +(defvar *thread-id-counter* 0) + +(defvar *thread-id-counter-lock* + (mt:make-lock :name "thread id counter lock")) + +(defun next-thread-id () + (mt:with-lock (*thread-id-counter-lock*) + (incf *thread-id-counter*)) + ) + +(defparameter *thread-id-map* (make-hash-table)) +(defparameter *id-thread-map* (make-hash-table)) + +(defvar *thread-id-map-lock* + (mt:make-lock :name "thread id map lock")) + +(defparameter +default-thread-local-variables+ + '(*macroexpand-hook* + *default-pathname-defaults* + *readtable* + *random-state* + *compile-print* + *compile-verbose* + *load-print* + *load-verbose* + *print-array* + *print-base* + *print-case* + *print-circle* + *print-escape* + *print-gensym* + *print-length* + *print-level* + *print-lines* + *print-miser-width* + *print-pprint-dispatch* + *print-pretty* + *print-radix* + *print-readably* + *print-right-margin* + *read-base* + *read-default-float-format* + *read-eval* + *read-suppress* + )) + +(defun thread-local-default-bindings () + (let (local) + (dolist (var +default-thread-local-variables+ local) + (setq local (acons var (symbol-value var) local)) + ))) + +;; mkcl doesn't have weak pointers +(defimplementation spawn (fn &key name initial-bindings) + (let* ((local-defaults (thread-local-default-bindings)) + (thread + ;;(mt:make-thread :name name) + (mt:make-thread :name name + :initial-bindings (nconc initial-bindings + local-defaults)) + ) + (id (next-thread-id))) + (mt:with-lock (*thread-id-map-lock*) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id)) + (mt:thread-preset + thread + #'(lambda () + (unwind-protect + (progn + ;;(format t "~&Starting thread: ~S.~%" name) (finish-output) + (mt:thread-detach nil) + (funcall fn)) + (progn + ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output) + (mt:with-lock (*thread-id-map-lock*) + (remhash thread *id-thread-map*) + (remhash id *thread-id-map*)) + ;;(format t "~&Finished thread: ~S~%" name) (finish-output) + )))) + (mt:thread-enable thread) + (mt:thread-yield) + thread + )) + +(defimplementation thread-id (thread) + (block thread-id + (mt:with-lock (*thread-id-map-lock*) + (or (gethash thread *id-thread-map*) + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id) + id))))) + +(defimplementation find-thread (id) + (mt:with-lock (*thread-id-map-lock*) + (gethash id *thread-id-map*))) + +(defimplementation thread-name (thread) + (mt:thread-name thread)) + +(defimplementation thread-status (thread) + (if (mt:thread-active-p thread) + "RUNNING" + "STOPPED")) + +(defimplementation make-lock (&key name) + (mt:make-lock :name name :recursive t)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mt:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mt:*thread*) + +(defimplementation all-threads () + (mt:all-threads)) + +(defimplementation interrupt-thread (thread fn) + (mt:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (mt:interrupt-thread thread #'mt:terminate-thread) + ) + +(defimplementation thread-alive-p (thread) + (mt:thread-active-p thread)) + +(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock")) +(defvar *mailboxes* (list)) +(declaim (type list *mailboxes*)) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + locked-by + (mutex (mt:make-lock :name "thread mailbox")) + (semaphore (mt:make-semaphore)) + (queue '() :type list)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mt:with-lock (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + +(defimplementation send (thread message) + (handler-case + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) +;; (mt:interrupt-thread +;; thread +;; (lambda () +;; (mt:with-lock (mutex) +;; (setf (mailbox.queue mbox) +;; (nconc (mailbox.queue mbox) (list message)))))) + +;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%" +;; mt:*thread* thread message) (finish-output) + (mt:with-lock (mutex) + (setf (mailbox.locked-by mbox) mt:*thread*) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + ;;(format t "*") (finish-output) + (handler-case + (mt:semaphore-signal (mailbox.semaphore mbox)) + (condition (condition) + (format t "Something went bad with semaphore-signal ~A" condition) (finish-output) + ;;(break) + )) + (setf (mailbox.locked-by mbox) nil) + ) + ;;(format t "+") (finish-output) + ) + (condition (condition) + (format t "~&Error in send: ~S~%" condition) (finish-output)) + ) + ) + +;; (defimplementation receive () +;; (block got-mail +;; (let* ((mbox (mailbox mt:*thread*)) +;; (mutex (mailbox.mutex mbox))) +;; (loop +;; (mt:with-lock (mutex) +;; (if (mailbox.queue mbox) +;; (return-from got-mail (pop (mailbox.queue mbox))))) +;; ;;interrupt-thread will halt this if it takes longer than 1sec +;; (sleep 1))))) + + +(defimplementation receive-if (test &optional timeout) + (handler-case + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox)) + got-one) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + ;;(format t "~&: ~S~%" mt:*thread*) (finish-output) + (handler-case + (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2)) + (condition (condition) + (format t "~&In (swank-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition) + (finish-output) + nil + ) + ) + (mt:with-lock (mutex) + (setf (mailbox.locked-by mbox) mt:*thread*) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (setf (mailbox.locked-by mbox) nil) + ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail)) + (return (car tail)))) + (setf (mailbox.locked-by mbox) nil) + ) + + ;;(format t "/ ~S~%" mt:*thread*) (finish-output) + (when (eq timeout t) (return (values nil t))) +;; (unless got-one +;; (format t "~&In (swank-mkcl) receive-if: semaphore-wait timed out!~%")) + ) + ) + (condition (condition) + (format t "~&Error in (swank-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output) + nil + ) + ) + ) + + +(defmethod stream-finish-output ((stream stream)) + (finish-output stream)) + + +;; + +;;#+windows +(defimplementation doze-in-repl () + (setq *inferior-lisp-sleeping-post* (mt:make-semaphore)) + ;;(loop (sleep 1)) + (mt:semaphore-wait *inferior-lisp-sleeping-post*) + (mk-ext:quit :verbose t) + ) + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/rpc.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/rpc.lisp new file mode 100644 index 0000000..e30cc2c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/rpc.lisp @@ -0,0 +1,162 @@ +;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- +;;; +;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems. +;;; +;;; Created 2010, Terje Norderhaug +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package swank/rpc) + + +;;;;; Input + +(define-condition swank-reader-error (reader-error) + ((packet :type string :initarg :packet + :reader swank-reader-error.packet) + (cause :type reader-error :initarg :cause + :reader swank-reader-error.cause))) + +(defun read-message (stream package) + (let ((packet (read-packet stream))) + (handler-case (values (read-form packet package)) + (reader-error (c) + (error 'swank-reader-error + :packet packet :cause c))))) + +(defun read-packet (stream) + (let* ((length (parse-header stream)) + (octets (read-chunk stream length))) + (handler-case (swank/backend:utf8-to-string octets) + (error (c) + (error 'swank-reader-error + :packet (asciify octets) + :cause c))))) + +(defun asciify (packet) + (with-output-to-string (*standard-output*) + (loop for code across (etypecase packet + (string (map 'vector #'char-code packet)) + (vector packet)) + do (cond ((<= code #x7f) (write-char (code-char code))) + (t (format t "\\x~x" code)))))) + +(defun parse-header (stream) + (parse-integer (map 'string #'code-char (read-chunk stream 6)) + :radix 16)) + +(defun read-chunk (stream length) + (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) + (count (read-sequence buffer stream))) + (cond ((= count length) + buffer) + ((zerop count) + (error 'end-of-file :stream stream)) + (t + (error "Short read: length=~D count=~D" length count))))) + +(defparameter *validate-input* nil + "Set to true to require input that more strictly conforms to the protocol") + +(defun read-form (string package) + (with-standard-io-syntax + (let ((*package* package)) + (if *validate-input* + (validating-read string) + (read-from-string string))))) + +(defun validating-read (string) + (with-input-from-string (*standard-input* string) + (simple-read))) + +(defun simple-read () + "Read a form that conforms to the protocol, otherwise signal an error." + (let ((c (read-char))) + (case c + (#\( (loop collect (simple-read) + while (ecase (read-char) + (#\) nil) + (#\space t)))) + (#\' `(quote ,(simple-read))) + (t + (cond + ((digit-char-p c) + (parse-integer + (map 'simple-string #'identity + (loop for ch = c then (read-char nil nil) + while (and ch (digit-char-p ch)) + collect ch + finally (unread-char ch))))) + ((or (member c '(#\: #\")) (alpha-char-p c)) + (unread-char c) + (read-preserving-whitespace)) + (t (error "Invalid character ~:c" c))))))) + + +;;;;; Output + +(defun write-message (message package stream) + (let* ((string (prin1-to-string-for-emacs message package)) + (octets (handler-case (swank/backend:string-to-utf8 string) + (error (c) (encoding-error c string)))) + (length (length octets))) + (write-header stream length) + (write-sequence octets stream) + (finish-output stream))) + +;; FIXME: for now just tell emacs that we and an encoding problem. +(defun encoding-error (condition string) + (swank/backend:string-to-utf8 + (prin1-to-string-for-emacs + `(:reader-error + ,(asciify string) + ,(format nil "Error during string-to-utf8: ~a" + (or (ignore-errors (asciify (princ-to-string condition))) + (asciify (princ-to-string (type-of condition)))))) + (find-package :cl)))) + +(defun write-header (stream length) + (declare (type (unsigned-byte 24) length)) + ;;(format *trace-output* "length: ~d (#x~x)~%" length length) + (loop for c across (format nil "~6,'0x" length) + do (write-byte (char-code c) stream))) + +(defun switch-to-double-floats (x) + (typecase x + (double-float x) + (float (coerce x 'double-float)) + (null x) + (list (loop for (x . cdr) on x + collect (switch-to-double-floats x) into result + until (atom cdr) + finally (return (append result (switch-to-double-floats cdr))))) + (t x))) + +(defun prin1-to-string-for-emacs (object package) + (with-standard-io-syntax + (let ((*print-case* :downcase) + (*print-readably* nil) + (*print-pretty* nil) + (*package* package) + ;; Emacs has only double floats. + (*read-default-float-format* 'double-float)) + (prin1-to-string (switch-to-double-floats object))))) + + +#| TEST/DEMO: + +(defparameter *transport* + (with-output-to-string (out) + (write-message '(:message (hello "world")) *package* out) + (write-message '(:return 5) *package* out) + (write-message '(:emacs-rex NIL) *package* out))) + +*transport* + +(with-input-from-string (in *transport*) + (loop while (peek-char T in NIL) + collect (read-message in *package*))) + +|# diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/sbcl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/sbcl.lisp new file mode 100644 index 0000000..430c906 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/sbcl.lisp @@ -0,0 +1,2025 @@ +;;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-sbcl.lisp --- SLIME backend for SBCL. +;;; +;;; Created 2003, Daniel Barlow +;;; +;;; This code has been placed in the Public Domain. All warranties are +;;; disclaimed. + +;;; Requires the SB-INTROSPECT contrib. + +;;; Administrivia + +(defpackage swank/sbcl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache)) + +(in-package swank/sbcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sb-bsd-sockets) + (require 'sb-introspect) + (require 'sb-posix) + (require 'sb-cltl2)) + +(declaim (optimize (debug 2) + (sb-c::insert-step-conditions 0) + (sb-c::insert-debug-catch 0))) + +;;; backwards compability tests + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; Generate a form suitable for testing for stepper support (0.9.17) + ;; with #+. + (defun sbcl-with-new-stepper-p () + (with-symbol 'enable-stepping 'sb-impl)) + ;; Ditto for weak hash-tables + (defun sbcl-with-weak-hash-tables () + (with-symbol 'hash-table-weakness 'sb-ext)) + ;; And for xref support (1.0.1) + (defun sbcl-with-xref-p () + (with-symbol 'who-calls 'sb-introspect)) + ;; ... for restart-frame support (1.0.2) + (defun sbcl-with-restart-frame () + (with-symbol 'frame-has-debug-tag-p 'sb-debug)) + ;; ... for :setf :inverse info (1.1.17) + (defun sbcl-with-setf-inverse-meta-info () + (boolean-to-feature-expression + ;; going through FIND-SYMBOL since META-INFO was renamed from + ;; TYPE-INFO in 1.2.10. + (let ((sym (find-symbol "META-INFO" "SB-C"))) + (and sym + (fboundp sym) + (funcall sym :setf :inverse ())))))) + +;;; swank-mop + +(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (sb-pcl::documentation slot t)) + +;; stream support + +(defimplementation gray-package-name () + "SB-GRAY") + +;; Pretty printer calls this, apparently +(defmethod sb-gray:stream-line-length + ((s sb-gray:fundamental-character-input-stream)) + nil) + +;;; Connection info + +(defimplementation lisp-implementation-type-name () + "sbcl") + +;; Declare return type explicitly to shut up STYLE-WARNINGS about +;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below. +(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid)) +(defimplementation getpid () + (sb-posix:getpid)) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (sb-ext:string-to-octets string :external-format :utf8)) + +(defimplementation utf8-to-string (octets) + (sb-ext:octets-to-string octets :external-format :utf8)) + +;;; TCP Server + +(defimplementation preferred-communication-style () + (cond + ;; fixme: when SBCL/win32 gains better select() support, remove + ;; this. + ((member :sb-thread *features*) :spawn) + ((member :win32 *features*) nil) + (t :fd-handler))) + + +(defun resolve-hostname (host) + "Returns valid IPv4 or IPv6 address for the host." + ;; get all IPv4 and IPv6 addresses as a list + (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host))) + ;; remove protocols for which we don't have an address + (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents))) + ;; Return the first one or nil, + ;; but actually, it shouln't return nil, because + ;; get-host-by-name will signal NAME-SERVICE-ERROR condition + ;; if there isn't any address for the host. + (first addresses))) + + +(defimplementation create-socket (host port &key backlog) + (let* ((host-ent (resolve-hostname host)) + (socket (make-instance (cond #+#.(swank/backend:with-symbol 'inet6-socket 'sb-bsd-sockets) + ((eql (sb-bsd-sockets:host-ent-address-type host-ent) 10) + 'sb-bsd-sockets:inet6-socket) + (t + 'sb-bsd-sockets:inet-socket)) + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:host-ent-address host-ent) port) + + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-sys:invalidate-descriptor (socket-fd socket)) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket &key + external-format + buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (accept socket) external-format + (ecase buffering + ((t :full) :full) + ((nil :none) :none) + ((:line) :line)))) + + +;; The SIGIO stuff should probably be removed as it's unlikey that +;; anybody uses it. +#-win32 +(progn + (defimplementation install-sigint-handler (function) + (sb-sys:enable-interrupt sb-unix:sigint + (lambda (&rest args) + (declare (ignore args)) + (sb-sys:invoke-interruption + (lambda () + (sb-sys:with-interrupts + (funcall function))))))) + + (defvar *sigio-handlers* '() + "List of (key . fn) pairs to be called on SIGIO.") + + (defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (sb-sys:with-interrupts + (mapc (lambda (handler) + (funcall (the function (cdr handler)))) + *sigio-handlers*))) + + (defun set-sigio-handler () + (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler)) + + (defun enable-sigio-on-fd (fd) + (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async) + (sb-posix::fcntl fd sb-posix::f-setown (getpid)) + (values)) + + (defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (enable-sigio-on-fd fd) + (push (cons fd fn) *sigio-handlers*))) + + (defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car)) + (sb-sys:invalidate-descriptor fd)) + (close socket))) + + +(defimplementation add-fd-handler (socket fun) + (let ((fd (socket-fd socket)) + (handler nil)) + (labels ((add () + (setq handler (sb-sys:add-fd-handler fd :input #'run))) + (run (fd) + (sb-sys:remove-fd-handler handler) ; prevent recursion + (unwind-protect + (funcall fun) + (when (sb-unix:unix-fstat fd) ; still open? + (add))))) + (add)))) + +(defimplementation remove-fd-handlers (socket) + (sb-sys:invalidate-descriptor (socket-fd socket))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (sb-sys:fd-stream-fd socket)))) + +(defimplementation command-line-args () + sb-ext:*posix-argv*) + +(defimplementation dup (fd) + (sb-posix:dup fd)) + +(defvar *wait-for-input-called*) + +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (when (boundp '*wait-for-input-called*) + (setq *wait-for-input-called* t)) + (let ((*wait-for-input-called* nil)) + (loop + (let ((ready (remove-if-not #'input-ready-p streams))) + (when ready (return ready))) + (when (check-slime-interrupts) + (return :interrupt)) + (when *wait-for-input-called* + (return :interrupt)) + (when timeout + (return nil)) + (sleep 0.1)))) + +(defun fd-stream-input-buffer-empty-p (stream) + (let ((buffer (sb-impl::fd-stream-ibuf stream))) + (or (not buffer) + (= (sb-impl::buffer-head buffer) + (sb-impl::buffer-tail buffer))))) + +#-win32 +(defun input-ready-p (stream) + (or (not (fd-stream-input-buffer-empty-p stream)) + #+#.(swank/backend:with-symbol 'fd-stream-fd-type 'sb-impl) + (eq :regular (sb-impl::fd-stream-fd-type stream)) + (not (sb-impl::sysread-may-block-p stream)))) + +#+win32 +(progn + (defun input-ready-p (stream) + (or (not (fd-stream-input-buffer-empty-p stream)) + (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream))))) + + (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event) + sb-win32:handle) + + (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event) + sb-alien:int + (event sb-win32:handle)) + + (defconstant +fd-read+ #.(ash 1 0)) + (defconstant +fd-close+ #.(ash 1 5)) + + (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) + sb-alien:int + (fd sb-alien:int) + (handle sb-win32:handle) + (mask sb-alien:long)) + + (sb-alien:load-shared-object "kernel32.dll") + (sb-alien:define-alien-routine ("WaitForSingleObjectEx" + wait-for-single-object-ex) + sb-alien:int + (event sb-win32:handle) + (milliseconds sb-alien:long) + (alertable sb-alien:int)) + + ;; see SB-WIN32:HANDLE-LISTEN + (defun handle-listen (handle) + (sb-alien:with-alien ((avail sb-win32:dword) + (buf (array char #.sb-win32::input-record-size))) + (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil + (sb-alien:alien-sap + (sb-alien:addr avail)) + nil)) + (return-from handle-listen (plusp avail))) + + (unless (zerop (sb-win32:peek-console-input handle + (sb-alien:alien-sap buf) + sb-win32::input-record-size + (sb-alien:alien-sap + (sb-alien:addr avail)))) + (return-from handle-listen (plusp avail)))) + + (let ((event (wsa-create-event))) + (wsa-event-select handle event (logior +fd-read+ +fd-close+)) + (let ((val (wait-for-single-object-ex event 0 0))) + (wsa-close-event event) + (unless (= val -1) + (return-from handle-listen (zerop val))))) + + nil) + + ) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix"))) + +;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general, +;; 2008-08-22. +(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname))) + +(defimplementation filename-to-pathname (filename) + (sb-ext:parse-native-namestring filename *physical-pathname-host*)) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation set-default-directory (directory) + (let ((directory (truename (merge-pathnames directory)))) + (sb-posix:chdir directory) + (setf *default-pathname-defaults* directory) + (default-directory))) + +(defun make-socket-io-stream (socket external-format buffering) + (let ((args `(:output t + :input t + :element-type ,(if external-format + 'character + '(unsigned-byte 8)) + :buffering ,buffering + ,@(cond ((and external-format (sb-int:featurep :sb-unicode)) + `(:external-format ,external-format)) + (t '())) + :serve-events ,(eq :fd-handler swank:*communication-style*) + ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS + ;; argument. + :allow-other-keys t))) + (apply #'sb-bsd-sockets:socket-make-stream socket args))) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + + +;;;; Support for SBCL syntax + +;;; SBCL's source code is riddled with #! reader macros. Also symbols +;;; containing `!' have special meaning. We have to work long and +;;; hard to be able to read the source. To deal with #! reader +;;; macros, we use a special readtable. The special symbols are +;;; converted by a condition handler. + +(defun feature-in-list-p (feature list) + (etypecase feature + (symbol (member feature list :test #'eq)) + (cons (flet ((subfeature-in-list-p (subfeature) + (feature-in-list-p subfeature list))) + ;; Don't use ECASE since SBCL also has :host-feature, + ;; don't need to handle it or anything else appearing in + ;; the future or in erronous code. + (case (first feature) + (:or (some #'subfeature-in-list-p (rest feature))) + (:and (every #'subfeature-in-list-p (rest feature))) + (:not (destructuring-bind (e) (cdr feature) + (not (subfeature-in-list-p e))))))))) + +(defun shebang-reader (stream sub-character infix-parameter) + (declare (ignore sub-character)) + (when infix-parameter + (error "illegal read syntax: #~D!" infix-parameter)) + (let ((next-char (read-char stream))) + (unless (find next-char "+-") + (error "illegal read syntax: #!~C" next-char)) + ;; When test is not satisfied + ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then + ;; would become "unless test is satisfied".. + (when (let* ((*package* (find-package "KEYWORD")) + (*read-suppress* nil) + (not-p (char= next-char #\-)) + (feature (read stream))) + (if (feature-in-list-p feature *features*) + not-p + (not not-p))) + ;; Read (and discard) a form from input. + (let ((*read-suppress* t)) + (read stream t nil t)))) + (values)) + +(defvar *shebang-readtable* + (let ((*readtable* (copy-readtable nil))) + (set-dispatch-macro-character #\# #\! + (lambda (s c n) (shebang-reader s c n)) + *readtable*) + *readtable*)) + +(defun shebang-readtable () + *shebang-readtable*) + +(defun sbcl-package-p (package) + (let ((name (package-name package))) + (eql (mismatch "SB-" name) 3))) + +(defun sbcl-source-file-p (filename) + (when filename + (loop for (nil pattern) in (logical-pathname-translations "SYS") + thereis (pathname-match-p filename pattern)))) + +(defun guess-readtable-for-filename (filename) + (if (sbcl-source-file-p filename) + (shebang-readtable) + *readtable*)) + +(defvar *debootstrap-packages* t) + +(defun call-with-debootstrapping (fun) + (handler-bind ((sb-int:bootstrap-package-not-found + #'sb-int:debootstrap-package)) + (funcall fun))) + +(defmacro with-debootstrapping (&body body) + `(call-with-debootstrapping (lambda () ,@body))) + +(defimplementation call-with-syntax-hooks (fn) + (cond ((and *debootstrap-packages* + (sbcl-package-p *package*)) + (with-debootstrapping (funcall fn))) + (t + (funcall fn)))) + +(defimplementation default-readtable-alist () + (let ((readtable (shebang-readtable))) + (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages)) + collect (cons (package-name p) readtable)))) + +;;; Packages + +#+#.(swank/backend:with-symbol 'package-local-nicknames 'sb-ext) +(defimplementation package-local-nicknames (package) + (sb-ext:package-local-nicknames package)) + +;;; Utilities + +#+#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect) +(defimplementation arglist (fname) + (sb-introspect:function-lambda-list fname)) + +#-#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect) +(defimplementation arglist (fname) + (sb-introspect:function-arglist fname)) + +(defimplementation function-name (f) + (check-type f function) + (sb-impl::%fun-name f)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (flet ((ensure-list (thing) (if (listp thing) thing (list thing)))) + (let* ((flags (sb-cltl2:declaration-information decl-identifier))) + (if flags + ;; Symbols aren't printed with package qualifiers, but the + ;; FLAGS would have to be fully qualified when used inside a + ;; declaration. So we strip those as long as there's no + ;; better way. (FIXME) + `(&any ,@(remove-if-not + #'(lambda (qualifier) + (find-symbol (symbol-name (first qualifier)) :cl)) + flags :key #'ensure-list)) + (call-next-method))))) + +#+#.(swank/backend:with-symbol 'deftype-lambda-list 'sb-introspect) +(defmethod type-specifier-arglist :around (typespec-operator) + (multiple-value-bind (arglist foundp) + (sb-introspect:deftype-lambda-list typespec-operator) + (if foundp arglist (call-next-method)))) + +(defimplementation type-specifier-p (symbol) + (or (sb-ext:valid-type-specifier-p symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defvar *buffer-name* nil) +(defvar *buffer-tmpfile* nil) +(defvar *buffer-offset*) +(defvar *buffer-substring* nil) + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning. +This traps all compiler conditions at a lower-level than using +C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to +craft our own error messages, which can omit a lot of redundant +information." + (unless (or (eq condition *previous-compiler-condition*)) + ;; First resignal warnings, so that outer handlers -- which may choose to + ;; muffle this -- get a chance to run. + (when (typep condition 'warning) + (signal condition)) + (setq *previous-compiler-condition* condition) + (signal-compiler-condition (real-condition condition) + (sb-c::find-error-context nil)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (etypecase condition + (sb-ext:compiler-note :note) + (sb-c:compiler-error :error) + (reader-error :read-error) + (error :error) + #+#.(swank/backend:with-symbol early-deprecation-warning sb-ext) + (sb-ext::early-deprecation-warning :early-deprecation-warning) + #+#.(swank/backend:with-symbol late-deprecation-warning sb-ext) + (sb-ext::late-deprecation-warning :late-deprecation-warning) + #+#.(swank/backend:with-symbol final-deprecation-warning sb-ext) + (sb-ext::final-deprecation-warning :final-deprecation-warning) + #+#.(swank/backend:with-symbol redefinition-warning + sb-kernel) + (sb-kernel:redefinition-warning + :redefinition) + (style-warning :style-warning) + (warning :warning)) + :references (condition-references condition) + :message (brief-compiler-message-for-emacs condition) + :source-context (compiler-error-context context) + :location (compiler-note-location condition context))) + +(defun real-condition (condition) + "Return the encapsulated condition or CONDITION itself." + (typecase condition + (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition)) + (t condition))) + +(defun condition-references (condition) + (if (typep condition 'sb-int:reference-condition) + (externalize-reference + (sb-int:reference-condition-references condition)))) + +(defun compiler-note-location (condition context) + (flet ((bailout () + (return-from compiler-note-location + (make-error-location "No error location available")))) + (cond (context + (locate-compiler-note + (sb-c::compiler-error-context-file-name context) + (compiler-source-path context) + (sb-c::compiler-error-context-original-source context))) + ((typep condition 'reader-error) + (let* ((stream (stream-error-stream condition)) + (file (pathname stream))) + (unless (open-stream-p stream) + (bailout)) + (if (compiling-from-buffer-p file) + ;; The stream position for e.g. "comma not inside + ;; backquote" is at the character following the + ;; comma, :offset is 0-based, hence the 1-. + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-offset* + (1- (file-position stream)))) + (progn + (assert (compiling-from-file-p file)) + ;; No 1- because :position is 1-based. + (make-location (list :file (namestring file)) + (list :position (file-position stream))))))) + (t (bailout))))) + +(defun compiling-from-buffer-p (filename) + (and *buffer-name* + ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P + ;; in LOCATE-COMPILER-NOTE, and allows handling nested + ;; compilation from eg. hitting C-C on (eval-when ... (require ..))). + ;; + ;; PROBE-FILE to handle tempfile directory being a symlink. + (pathnamep filename) + (let ((true1 (probe-file filename)) + (true2 (probe-file *buffer-tmpfile*))) + (and true1 (equal true1 true2))))) + +(defun compiling-from-file-p (filename) + (and (pathnamep filename) + (or (null *buffer-name*) + (null *buffer-tmpfile*) + (let ((true1 (probe-file filename)) + (true2 (probe-file *buffer-tmpfile*))) + (not (and true1 (equal true1 true2))))))) + +(defun compiling-from-generated-code-p (filename source) + (and (eq filename :lisp) (stringp source))) + +(defun locate-compiler-note (file source-path source) + (cond ((compiling-from-buffer-p file) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-offset* + (source-path-string-position + source-path *buffer-substring*)))) + ((compiling-from-file-p file) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (namestring file)) + (list :position (and position + (1+ position)))))) + ((compiling-from-generated-code-p file source) + (make-location (list :source-form source) + (list :position 1))) + (t + (error "unhandled case in compiler note ~S ~S ~S" + file source-path source)))) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (let ((sb-int:*print-condition-references* nil)) + (princ-to-string condition))) + +(defun compiler-error-context (error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or sb-c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (sb-c::compiler-error-context-enclosing-source error-context) + (sb-c::compiler-error-context-source error-context))) + (and (or enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]" + enclosing source)))) + +(defun compiler-source-path (context) + "Return the source-path for the current compiler error. +Returns NIL if this cannot be determined by examining internal +compiler state." + (cond ((sb-c::node-p context) + (reverse + (sb-c::source-path-original-source + (sb-c::node-source-path context)))) + ((sb-c::compiler-error-context-p context) + (reverse + (sb-c::compiler-error-context-original-source-path context))))) + +(defimplementation call-with-compilation-hooks (function) + (declare (type function function)) + (handler-bind + ;; N.B. Even though these handlers are called HANDLE-FOO they + ;; actually decline, i.e. the signalling of the original + ;; condition continues upward. + ((sb-c:fatal-compiler-error #'handle-notification-condition) + (sb-c:compiler-error #'handle-notification-condition) + (sb-ext:compiler-note #'handle-notification-condition) + (error #'handle-notification-condition) + (warning #'handle-notification-condition)) + (funcall function))) + +;;; HACK: SBCL 1.2.12 shipped with a bug where +;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there +;;; were no policy restrictions in place. This workaround ensures the +;;; existence of at least one dummy restriction. +(handler-case (sb-ext:restrict-compiler-policy) + (error () (sb-ext:restrict-compiler-policy 'debug))) + +(defun compiler-policy (qualities) + "Return compiler policy qualities present in the QUALITIES alist. +QUALITIES is an alist with (quality . value)" + #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext) + (loop with policy = (sb-ext:restrict-compiler-policy) + for (quality) in qualities + collect (cons quality + (or (cdr (assoc quality policy)) + 0)))) + +(defun (setf compiler-policy) (policy) + (declare (ignorable policy)) + #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext) + (loop for (qual . value) in policy + do (sb-ext:restrict-compiler-policy qual value))) + +(defmacro with-compiler-policy (policy &body body) + (let ((current-policy (gensym))) + `(let ((,current-policy (compiler-policy ,policy))) + (setf (compiler-policy) ,policy) + (unwind-protect (progn ,@body) + (setf (compiler-policy) ,current-policy))))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (multiple-value-bind (output-file warnings-p failure-p) + (with-compiler-policy policy + (with-compilation-hooks () + (compile-file input-file :output-file output-file + :external-format external-format))) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))) + +;;;; compile-string + +;;; We copy the string to a temporary file in order to get adequate +;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms +;;; which the previous approach using +;;; (compile nil `(lambda () ,(read-from-string string))) +;;; did not provide. + +(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + +(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam) + sb-alien:c-string + (dir sb-alien:c-string) + (prefix sb-alien:c-string))) + +(defun temp-file-name () + "Return a temporary file name to compile strings into." + (tempnam nil "slime")) + +(defvar *trap-load-time-warnings* t) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (*buffer-substring* string) + (*buffer-tmpfile* (temp-file-name))) + (labels ((load-it (filename) + (cond (*trap-load-time-warnings* + (with-compilation-hooks () (load filename))) + (t (load filename)))) + (cf () + (with-compiler-policy policy + (with-compilation-unit + (:source-plist (list :emacs-buffer buffer + :emacs-filename filename + :emacs-package (package-name *package*) + :emacs-position position + :emacs-string string) + :source-namestring filename + :allow-other-keys t) + (compile-file *buffer-tmpfile* :external-format :utf-8))))) + (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error + :external-format :utf-8) + (write-string string s)) + (unwind-protect + (multiple-value-bind (output-file warningsp failurep) + (with-compilation-hooks () (cf)) + (declare (ignore warningsp)) + (when output-file + (load-it output-file)) + (not failurep)) + (ignore-errors + (delete-file *buffer-tmpfile*) + (delete-file (compile-file-pathname *buffer-tmpfile*))))))) + +;;;; Definitions + +(defparameter *definition-types* + '(:variable defvar + :constant defconstant + :type deftype + :symbol-macro define-symbol-macro + :macro defmacro + :compiler-macro define-compiler-macro + :function defun + :generic-function defgeneric + :method defmethod + :setf-expander define-setf-expander + :structure defstruct + :condition define-condition + :class defclass + :method-combination define-method-combination + :package defpackage + :transform :deftransform + :optimizer :defoptimizer + :vop :define-vop + :source-transform :define-source-transform + :ir1-convert :def-ir1-translator + :declaration declaim + :alien-type :define-alien-type) + "Map SB-INTROSPECT definition type names to Slime-friendly forms") + +(defun definition-specifier (type) + "Return a pretty specifier for NAME representing a definition of type TYPE." + (getf *definition-types* type)) + +(defun make-dspec (type name source-location) + (list* (definition-specifier type) + name + (sb-introspect::definition-source-description source-location))) + +(defimplementation find-definitions (name) + (loop for type in *definition-types* by #'cddr + for defsrcs = (sb-introspect:find-definition-sources-by-name name type) + append (loop for defsrc in defsrcs collect + (list (make-dspec type name defsrc) + (converting-errors-to-error-location + (definition-source-for-emacs defsrc + type name)))))) + +(defimplementation find-source-location (obj) + (flet ((general-type-of (obj) + (typecase obj + (method :method) + (generic-function :generic-function) + (function :function) + (structure-class :structure-class) + (class :class) + (method-combination :method-combination) + (package :package) + (condition :condition) + (structure-object :structure-object) + (standard-object :standard-object) + (t :thing))) + (to-string (obj) + (typecase obj + ;; Packages are possibly named entities. + (package (princ-to-string obj)) + ((or structure-object standard-object condition) + (with-output-to-string (s) + (print-unreadable-object (obj s :type t :identity t)))) + (t (princ-to-string obj))))) + (converting-errors-to-error-location + (let ((defsrc (sb-introspect:find-definition-source obj))) + (definition-source-for-emacs defsrc + (general-type-of obj) + (to-string obj)))))) + +(defmacro with-definition-source ((&rest names) obj &body body) + "Like with-slots but works only for structs." + (flet ((reader (slot) + ;; Use read-from-string instead of intern so that + ;; conc-name can be a string such as ext:struct- and not + ;; cause errors and not force interning ext::struct- + (read-from-string + (concatenate 'string "sb-introspect:definition-source-" + (string slot))))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + +(defun categorize-definition-source (definition-source) + (with-definition-source (pathname form-path character-offset plist) + definition-source + (let ((file-p (and pathname (probe-file pathname) + (or form-path character-offset)))) + (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file) + ((getf plist :emacs-buffer) :buffer) + (file-p :file) + (pathname :file-without-position) + (t :invalid))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun form-number-position (definition-source stream) + (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source))) + (form-number (sb-introspect:definition-source-form-number definition-source))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun file-form-number-position (definition-source) + (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source)) + (filename (sb-introspect:definition-source-pathname definition-source)) + (*readtable* (guess-readtable-for-filename filename)) + (source-code (get-source-code filename code-date))) + (with-debootstrapping + (with-input-from-string (s source-code) + (form-number-position definition-source s))))) + +#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun string-form-number-position (definition-source string) + (with-input-from-string (s string) + (form-number-position definition-source s))) + +(defun definition-source-buffer-location (definition-source) + (with-definition-source (form-path character-offset plist) definition-source + (destructuring-bind (&key emacs-buffer emacs-position emacs-directory + emacs-string &allow-other-keys) + plist + (let ((*readtable* (guess-readtable-for-filename emacs-directory)) + start + end) + (with-debootstrapping + (or + (and form-path + (or + #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) + (setf (values start end) + (and (sb-introspect:definition-source-form-number definition-source) + (string-form-number-position definition-source emacs-string))) + (setf (values start end) + (source-path-string-position form-path emacs-string)))) + (setf start character-offset + end most-positive-fixnum))) + (make-location + `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,start) + `(:snippet + ,(subseq emacs-string + start + (min end (+ start *source-snippet-size*))))))))) + +(defun definition-source-file-location (definition-source) + (with-definition-source (pathname form-path character-offset plist + file-write-date) definition-source + (let* ((namestring (namestring (translate-logical-pathname pathname))) + (pos (or (and form-path + (or + #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) + (and (sb-introspect:definition-source-form-number definition-source) + (ignore-errors (file-form-number-position definition-source))) + (ignore-errors + (source-file-position namestring file-write-date + form-path)))) + character-offset)) + (snippet (source-hint-snippet namestring file-write-date pos))) + (make-location `(:file ,namestring) + ;; /file positions/ in Common Lisp start from + ;; 0, buffer positions in Emacs start from 1. + `(:position ,(1+ pos)) + `(:snippet ,snippet))))) + +(defun definition-source-buffer-and-file-location (definition-source) + (let ((buffer (definition-source-buffer-location definition-source))) + (make-location (list :buffer-and-file + (cadr (location-buffer buffer)) + (namestring (sb-introspect:definition-source-pathname + definition-source))) + (location-position buffer) + (location-hints buffer)))) + +(defun definition-source-for-emacs (definition-source type name) + (with-definition-source (pathname form-path character-offset plist + file-write-date) + definition-source + (ecase (categorize-definition-source definition-source) + (:buffer-and-file + (definition-source-buffer-and-file-location definition-source)) + (:buffer + (definition-source-buffer-location definition-source)) + (:file + (definition-source-file-location definition-source)) + (:file-without-position + (make-location `(:file ,(namestring + (translate-logical-pathname pathname))) + '(:position 1) + (when (eql type :function) + `(:snippet ,(format nil "(defun ~a " + (symbol-name name)))))) + (:invalid + (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ + meaningful information." + type name))))) + +(defun source-file-position (filename write-date form-path) + (let ((source (get-source-code filename write-date)) + (*readtable* (guess-readtable-for-filename filename))) + (with-debootstrapping + (source-path-string-position form-path source)))) + +(defun source-hint-snippet (filename write-date position) + (read-snippet-from-string (get-source-code filename write-date) position)) + +(defun function-source-location (function &optional name) + (declare (type function function)) + (definition-source-for-emacs (sb-introspect:find-definition-source function) + :function + (or name (function-name function)))) + +(defun setf-expander (symbol) + (or + #+#.(swank/sbcl::sbcl-with-setf-inverse-meta-info) + (sb-int:info :setf :inverse symbol) + (sb-int:info :setf :expander symbol))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (sb-int:info :variable :kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (and (setf-expander symbol) + (doc 'setf))) + (maybe-push + :type (if (sb-int:info :type :kind symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol type) + (case type + (:variable + (describe symbol)) + (:function + (describe (symbol-function symbol))) + (:setf + (describe (setf-expander symbol))) + (:class + (describe (find-class symbol))) + (:type + (describe (sb-kernel:values-specifier-type symbol))))) + +#+#.(swank/sbcl::sbcl-with-xref-p) +(progn + (defmacro defxref (name &optional fn-name) + `(defimplementation ,name (what) + (sanitize-xrefs + (mapcar #'source-location-for-xref-data + (,(find-symbol (symbol-name (if fn-name + fn-name + name)) + "SB-INTROSPECT") + what))))) + (defxref who-calls) + (defxref who-binds) + (defxref who-sets) + (defxref who-references) + (defxref who-macroexpands) + #+#.(swank/backend:with-symbol 'who-specializes-directly 'sb-introspect) + (defxref who-specializes who-specializes-directly)) + +(defun source-location-for-xref-data (xref-data) + (destructuring-bind (name . defsrc) xref-data + (list name (converting-errors-to-error-location + (definition-source-for-emacs defsrc 'function name))))) + +(defimplementation list-callers (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))) + +(defimplementation list-callees (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))) + +(defun sanitize-xrefs (xrefs) + (remove-duplicates + (remove-if (lambda (f) + (member f (ignored-xref-function-names))) + (loop for entry in xrefs + for name = (car entry) + collect (if (and (consp name) + (member (car name) + '(sb-pcl::fast-method + sb-pcl::slow-method + sb-pcl::method))) + (cons (cons 'defmethod (cdr name)) + (cdr entry)) + entry)) + :key #'car) + :test (lambda (a b) + (and (eq (first a) (first b)) + (equal (second a) (second b)))))) + +(defun ignored-xref-function-names () + #-#.(swank/sbcl::sbcl-with-new-stepper-p) + '(nil sb-c::step-form sb-c::step-values) + #+#.(swank/sbcl::sbcl-with-new-stepper-p) + '(nil)) + +(defun function-dspec (fn) + "Describe where the function FN was defined. +Return a list of the form (NAME LOCATION)." + (let ((name (function-name fn))) + (list name (converting-errors-to-error-location + (function-source-location fn name))))) + +;;; macroexpansion + +(defimplementation macroexpand-all (form &optional env) + (sb-cltl2:macroexpand-all form env)) + +(defimplementation collect-macro-forms (form &optional environment) + (let ((macro-forms '()) + (compiler-macro-forms '()) + (function-quoted-forms '())) + (sb-walker:walk-form + form environment + (lambda (form context environment) + (declare (ignore context)) + (when (and (consp form) + (symbolp (car form))) + (cond ((eq (car form) 'function) + (push (cadr form) function-quoted-forms)) + ((member form function-quoted-forms) + nil) + ((macro-function (car form) environment) + (push form macro-forms)) + ((not (eq form (compiler-macroexpand-1 form environment))) + (push form compiler-macro-forms)))) + form)) + (values macro-forms compiler-macro-forms))) + + +;;; Debugging + +;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger +;;; than just a hook into BREAK. In particular, it'll make +;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather +;;; than the native debugger. That should probably be considered a +;;; feature. + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(sb-int:named-lambda swank-invoke-debugger-hook + (condition old-hook) + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defun set-break-hook (hook) + (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + +(defun call-with-break-hook (hook continuation) + (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall continuation))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (set-break-hook function)) + +(defimplementation condition-extras (condition) + (cond #+#.(swank/sbcl::sbcl-with-new-stepper-p) + ((typep condition 'sb-impl::step-form-condition) + `((:show-frame-source 0))) + ((typep condition 'sb-int:reference-condition) + (let ((refs (sb-int:reference-condition-references condition))) + (if refs + `((:references ,(externalize-reference refs)))))))) + +(defun externalize-reference (ref) + (etypecase ref + (null nil) + (cons (cons (externalize-reference (car ref)) + (externalize-reference (cdr ref)))) + ((or string number) ref) + (symbol + (cond ((eq (symbol-package ref) (symbol-package :test)) + ref) + (t (symbol-name ref)))))) + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let ((*sldb-stack-top* + (if (and (not *debug-swank-backend*) + sb-debug:*stack-top-hint*) + #+#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) + (sb-debug::resolve-stack-top-hint) + #-#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) + sb-debug:*stack-top-hint* + (sb-di:top-frame))) + (sb-debug:*stack-top-hint* nil)) + (handler-bind ((sb-di:debug-condition + (lambda (condition) + (signal 'sldb-condition + :original-condition condition)))) + (funcall debugger-loop-fn)))) + +#+#.(swank/sbcl::sbcl-with-new-stepper-p) +(progn + (defimplementation activate-stepping (frame) + (declare (ignore frame)) + (sb-impl::enable-stepping)) + (defimplementation sldb-stepper-condition-p (condition) + (typep condition 'sb-ext:step-form-condition)) + (defimplementation sldb-step-into () + (invoke-restart 'sb-ext:step-into)) + (defimplementation sldb-step-next () + (invoke-restart 'sb-ext:step-next)) + (defimplementation sldb-step-out () + (invoke-restart 'sb-ext:step-out))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + #+#.(swank/sbcl::sbcl-with-new-stepper-p) + (sb-ext:*stepper-hook* + (lambda (condition) + (typecase condition + (sb-ext:step-form-condition + (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame))) + (sb-impl::invoke-debugger condition))))))) + (handler-bind (#+#.(swank/sbcl::sbcl-with-new-stepper-p) + (sb-ext:step-condition #'sb-impl::invoke-stepper)) + (call-with-break-hook hook fun)))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (sb-di:frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + "Return a list of frames starting with frame number START and +continuing to frame number END or, if END is nil, the last frame on the +stack." + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (sb-di:frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (sb-debug::print-frame-call frame stream + :allow-other-keys t + :emergency-best-effort t)) + +(defimplementation frame-restartable-p (frame) + #+#.(swank/sbcl::sbcl-with-restart-frame) + (not (null (sb-debug:frame-has-debug-tag-p frame)))) + +(defimplementation frame-call (frame-number) + (multiple-value-bind (name args) + (sb-debug::frame-call (nth-frame frame-number)) + (with-output-to-string (stream) + (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) + (let ((*print-length* nil) + (*print-level* nil)) + (prin1 (sb-debug::ensure-printable-object name) stream)) + (let ((args (sb-debug::ensure-printable-object args))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args))))))))) + +;;;; Code-location -> source-location translation + +;;; If debug-block info is avaibale, we determine the file position of +;;; the source-path for a code-location. If the code was compiled +;;; with C-c C-c, we have to search the position in the source string. +;;; If there's no debug-block info, we return the (less precise) +;;; source-location of the corresponding function. + +(defun code-location-source-location (code-location) + (let* ((dsource (sb-di:code-location-debug-source code-location)) + (plist (sb-c::debug-source-plist dsource)) + (package (getf plist :emacs-package)) + (*package* (or (and package + (find-package package)) + *package*))) + (if (getf plist :emacs-buffer) + (emacs-buffer-source-location code-location plist) + #+#.(swank/backend:with-symbol 'debug-source-from 'sb-di) + (ecase (sb-di:debug-source-from dsource) + (:file (file-source-location code-location)) + (:lisp (lisp-source-location code-location))) + #-#.(swank/backend:with-symbol 'debug-source-from 'sb-di) + (if (sb-di:debug-source-namestring dsource) + (file-source-location code-location) + (lisp-source-location code-location))))) + +;;; FIXME: The naming policy of source-location functions is a bit +;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the +;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co +;;; which returns the source location for a _code-location_. +;;; +;;; Maybe these should be named code-location-file-source-location, +;;; etc, turned into generic functions, or something. In the very +;;; least the names should indicate the main entry point vs. helper +;;; status. + +(defun file-source-location (code-location) + (if (code-location-has-debug-block-info-p code-location) + (source-file-source-location code-location) + (fallback-source-location code-location))) + +(defun fallback-source-location (code-location) + (let ((fun (code-location-debug-fun-fun code-location))) + (cond (fun (function-source-location fun)) + (t (error "Cannot find source location for: ~A " code-location))))) + +(defun lisp-source-location (code-location) + (let ((source (prin1-to-string + (sb-debug::code-location-source-form code-location 100))) + (condition swank:*swank-debugger-condition*)) + (if (and (typep condition 'sb-impl::step-form-condition) + (search "SB-IMPL::WITH-STEPPING-ENABLED" source + :test #'char-equal) + (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal)) + ;; The initial form is utterly uninteresting -- and almost + ;; certainly right there in the REPL. + (make-error-location "Stepping...") + (make-location `(:source-form ,source) '(:position 1))))) + +(defun emacs-buffer-source-location (code-location plist) + (if (code-location-has-debug-block-info-p code-location) + (destructuring-bind (&key emacs-buffer emacs-position emacs-string + &allow-other-keys) + plist + (let* ((pos (string-source-position code-location emacs-string)) + (snipped (read-snippet-from-string emacs-string pos))) + (make-location `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,pos) + `(:snippet ,snipped)))) + (fallback-source-location code-location))) + +(defun source-file-source-location (code-location) + (let* ((code-date (code-location-debug-source-created code-location)) + (filename (code-location-debug-source-name code-location)) + (*readtable* (guess-readtable-for-filename filename)) + (source-code (get-source-code filename code-date))) + (with-debootstrapping + (with-input-from-string (s source-code) + (let* ((pos (stream-source-position code-location s)) + (snippet (read-snippet s pos))) + (make-location `(:file ,filename) + `(:position ,pos) + `(:snippet ,snippet))))))) + +(defun code-location-debug-source-name (code-location) + (namestring (truename (#.(swank/backend:choose-symbol + 'sb-c 'debug-source-name + 'sb-c 'debug-source-namestring) + (sb-di::code-location-debug-source code-location))))) + +(defun code-location-debug-source-created (code-location) + (sb-c::debug-source-created + (sb-di::code-location-debug-source code-location))) + +(defun code-location-debug-fun-fun (code-location) + (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location))) + +(defun code-location-has-debug-block-info-p (code-location) + (handler-case + (progn (sb-di:code-location-debug-block code-location) + t) + (sb-di:no-debug-blocks () nil))) + +(defun stream-source-position (code-location stream) + (let* ((cloc (sb-debug::maybe-block-start-location code-location)) + (tlf-number (sb-di::code-location-toplevel-form-offset cloc)) + (form-number (sb-di::code-location-form-number cloc))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +(defun string-source-position (code-location string) + (with-input-from-string (s string) + (stream-source-position code-location s))) + +;;; source-path-file-position and friends are in source-path-parser + +(defimplementation frame-source-location (index) + (converting-errors-to-error-location + (code-location-source-location + (sb-di:frame-code-location (nth-frame index))))) + +(defvar *keep-non-valid-locals* nil) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))) + (cond (*keep-non-valid-locals* all-vars) + (t (let ((loc (sb-di:frame-code-location frame))) + (remove-if (lambda (var) + (ecase (sb-di:debug-var-validity var loc) + (:valid nil) + ((:invalid :unknown) t))) + all-vars)))))) + +(defun debug-var-value (var frame location) + (ecase (sb-di:debug-var-validity var location) + (:valid (sb-di:debug-var-value var frame)) + ((:invalid :unknown) ':))) + +(defun debug-var-info (var) + ;; Introduced by SBCL 1.0.49.76. + (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di))) + (when (and s (fboundp s)) + (funcall s var)))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (sb-di:frame-code-location frame)) + (vars (frame-debug-vars frame)) + ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE + ;; specially. + (more-name (or (find-symbol "MORE" :sb-debug) 'more)) + (more-context nil) + (more-count nil)) + (when vars + (let ((locals + (loop for v across vars + unless + (case (debug-var-info v) + (:more-context + (setf more-context (debug-var-value v frame loc)) + t) + (:more-count + (setf more-count (debug-var-value v frame loc)) + t)) + collect + (list :name (sb-di:debug-var-symbol v) + :id (sb-di:debug-var-id v) + :value (debug-var-value v frame loc))))) + (when (and more-context more-count) + (setf locals (append locals + (list + (list :name more-name + :id 0 + :value (multiple-value-list + (sb-c:%more-arg-values + more-context + 0 more-count))))))) + locals)))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (vars (frame-debug-vars frame)) + (loc (sb-di:frame-code-location frame)) + (dvar (if (= var (length vars)) + ;; If VAR is out of bounds, it must be the fake var + ;; we made up for &MORE. + (let* ((context-var (find :more-context vars + :key #'debug-var-info)) + (more-context (debug-var-value context-var frame + loc)) + (count-var (find :more-count vars + :key #'debug-var-info)) + (more-count (debug-var-value count-var frame loc))) + (return-from frame-var-value + (multiple-value-list (sb-c:%more-arg-values + more-context + 0 more-count)))) + (aref vars var)))) + (debug-var-value dvar frame loc))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (sb-di:frame-catches (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (let ((frame (nth-frame index))) + (funcall (the function + (sb-di:preprocess-for-eval form + (sb-di:frame-code-location frame))) + frame))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)))) + (when fun + (let ((name (function-name fun))) + (typecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql setf) (cons symbol)) (symbol-package (cadr name)))))))) + +#+#.(swank/sbcl::sbcl-with-restart-frame) +(progn + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index))) + (cond ((sb-debug:frame-has-debug-tag-p frame) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (sb-debug:unwind-to-frame-and-call frame + (lambda () + (values-list values))))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (when (sb-debug:frame-has-debug-tag-p frame) + (multiple-value-bind (fname args) (sb-debug::frame-call frame) + (multiple-value-bind (fun arglist) + (if (and (sb-int:legal-fun-name-p fname) (fboundp fname)) + (values (fdefinition fname) args) + (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)) + (sb-debug::frame-args-as-list frame))) + (when (functionp fun) + (sb-debug:unwind-to-frame-and-call + frame + (lambda () + ;; Ensure TCO. + (declare (optimize (debug 0))) + (apply fun arglist))))))) + (format nil "Cannot restart frame: ~S" frame)))) + +;; FIXME: this implementation doesn't unwind the stack before +;; re-invoking the function, but it's better than no implementation at +;; all. +#-#.(swank/sbcl::sbcl-with-restart-frame) +(progn + (defun sb-debug-catch-tag-p (tag) + (and (symbolp tag) + (not (symbol-package tag)) + (string= tag :sb-debug-catch-tag))) + + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index)) + (probe (assoc-if #'sb-debug-catch-tag-p + (sb-di::frame-catches frame)))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (return-from-frame index (sb-debug::frame-call-as-list frame))))) + +;;;;; reference-conditions + +(defimplementation print-condition (condition stream) + (let ((sb-int:*print-condition-references* nil)) + (princ condition stream))) + + +;;;; Profiling + +(defimplementation profile (fname) + (when fname (eval `(sb-profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(sb-profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (sb-profile:unprofile) + "All functions unprofiled.") + +(defimplementation profile-report () + (sb-profile:report)) + +(defimplementation profile-reset () + (sb-profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (sb-profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(sb-profile:profile ,(package-name (find-package package))))) + + +;;;; Inspector + +(defmethod emacs-inspect ((o t)) + (cond ((sb-di::indirect-value-cell-p o) + (label-value-line* (:value (sb-kernel:value-cell-ref o)))) + (t + (multiple-value-bind (text label parts) (sb-impl::inspected-parts o) + (list* (string-right-trim '(#\Newline) text) + '(:newline) + (if label + (loop for (l . v) in parts + append (label-value-line l v)) + (loop for value in parts + for i from 0 + append (label-value-line i value)))))))) + +(defmethod emacs-inspect ((o function)) + (cond ((sb-kernel:simple-fun-p o) + (label-value-line* + (:name (sb-kernel:%simple-fun-name o)) + (:arglist (sb-kernel:%simple-fun-arglist o)) + (:next (sb-kernel:%simple-fun-next o)) + (:type (sb-kernel:%simple-fun-type o)) + (:code (sb-kernel:fun-code-header o)))) + ((sb-kernel:closurep o) + (append + (label-value-line :function (sb-kernel:%closure-fun o)) + `("Closed over values:" (:newline)) + (loop for i below (1- (sb-kernel:get-closure-length o)) + append (label-value-line + i (sb-kernel:%closure-index-ref o i))))) + (t (call-next-method o)))) + +(defmethod emacs-inspect ((o sb-kernel:code-component)) + (append + (label-value-line* + (:code-size (sb-kernel:%code-code-size o)) + (:entry-points (sb-kernel:%code-entry-points o)) + (:debug-info (sb-kernel:%code-debug-info o))) + `("Constants:" (:newline)) + (loop for i from sb-vm:code-constants-offset + below + (#.(swank/backend:choose-symbol 'sb-kernel 'code-header-words + 'sb-kernel 'get-header-data) + o) + append (label-value-line i (sb-kernel:code-header-ref o i))) + `("Code:" (:newline) + ,(with-output-to-string (s) + (sb-disassem:disassemble-code-component o :stream s))))) + +(defmethod emacs-inspect ((o sb-ext:weak-pointer)) + (label-value-line* + (:value (sb-ext:weak-pointer-value o)))) + +(defmethod emacs-inspect ((o sb-kernel:fdefn)) + (label-value-line* + (:name (sb-kernel:fdefn-name o)) + (:function (sb-kernel:fdefn-fun o)))) + +(defmethod emacs-inspect :around ((o generic-function)) + (append + (call-next-method) + (label-value-line* + (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o)) + (:initial-methods (sb-pcl::generic-function-initial-methods o)) + ))) + + +;;;; Multiprocessing + +#+(and sb-thread + #.(swank/backend:with-symbol "THREAD-NAME" "SB-THREAD")) +(progn + (defvar *thread-id-counter* 0) + + (defvar *thread-id-counter-lock* + (sb-thread:make-mutex :name "thread id counter lock")) + + (defun next-thread-id () + (sb-thread:with-mutex (*thread-id-counter-lock*) + (incf *thread-id-counter*))) + + (defparameter *thread-id-map* (make-hash-table)) + + ;; This should be a thread -> id map but as weak keys are not + ;; supported it is id -> map instead. + (defvar *thread-id-map-lock* + (sb-thread:make-mutex :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (sb-thread:make-thread fn :name name)) + + (defimplementation thread-id (thread) + (block thread-id + (sb-thread:with-mutex (*thread-id-map-lock*) + (loop for id being the hash-key in *thread-id-map* + using (hash-value thread-pointer) + do + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (cond ((null maybe-thread) + ;; the value is gc'd, remove it manually + (remhash id *thread-id-map*)) + ((eq thread maybe-thread) + (return-from thread-id id))))) + ;; lazy numbering + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread)) + id)))) + + (defimplementation find-thread (id) + (sb-thread:with-mutex (*thread-id-map-lock*) + (let ((thread-pointer (gethash id *thread-id-map*))) + (if thread-pointer + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (if maybe-thread + maybe-thread + ;; the value is gc'd, remove it manually + (progn + (remhash id *thread-id-map*) + nil))) + nil)))) + + (defimplementation thread-name (thread) + ;; sometimes the name is not a string (e.g. NIL) + (princ-to-string (sb-thread:thread-name thread))) + + (defimplementation thread-status (thread) + (if (sb-thread:thread-alive-p thread) + "Running" + "Stopped")) + + (defimplementation make-lock (&key name) + (sb-thread:make-mutex :name name)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (sb-thread:with-recursive-lock (lock) (funcall function))) + + (defimplementation current-thread () + sb-thread:*current-thread*) + + (defimplementation all-threads () + (sb-thread:list-all-threads)) + + (defimplementation interrupt-thread (thread fn) + (sb-thread:interrupt-thread thread fn)) + + (defimplementation kill-thread (thread) + (sb-thread:terminate-thread thread)) + + (defimplementation thread-alive-p (thread) + (sb-thread:thread-alive-p thread)) + + (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (sb-thread:make-mutex)) + (waitqueue (sb-thread:make-waitqueue)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (sb-thread:with-mutex (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-recursive-lock (mutex) + (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-mutex (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox)) + (waitq (mailbox.waitqueue mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (sb-thread:with-mutex (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (sb-thread:condition-wait waitq mutex))))) + + (let ((alist '()) + (mutex (sb-thread:make-mutex :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (sb-thread:with-mutex (mutex) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (sb-thread:thread + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (sb-thread:with-mutex (mutex) + (cdr (assoc name alist)))))) + +(defimplementation quit-lisp () + #+#.(swank/backend:with-symbol 'exit 'sb-ext) + (sb-ext:exit) + #-#.(swank/backend:with-symbol 'exit 'sb-ext) + (progn + #+sb-thread + (dolist (thread (remove (current-thread) (all-threads))) + (ignore-errors (sb-thread:terminate-thread thread))) + (sb-ext:quit))) + + + +;;Trace implementations +;;In SBCL, we have: +;; (trace ) +;; (trace :methods ') ;to trace all methods of the gf +;; (trace (method ? (+))) +;; can be a normal name or a (setf name) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((member fspec (eval '(trace)) :test #'equal) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args)) + (format nil "~S is now traced." fspec)))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defmethod) + (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec))))) + ((:defgeneric) + (toggle-trace-aux (second spec) :methods t)) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee :wherein (list (process-fspec caller))))))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :key args) + #-#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation make-weak-value-hash-table (&rest args) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :value args) + #-#.(swank/sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation hash-table-weakness (hashtable) + #+#.(swank/sbcl::sbcl-with-weak-hash-tables) + (sb-ext:hash-table-weakness hashtable)) + +;;; Floating point + +(defimplementation float-nan-p (float) + (sb-ext:float-nan-p float)) + +(defimplementation float-infinity-p (float) + (sb-ext:float-infinity-p float)) + +#-win32 +(defimplementation save-image (filename &optional restart-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (and (sb-posix:wifexited status) + (zerop (sb-posix:wexitstatus status)))))))))) + +#+unix +(progn + (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int + (program sb-alien:c-string) + (argv (* sb-alien:c-string))) + + (defun execv (program args) + "Replace current executable with another one." + (let ((a-args (sb-alien:make-alien sb-alien:c-string + (+ 1 (length args))))) + (unwind-protect + (progn + (loop for index from 0 by 1 + and item in (append args '(nil)) + do (setf (sb-alien:deref a-args index) + item)) + (when (minusp + (sys-execv program a-args)) + (error "execv(3) returned."))) + (sb-alien:free-alien a-args)))) + + (defun runtime-pathname () + #+#.(swank/backend:with-symbol + '*runtime-pathname* 'sb-ext) + sb-ext:*runtime-pathname* + #-#.(swank/backend:with-symbol + '*runtime-pathname* 'sb-ext) + (car sb-ext:*posix-argv*)) + + (defimplementation exec-image (image-file args) + (loop with fd-arg = + (loop for arg in args + and key = "" then arg + when (string-equal key "--swank-fd") + return (parse-integer arg)) + for my-fd from 3 to 1024 + when (/= my-fd fd-arg) + do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1))) + (let* ((self-string (pathname-to-filename (runtime-pathname)))) + (execv + self-string + (apply 'list self-string "--core" image-file args))))) + +(defimplementation make-fd-stream (fd external-format) + (sb-sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering :full + :dual-channel-p t + :external-format external-format)) + +#-win32 +(defimplementation background-save-image (filename &key restart-function + completion-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-posix:close pipe-in) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (sb-posix:close pipe-out) + (sb-sys:add-fd-handler + pipe-in :input + (lambda (fd) + (sb-sys:invalidate-descriptor fd) + (sb-posix:close fd) + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (sb-posix:wifexited status)) + (funcall completion-function + (zerop (sb-posix:wexitstatus status)))))))))))) + +(pushnew 'deinit-log-output sb-ext:*save-hooks*) + + +;;;; wrap interface implementation + +(defun sbcl-version>= (&rest subversions) + #+#.(swank/backend:with-symbol 'assert-version->= 'sb-ext) + (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t)) + #-#.(swank/backend:with-symbol 'assert-version->= 'sb-ext) + nil) + +(defimplementation wrap (spec indicator &key before after replace) + (when (wrapped-p spec indicator) + (warn "~a already wrapped with indicator ~a, unwrapping first" + spec indicator) + (sb-int:unencapsulate spec indicator)) + (sb-int:encapsulate spec indicator + #-#.(swank/backend:with-symbol 'arg-list 'sb-int) + (lambda (function &rest args) + (sbcl-wrap spec before after replace function args)) + #+#.(swank/backend:with-symbol 'arg-list 'sb-int) + (if (sbcl-version>= 1 1 16) + (lambda () + (sbcl-wrap spec before after replace + (symbol-value 'sb-int:basic-definition) + (symbol-value 'sb-int:arg-list))) + `(sbcl-wrap ',spec ,before ,after ,replace + (symbol-value 'sb-int:basic-definition) + (symbol-value 'sb-int:arg-list))))) + +(defimplementation unwrap (spec indicator) + (sb-int:unencapsulate spec indicator)) + +(defimplementation wrapped-p (spec indicator) + (sb-int:encapsulated-p spec indicator)) + +(defun sbcl-wrap (spec before after replace function args) + (declare (ignore spec)) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list (if replace + (funcall replace + args) + (apply function args)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed retlist :exited-non-locally)))))) + +#+#.(swank/backend:with-symbol 'comma-expr 'sb-impl) +(progn + (defmethod sexp-in-bounds-p ((s sb-impl::comma) i) + (= i 1)) + + (defmethod sexp-ref ((s sb-impl::comma) i) + (sb-impl::comma-expr s))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/scl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/scl.lisp new file mode 100644 index 0000000..7327133 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/scl.lisp @@ -0,0 +1,1726 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; Scieneer Common Lisp code for SLIME. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage swank/scl + (:use cl swank/backend swank/source-path-parser swank/source-file-cache)) + +(in-package swank/scl) + + + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; TCP server +;;; +;;; SCL only supports the :spawn communication style. +;;; + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (let ((addr (resolve-hostname host))) + (ext:create-inet-listener port :stream :host addr :reuse-address t + :backlog (or backlog 5)))) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (ext:close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (let ((buffering (or buffering :full)) + (fd (socket-fd socket))) + (loop + (let ((ready (sys:wait-until-fd-usable fd :input timeout))) + (unless ready + (error "Timeout accepting connection on socket: ~S~%" socket))) + (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd)))) + (when new-fd + (return (make-socket-io-stream new-fd external-format + (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line))))))))) + +(defimplementation set-stream-timeout (stream timeout) + (check-type timeout (or null real)) + (if (fboundp 'ext::stream-timeout) + (setf (ext::stream-timeout stream) timeout) + (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout) + timeout))) + +;;;;; Sockets + +(defun socket-fd (socket) + "Return the file descriptor for the socket represented by 'socket." + (etypecase socket + (fixnum socket) + (stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of 'hostname as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd external-format buffering) + "Create a new input/output fd-stream for 'fd." + (cond ((not external-format) + (sys:make-fd-stream fd :input t :output t :buffering buffering + :element-type '(unsigned-byte 8))) + (t + (let* ((stream (sys:make-fd-stream fd :input t :output t + :element-type 'base-char + :buffering buffering + :external-format external-format))) + ;; Ignore character conversion errors. Without this the + ;; communication channel is prone to lockup if a character + ;; conversion error occurs. + (setf (lisp::character-conversion-stream-input-error-value stream) + #\?) + (setf (lisp::character-conversion-stream-output-error-value stream) + #\?) + stream)))) + + +;;;; Stream handling + +(defimplementation gray-package-name () + '#:ext) + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. + Nil if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file input-file + :output-file output-file + :external-format external-format) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))))) + +(defimplementation swank-compile-string (string &key buffer position filename + policy) + (declare (ignore filename policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string)) + (with-input-from-string (stream string) + (ext:compile-from-stream + stream + :source-info `(:emacs-buffer ,buffer + :emacs-buffer-offset ,position + :emacs-buffer-string ,string)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `swank:compiler-condition's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (brief-compiler-message-for-emacs condition) + :source-context (compiler-error-context context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context)))) + +(defun severity-for-emacs (condition) + "Return the severity of 'condition." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. + When Emacs presents the message it already has the source popped up + and the source form highlighted. This makes much of the information in + the error-context redundant." + (princ-to-string condition)) + +(defun compiler-error-context (error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (if (and enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]" + enclosing source)))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. + Return a `location' record, or (:error ) on failure." + (if (null context) + (note-error-location) + (let ((file (c::compiler-error-context-file-name context)) + (source (c::compiler-error-context-original-source context)) + (path + (reverse + (c::compiler-error-context-original-source-path context)))) + (or (locate-compiler-note file source path) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (list :error "No error location available.")) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + + +;;; TODO +(defimplementation who-calls (name) nil) +(defimplementation who-references (name) nil) +(defimplementation who-binds (name) nil) +(defimplementation who-sets (name) nil) +(defimplementation who-specializes (symbol) nil) +(defimplementation who-macroexpands (name) nil) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call 'fn for each constant in 'code's constant pool." + (check-type code kernel:code-component) + (loop for i from vm:code-constants-offset below (kernel:get-header-data code) + do (funcall fn (kernel:code-header-ref code i)))) + +(defun function-callees (function) + "Return 'function's callees as a list of functions." + (let ((callees '())) + (map-code-constants + (vm::find-code-object function) + (lambda (obj) + (when (kernel:fdefn-p obj) + (push (kernel:fdefn-function obj) callees)))) + callees)) + +(declaim (ext:maybe-inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of 'spaces. FN + receives the object as argument. 'spaces should be a list of the + symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (declare (inline vm::map-allocated-objects) + (optimize (ext:inhibit-warnings 3))) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum size) (ignore size)) + (when (= vm:code-header-type header) + (funcall fn obj))) + space))) + +(declaim (ext:maybe-inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call 'fn for each code component with a fdefn for 'function in its + constant pool." + (let ((function (coerce function 'function))) + (declare (inline map-allocated-code-components)) + (map-allocated-code-components + spaces + (lambda (obj) + (map-code-constants + obj + (lambda (constant) + (when (and (kernel:fdefn-p constant) + (eq (kernel:fdefn-function constant) + function)) + (funcall fn obj)))))))) + +(defun function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return 'function's callers. The result is a list of code-objects." + (let ((referrers '())) + (declare (inline map-caller-code-components)) + (map-caller-code-components function spaces + (lambda (code) (push code referrers))) + referrers)) + +(defun debug-info-definitions (debug-info) + "Return the defintions for a debug-info. This should only be used + for code-object without entry points, i.e., byte compiled + code (are theree others?)" + ;; This mess has only been tested with #'ext::skip-whitespace, a + ;; byte-compiled caller of #'read-char . + (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) + (let ((name (c::debug-info-name debug-info)) + (source (c::debug-info-source debug-info))) + (destructuring-bind (first) source + (ecase (c::debug-source-from first) + (:file + (list (list name + (make-location + (list :file (unix-truename (c::debug-source-name first))) + (list :function-name (string name)))))))))) + +(defun valid-function-name-p (name) + (or (symbolp name) (and (consp name) + (eq (car name) 'setf) + (symbolp (cadr name)) + (not (cddr name))))) + +(defun code-component-entry-points (code) + "Return a list ((name location) ...) of function definitons for + the code omponent 'code." + (let ((names '())) + (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) + ((not f)) + (let ((name (kernel:%function-name f))) + (when (valid-function-name-p name) + (push (list name (function-location f)) names)))) + names)) + +(defimplementation list-callers (symbol) + "Return a list ((name location) ...) of callers." + (let ((components (function-callers symbol)) + (xrefs '())) + (dolist (code components) + (let* ((entry (kernel:%code-entry-points code)) + (defs (if entry + (code-component-entry-points code) + ;; byte compiled stuff + (debug-info-definitions + (kernel:%code-debug-info code))))) + (setq xrefs (nconc defs xrefs)))) + xrefs)) + +(defimplementation list-callees (symbol) + (let ((fns (function-callees symbol))) + (mapcar (lambda (fn) + (list (kernel:%function-name fn) + (function-location fn))) + fns))) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the SCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. + This is useful when debugging the definition-finding code.") + +(defmacro safe-definition-finding (&body body) + "Execute 'body and return the source-location it returns. + If an error occurs and `*debug-definition-finding*' is false, then + return an error pseudo-location. + + The second return value is 'nil if no error occurs, otherwise it is the + condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values (list :error (princ-to-string c)) c)))))) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for 'code-location." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for 'code-location in 'filename." + (let* ((code-date (di:debug-source-created debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a 'code-location from a stream. + This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :offset (getf info :emacs-buffer-offset) position) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for 'debug-info. + Function-name source-locations are a fallback for when precise + positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of 'debug-source contain an Emacs buffer location? + This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream) + "Return the byte offset of 'code-location in 'stream. Extract the + toplevel-form-number and form-number from 'code-location and use that + to find the position of the corresponding form. + + Finish with 'stream positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (di:code-location-top-level-form-offset location)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in 'stream. + 'tlf-number is the top-level-form number. + 'form-number is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of 'code-location in 'string. + See 'code-location-stream-position." + (with-input-from-string (s string) + (code-location-stream-position code-location s))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name))) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; SCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the SCL manual for more details. + +(defun function-definitions (name) + "Return definitions for 'name in the \"function namespace\", i.e., + regular functions, generic functions, methods and macros. + 'name can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (special? (and (symbolp name) (special-operator-p name))) + (function? (and (valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (special? + (list `((:special-operator ,name) + (:error ,(format nil "Special operator: ~S" name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (generic-function-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for 'function." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + + +(defun byte-function-location (fn) + "Return the location of the byte-compiled function 'fn." + (etypecase fn + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((component (c::byte-function-component fn)) + (debug-info (kernel:%code-debug-info component))) + (debug-info-function-name-location debug-info))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fn))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in SCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is 'function a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that 'function belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + ;; Find the location in a constructor. + (function-location (struct-constructor dd))) + +(defun struct-constructor (dd) + "Return a constructor function from a defstruct definition. +Signal an error if no constructor can be found." + (let ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (when (or (null constructor) + (and (consp constructor) (null (car constructor)))) + (error "Cannot find structure's constructor: ~S" + (kernel::dd-name dd))) + (coerce (if (consp constructor) (first constructor) constructor) + 'function))) + +;;;;;; Generic functions and methods + +(defun generic-function-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (clos:generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (clos:generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (clos:method-generic-function method)) + (name (clos:generic-function-name gf)) + (specializers (clos:method-specializers method)) + (qualifiers (clos:method-qualifiers method))) + `(method ,name ,@qualifiers ,specializers + #+nil (clos::unparse-specializers specializers)))) + +;; XXX maybe special case setters/getters +(defun method-location (method) + (function-location (clos:method-function method))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (find-class name nil))) + (etypecase class + (null '()) + (structure-class + (list (list `(defstruct ,name) + (dd-location (find-dd name))))) + (standard-class + (list (list `(defclass ,name) + (class-location (find-class name))))) + ((or built-in-class + kernel:funcallable-structure-class) + (list (list `(kernel::define-type-class ,name) + `(:error + ,(format nil "No source info for ~A" name))))))))) + +(defun class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (class-name class))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((name (class-name class))) + `(:error ,(format nil "No location info for condition: ~A" name)))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun definition-source-location (object name) + `(:error ,(format nil "No source info for: ~A" object))) + +(defun setf-definitions (name) + (let ((function (or (ext:info :setf :inverse name) + (ext:info :setf :expander name)))) + (if function + (list (list `(setf ,name) + (function-location (coerce function 'function))))))) + + +(defun variable-location (symbol) + `(:error ,(format nil "No source info for variable ~S" symbol))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(c::vop ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unknown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (multiple-value-bind (args winp) + (ext:function-arglist fun) + (if winp args :not-available))) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((typep function 'generic-function) + (clos:generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. + A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (macroexpand form)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation pathname-to-filename (pathname) + (ext:unix-namestring pathname nil)) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + (if (eq ext:*case-mode* :upper) "scl" "scl-lower")) + +(defimplementation quit-lisp () + (ext:quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error 'sldb-condition + :original-condition condition)))) + (funcall debugger-loop-fn)))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location (index) + (code-location-source-location (di:frame-code-location (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (di::debug-function-debug-variables (di:frame-debug-function frame))) + +(defun debug-var-value (var frame location) + (let ((validity (di:debug-variable-validity var location))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of SCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:ucontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:ucontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; SCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol + (symbol-name '#:function-end-breakpoint-values/standard) + :debug-internals))) + (cond (sym (funcall sym sigcontext)) + (t (di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +#+nil +(defimplementation condition-extras ((c breakpoint)) + ;; simply pop up the source buffer + `((:short-frame-source 0))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +#+nil +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + ((or di::bogus-debug-function di::interpreted-debug-function) + -1))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +CSP = ~X +CFP = ~X +IP = ~X +OCFP = ~X +LRA = ~X~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + + +(defimplementation disassemble-frame (frame-number) + "Return a string with the disassembly of frames code." + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (format t "~%[Disassembling bogus frames not implemented]"))))) + + +;;;; Inspecting + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:instance-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:function-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp (symbol-name '#:-type) (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list (symbol-name '#:-type) :vm) + (apropos-list (symbol-name '#:-type) :bignum)))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((di::indirect-value-cell-p o) + `("Value: " (:value ,(c:value-cell-ref o)))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (scl-inspect o)))) + +(defun scl-inspect (o) + (destructuring-bind (text labeledp . parts) + (inspect::describe-parts o) + (list* (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (list* (format nil "~A is a function.~%" o) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (list* (format nil "~A is a closure.~%" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (- (kernel:get-closure-length o) + (1- vm:closure-info-offset)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (scl-inspect o)) + (t + (call-next-method))))) + + +(defmethod emacs-inspect ((o kernel:code-component)) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((kernel:%code-debug-info o) + (disassem:disassemble-code-component o :stream s)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift) + :stream s))))))) + +(defmethod emacs-inspect ((o kernel:fdefn)) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) + +(defmethod emacs-inspect ((o array)) + (cond ((kernel:array-header-p o) + (list* (format nil "~A is an array.~%" o) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + (t + (list* (format nil "~A is an simple-array.~%" o) + (label-value-line* + (:header (describe-primitive-type o)) + (:length (length o))))))) + +(defmethod emacs-inspect ((o simple-vector)) + (list* (format nil "~A is a vector.~%" o) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (unless (eq (array-element-type o) 'nil) + (loop for i below (length o) + append (label-value-line i (aref o i))))))) + +(defun inspect-alien-record (alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (label-value-line slot (alien:slot alien slot)))))))) + +(defun inspect-alien-pointer (alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (scl-inspect alien)))) + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + #+nil :methods #+nil methods)) + + +;;;; Multiprocessing + +(defimplementation spawn (fn &key name) + (thread:thread-create fn :name (or name "Anonymous"))) + +(defvar *thread-id-counter* 0) +(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter")) + +(defimplementation thread-id (thread) + (thread:with-lock-held (*thread-id-counter-lock*) + (or (getf (thread:thread-plist thread) 'id) + (setf (getf (thread:thread-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (block find-thread + (thread:map-over-threads + #'(lambda (thread) + (when (eql (getf (thread:thread-plist thread) 'id) id) + (return-from find-thread thread)))))) + +(defimplementation thread-name (thread) + (princ-to-string (thread:thread-name thread))) + +(defimplementation thread-status (thread) + (let ((dynamic-values (thread::thread-dynamic-values thread))) + (if (zerop dynamic-values) "Exited" "Running"))) + +(defimplementation make-lock (&key name) + (thread:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (thread:with-lock-held (lock) (funcall function))) + +(defimplementation current-thread () + thread:*thread*) + +(defimplementation all-threads () + (let ((all-threads nil)) + (thread:map-over-threads #'(lambda (thread) (push thread all-threads))) + all-threads)) + +(defimplementation interrupt-thread (thread fn) + (thread:thread-interrupt thread #'(lambda () + (sys:with-interrupts + (funcall fn))))) + +(defimplementation kill-thread (thread) + (thread:destroy-thread thread)) + +(defimplementation thread-alive-p (thread) + (not (zerop (thread::thread-dynamic-values thread)))) + +(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil)) + +(defstruct (mailbox) + (lock (thread:make-lock "Thread mailbox" :type :error-check + :interruptible nil) + :type thread:error-check-lock) + (queue '() :type list)) + +(defun mailbox (thread) + "Return 'thread's mailbox." + (sys:without-interrupts + (thread:with-lock-held (*mailbox-lock*) + (or (getf (thread:thread-plist thread) 'mailbox) + (setf (getf (thread:thread-plist thread) 'mailbox) + (make-mailbox)))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (lock (mailbox-lock mbox))) + (sys:without-interrupts + (thread:with-lock-held (lock "Mailbox Send") + (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) + (list message))))) + (mp:process-wakeup thread))) + +#+nil +(defimplementation receive () + (receive-if (constantly t))) + +(defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox thread:*thread*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (sys:without-interrupts + (mp:with-lock-held ((mailbox-lock mbox)) + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox))))))) + + + +(defimplementation emacs-connected ()) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;; In SCL, we have: +;; (trace ) +;; (trace (method ? (+))) +;; (trace :methods t ') ;;to trace all methods of the gf +;; can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + nil) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ;; this isn't actually supported + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +;;; Weak datastructures + +;;; Not implemented in SCL. +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/source-file-cache.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/source-file-cache.lisp new file mode 100644 index 0000000..e639ea1 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/source-file-cache.lisp @@ -0,0 +1,136 @@ +;;;; Source-file cache +;;; +;;; To robustly find source locations in CMUCL and SBCL it's useful to +;;; have the exact source code that the loaded code was compiled from. +;;; In this source we can accurately find the right location, and from +;;; that location we can extract a "snippet" of code to show what the +;;; definition looks like. Emacs can use this snippet in a best-match +;;; search to locate the right definition, which works well even if +;;; the buffer has been modified. +;;; +;;; The idea is that if a definition previously started with +;;; `(define-foo bar' then it probably still does. +;;; +;;; Whenever we see that the file on disk has the same +;;; `file-write-date' as a location we're looking for we cache the +;;; whole file inside Lisp. That way we will still have the matching +;;; version even if the file is later modified on disk. If the file is +;;; later recompiled and reloaded then we replace our cache entry. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(defpackage swank/source-file-cache + (:use cl) + (:import-from swank/backend + defimplementation buffer-first-change + guess-external-format + find-external-format) + (:export + get-source-code + source-cache-get ;FIXME: isn't it odd that both are exported? + + *source-snippet-size* + read-snippet + read-snippet-from-string + )) + +(in-package swank/source-file-cache) + +(defvar *cache-sourcecode* t + "When true complete source files are cached. +The cache is used to keep known good copies of the source text which +correspond to the loaded code. Finding definitions is much more +reliable when the exact source is available, so we cache it in case it +gets edited on disk later.") + +(defvar *source-file-cache* (make-hash-table :test 'equal) + "Cache of source file contents. +Maps from truename to source-cache-entry structure.") + +(defstruct (source-cache-entry + (:conc-name source-cache-entry.) + (:constructor make-source-cache-entry (text date))) + text date) + +(defimplementation buffer-first-change (filename) + "Load a file into the cache when the user modifies its buffer. +This is a win if the user then saves the file and tries to M-. into it." + (unless (source-cached-p filename) + (ignore-errors + (source-cache-get filename (file-write-date filename)))) + nil) + +(defun get-source-code (filename code-date) + "Return the source code for FILENAME as written on DATE in a string. +If the exact version cannot be found then return the current one from disk." + (or (source-cache-get filename code-date) + (read-file filename))) + +(defun source-cache-get (filename date) + "Return the source code for FILENAME as written on DATE in a string. +Return NIL if the right version cannot be found." + (when *cache-sourcecode* + (let ((entry (gethash filename *source-file-cache*))) + (cond ((and entry (equal date (source-cache-entry.date entry))) + ;; Cache hit. + (source-cache-entry.text entry)) + ((or (null entry) + (not (equal date (source-cache-entry.date entry)))) + ;; Cache miss. + (if (equal (file-write-date filename) date) + ;; File on disk has the correct version. + (let ((source (read-file filename))) + (setf (gethash filename *source-file-cache*) + (make-source-cache-entry source date)) + source) + nil)))))) + +(defun source-cached-p (filename) + "Is any version of FILENAME in the source cache?" + (if (gethash filename *source-file-cache*) t)) + +(defun read-file (filename) + "Return the entire contents of FILENAME as a string." + (with-open-file (s filename :direction :input + :external-format (or (guess-external-format filename) + (find-external-format "latin-1") + :default)) + (let* ((string (make-string (file-length s))) + (length (read-sequence string s))) + (subseq string 0 length)))) + +;;;; Snippets + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. +Snippets at the beginning of definitions are used to tell Emacs what +the definitions looks like, so that it can accurately find them by +text search.") + +(defun read-snippet (stream &optional position) + "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. +If POSITION is given, set the STREAM's file position first." + (when position + (file-position stream position)) + #+sbcl (skip-comments-and-whitespace stream) + (read-upto-n-chars stream *source-snippet-size*)) + +(defun read-snippet-from-string (string &optional position) + (with-input-from-string (s string) + (read-snippet s position))) + +(defun skip-comments-and-whitespace (stream) + (case (peek-char nil stream nil nil) + ((#\Space #\Tab #\Newline #\Linefeed #\Page) + (read-char stream) + (skip-comments-and-whitespace stream)) + (#\; + (read-line stream) + (skip-comments-and-whitespace stream)))) + +(defun read-upto-n-chars (stream n) + "Return a string of upto N chars from STREAM." + (let* ((string (make-string n)) + (chars (read-sequence string stream))) + (subseq string 0 chars))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/source-path-parser.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/source-path-parser.lisp new file mode 100644 index 0000000..bb9c35c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/swank/source-path-parser.lisp @@ -0,0 +1,239 @@ +;;;; Source-paths + +;;; CMUCL/SBCL use a data structure called "source-path" to locate +;;; subforms. The compiler assigns a source-path to each form in a +;;; compilation unit. Compiler notes usually contain the source-path +;;; of the error location. +;;; +;;; Compiled code objects don't contain source paths, only the +;;; "toplevel-form-number" and the (sub-) "form-number". To get from +;;; the form-number to the source-path we need the entire toplevel-form +;;; (i.e. we have to read the source code). CMUCL has already some +;;; utilities to do this translation, but we use some extended +;;; versions, because we need more exact position info. Apparently +;;; Hemlock is happy with the position of the toplevel-form; we also +;;; need the position of subforms. +;;; +;;; We use a special readtable to get the positions of the subforms. +;;; The readtable stores the start and end position for each subform in +;;; hashtable for later retrieval. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +;;; Taken from swank-cmucl.lisp, by Helmut Eller + +(defpackage swank/source-path-parser + (:use cl) + (:export + read-source-form + source-path-string-position + source-path-file-position + source-path-source-position + + sexp-in-bounds-p + sexp-ref) + (:shadow ignore-errors)) + +(in-package swank/source-path-parser) + +;; Some test to ensure the required conformance +(let ((rt (copy-readtable nil))) + (assert (or (not (get-macro-character #\space rt)) + (nth-value 1 (get-macro-character #\space rt)))) + (assert (not (get-macro-character #\\ rt)))) + +(eval-when (:compile-toplevel) + (defmacro ignore-errors (&rest forms) + ;;`(progn . ,forms) ; for debugging + `(cl:ignore-errors . ,forms))) + +(defun make-sharpdot-reader (orig-sharpdot-reader) + (lambda (s c n) + ;; We want things like M-. to work regardless of any #.-fu in + ;; the source file that is to be visited. (For instance, when a + ;; file contains #. forms referencing constants that do not + ;; currently exist in the image.) + (ignore-errors (funcall orig-sharpdot-reader s c n)))) + +(defun make-source-recorder (fn source-map) + "Return a macro character function that does the same as FN, but +additionally stores the result together with the stream positions +before and after of calling FN in the hashtable SOURCE-MAP." + (lambda (stream char) + (let ((start (1- (file-position stream))) + (values (multiple-value-list (funcall fn stream char))) + (end (file-position stream))) + #+(or) + (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" + start values end (char-code char) char) + (when values + (destructuring-bind (&optional existing-start &rest existing-end) + (car (gethash (car values) source-map)) + ;; Some macros may return what a sub-call to another macro + ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice, + ;; once from #\# and once from #\(. If the saved form + ;; is a subform, don't save it again. + (unless (and existing-start existing-end + (<= start existing-start end) + (<= start existing-end end)) + (push (cons start end) (gethash (car values) source-map))))) + (values-list values)))) + +(defun make-source-recording-readtable (readtable source-map) + (declare (type readtable readtable) (type hash-table source-map)) + "Return a source position recording copy of READTABLE. +The source locations are stored in SOURCE-MAP." + (flet ((install-special-sharpdot-reader (rt) + (let ((fun (ignore-errors + (get-dispatch-macro-character #\# #\. rt)))) + (when fun + (let ((wrapper (make-sharpdot-reader fun))) + (set-dispatch-macro-character #\# #\. wrapper rt))))) + (install-wrappers (rt) + (dotimes (code 128) + (let ((char (code-char code))) + (multiple-value-bind (fun nt) (get-macro-character char rt) + (when fun + (let ((wrapper (make-source-recorder fun source-map))) + (set-macro-character char wrapper nt rt)))))))) + (let ((rt (copy-readtable readtable))) + (install-special-sharpdot-reader rt) + (install-wrappers rt) + rt))) + +;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning. +;; Should be possible as we only need the right "list structure" and +;; not the right atoms. +(defun read-and-record-source-map (stream) + "Read the next object from STREAM. +Return the object together with a hashtable that maps +subexpressions of the object to stream positions." + (let* ((source-map (make-hash-table :test #'eq)) + (*readtable* (make-source-recording-readtable *readtable* source-map)) + (*read-suppress* nil) + (start (file-position stream)) + (form (ignore-errors (read stream))) + (end (file-position stream))) + ;; ensure that at least FORM is in the source-map + (unless (gethash form source-map) + (push (cons start end) (gethash form source-map))) + (values form source-map))) + +(defun starts-with-p (string prefix) + (declare (type string string prefix)) + (not (mismatch string prefix + :end1 (min (length string) (length prefix)) + :test #'char-equal))) + +(defun extract-package (line) + (declare (type string line)) + (let ((name (cadr (read-from-string line)))) + (find-package name))) + +#+(or) +(progn + (assert (extract-package "(in-package cl)")) + (assert (extract-package "(cl:in-package cl)")) + (assert (extract-package "(in-package \"CL\")")) + (assert (extract-package "(in-package #:cl)"))) + +;; FIXME: do something cleaner than this. +(defun readtable-for-package (package) + ;; KLUDGE: due to the load order we can't reference the swank + ;; package. + (funcall (read-from-string "swank::guess-buffer-readtable") + (string-upcase (package-name package)))) + +;; Search STREAM for a "(in-package ...)" form. Use that to derive +;; the values for *PACKAGE* and *READTABLE*. +;; +;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends +;; use the same heuristic and to avoid the need to access +;; swank::guess-buffer-readtable from here. +(defun guess-reader-state (stream) + (let* ((point (file-position stream)) + (pkg *package*)) + (file-position stream 0) + (loop for line = (read-line stream nil nil) do + (when (not line) (return)) + (when (or (starts-with-p line "(in-package ") + (starts-with-p line "(cl:in-package ")) + (let ((p (extract-package line))) + (when p (setf pkg p))) + (return))) + (file-position stream point) + (values (readtable-for-package pkg) pkg))) + +(defun skip-whitespace (stream) + (peek-char t stream nil nil)) + +;; Skip over N toplevel forms. +(defun skip-toplevel-forms (n stream) + (let ((*read-suppress* t)) + (dotimes (i n) + (read stream)) + (skip-whitespace stream))) + +(defun read-source-form (n stream) + "Read the Nth toplevel form number with source location recording. +Return the form and the source-map." + (multiple-value-bind (*readtable* *package*) (guess-reader-state stream) + (skip-toplevel-forms n stream) + (read-and-record-source-map stream))) + +(defun source-path-stream-position (path stream) + "Search the source-path PATH in STREAM and return its position." + (check-source-path path) + (destructuring-bind (tlf-number . path) path + (multiple-value-bind (form source-map) (read-source-form tlf-number stream) + (source-path-source-position (cons 0 path) form source-map)))) + +(defun check-source-path (path) + (unless (and (consp path) + (every #'integerp path)) + (error "The source-path ~S is not valid." path))) + +(defun source-path-string-position (path string) + (with-input-from-string (s string) + (source-path-stream-position path s))) + +(defun source-path-file-position (path filename) + ;; We go this long way round, and don't directly operate on the file + ;; stream because FILE-POSITION (used above) is not totally savy even + ;; on file character streams; on SBCL, FILE-POSITION returns the binary + ;; offset, and not the character offset---screwing up on Unicode. + (let ((toplevel-number (first path)) + (buffer)) + (with-open-file (file filename) + (skip-toplevel-forms (1+ toplevel-number) file) + (let ((endpos (file-position file))) + (setq buffer (make-array (list endpos) :element-type 'character + :initial-element #\Space)) + (assert (file-position file 0)) + (read-sequence buffer file :end endpos))) + (source-path-string-position path buffer))) + +(defgeneric sexp-in-bounds-p (sexp i) + (:method ((list list) i) + (< i (loop for e on list + count t))) + (:method ((sexp t) i) nil)) + +(defgeneric sexp-ref (sexp i) + (:method ((s list) i) (elt s i))) + +(defun source-path-source-position (path form source-map) + "Return the start position of PATH from FORM and SOURCE-MAP. All +subforms along the path are considered and the start and end position +of the deepest (i.e. smallest) possible form is returned." + ;; compute all subforms along path + (let ((forms (loop for i in path + for f = form then (if (sexp-in-bounds-p f i) + (sexp-ref f i)) + collect f))) + ;; select the first subform present in source-map + (loop for form in (nreverse forms) + for ((start . end) . rest) = (gethash form source-map) + when (and start end (not rest)) + return (return (values start end))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/xref.lisp b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/xref.lisp new file mode 100644 index 0000000..e09a150 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/xref.lisp @@ -0,0 +1,2906 @@ +;;; -*- Mode: LISP; Package: XREF; Syntax: Common-lisp; -*- +;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz +;;; xref.lisp + +;;; **************************************************************** +;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp +;;; **************************************************************** +;;; +;;; The List Callers system is a portable Common Lisp cross referencing +;;; utility. It grovels over a set of files and compiles a database of the +;;; locations of all references for each symbol used in the files. +;;; List Callers is similar to the Symbolics Who-Calls and the +;;; Xerox Masterscope facilities. +;;; +;;; When you change a function or variable definition, it can be useful +;;; to know its callers, in order to update each of them to the new +;;; definition. Similarly, having a graphic display of the structure +;;; (e.g., call graph) of a program can help make undocumented code more +;;; understandable. This static code analyzer facilitates both capabilities. +;;; The database compiled by xref is suitable for viewing by a graphical +;;; browser. (Note: the reference graph is not necessarily a DAG. Since many +;;; graphical browsers assume a DAG, this will lead to infinite loops. +;;; Some code which is useful in working around this problem is included, +;;; as well as a sample text-indenting outliner and an interface to Bates' +;;; PSGraph Postscript Graphing facility.) +;;; +;;; Written by Mark Kantrowitz, July 1990. +;;; +;;; Address: School of Computer Science +;;; Carnegie Mellon University +;;; Pittsburgh, PA 15213 +;;; +;;; Copyright (c) 1990. All rights reserved. +;;; +;;; See general license below. +;;; + +;;; **************************************************************** +;;; General License Agreement and Lack of Warranty ***************** +;;; **************************************************************** +;;; +;;; This software is distributed in the hope that it will be useful (both +;;; in and of itself and as an example of lisp programming), but WITHOUT +;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for +;;; the consequences of using it or for whether it serves any particular +;;; purpose or works at all. No warranty is made about the software or its +;;; performance. +;;; +;;; Use and copying of this software and the preparation of derivative +;;; works based on this software are permitted, so long as the following +;;; conditions are met: +;;; o The copyright notice and this entire notice are included intact +;;; and prominently carried on all copies and supporting documentation. +;;; o No fees or compensation are charged for use, copies, or +;;; access to this software. You may charge a nominal +;;; distribution fee for the physical act of transferring a +;;; copy, but you may not charge for the program itself. +;;; o If you modify this software, you must cause the modified +;;; file(s) to carry prominent notices (a Change Log) +;;; describing the changes, who made the changes, and the date +;;; of those changes. +;;; o Any work distributed or published that in whole or in part +;;; contains or is a derivative of this software or any part +;;; thereof is subject to the terms of this agreement. The +;;; aggregation of another unrelated program with this software +;;; or its derivative on a volume of storage or distribution +;;; medium does not bring the other program under the scope +;;; of these terms. +;;; o Permission is granted to manufacturers and distributors of +;;; lisp compilers and interpreters to include this software +;;; with their distribution. +;;; +;;; This software is made available AS IS, and is distributed without +;;; warranty of any kind, either expressed or implied. +;;; +;;; In no event will the author(s) or their institutions be liable to you +;;; for damages, including lost profits, lost monies, or other special, +;;; incidental or consequential damages arising out of or in connection +;;; with the use or inability to use (including but not limited to loss of +;;; data or data being rendered inaccurate or losses sustained by third +;;; parties or a failure of the program to operate as documented) the +;;; program, even if you have been advised of the possibility of such +;;; damanges, or for any claim by any other party, whether in an action of +;;; contract, negligence, or other tortious action. +;;; +;;; The current version of this software and a variety of related utilities +;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory +;;; user/ai/lang/lisp/code/tools/xref/ +;;; +;;; Please send bug reports, comments, questions and suggestions to +;;; mkant@cs.cmu.edu. We would also appreciate receiving any changes +;;; or improvements you may make. +;;; +;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list, +;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email +;;; address, and affiliation. This mailing list is primarily for +;;; notification about major updates, bug fixes, and additions to the lisp +;;; utilities collection. The mailing list is intended to have low traffic. +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 27-FEB-91 mk Added insert arg to psgraph-xref to allow the postscript +;;; graphs to be inserted in Scribe documents. +;;; 21-FEB-91 mk Added warning if not compiled. +;;; 07-FEB-91 mk Fixed bug in record-callers with regard to forms at +;;; toplevel. +;;; 21-JAN-91 mk Added file xref-test.lisp to test xref. +;;; 16-JAN-91 mk Added definition WHO-CALLS to parallel the Symbolics syntax. +;;; 16-JAN-91 mk Added macroexpansion capability to record-callers. Also +;;; added parameter *handle-macro-forms*, defaulting to T. +;;; 16-JAN-91 mk Modified print-caller-tree and related functions +;;; to allow the user to specify root nodes. If the user +;;; doesn't specify them, it will default to all root +;;; nodes, as before. +;;; 16-JAN-91 mk Added parameter *default-graphing-mode* to specify +;;; the direction of the graphing. Either :call-graph, +;;; where the children of a node are those functions called +;;; by the node, or :caller-graph where the children of a +;;; node are the callers of the node. :call-graph is the +;;; default. +;;; 16-JAN-91 mk Added parameter *indent-amount* to control the indentation +;;; in print-indented-tree. +;;; 16-JUL-90 mk Functions with argument lists of () were being ignored +;;; because of a (when form) wrapped around the body of +;;; record-callers. Then intent of (when form) was as an extra +;;; safeguard against infinite looping. This wasn't really +;;; necessary, so it has been removed. +;;; 16-JUL-90 mk PSGraph-XREF now has keyword arguments, instead of +;;; optionals. +;;; 16-JUL-90 mk Added PRINT-CLASS-HIERARCHY to use psgraph to graph the +;;; CLOS class hierarchy. This really doesn't belong here, +;;; and should be moved to psgraph.lisp as an example of how +;;; to use psgraph. +;;; 16-JUL-90 mk Fixed several caller patterns. The pattern for member +;;; had an error which caused many references to be missed. +;;; 16-JUL-90 mk Added ability to save/load processed databases. +;;; 5-JUL-91 mk Fixed warning of needing compilation to occur only when the +;;; source is loaded. +;;; 20-SEP-93 mk Added fix from Peter Norvig to allow Xref to xref itself. +;;; The arg to macro-function must be a symbol. +;;; 7-APR-12 heller Break lines at 80 columns. + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; Verify that: +;;; o null forms don't cause it to infinite loop. +;;; o nil matches against null argument lists. +;;; o declarations and doc are being ignored. +;;; +;;; Would be nice if in addition to showing callers of a function, it +;;; displayed the context of the calls to the function (e.g., the +;;; immediately surrounding form). This entails storing entries of +;;; the form (symbol context*) in the database and augmenting +;;; record-callers to keep the context around. The only drawbacks is +;;; that it would cons a fair bit. If we do this, we should store +;;; additional information as well in the database, such as the caller +;;; pattern type (e.g., variable vs. function). +;;; +;;; Write a translator from BNF (at least as much of BNF as is used +;;; in CLtL2), to the format used here. +;;; +;;; Should automatically add new patterns for new functions and macros +;;; based on their arglists. Probably requires much more than this +;;; simple code walker, so there isn't much we can do. +;;; +;;; Defmacro is a problem, because it often hides internal function +;;; calls within backquote and quote, which we normally ignore. If +;;; we redefine QUOTE's pattern so that it treats the arg like a FORM, +;;; we'll probably get them (though maybe the syntax will be mangled), +;;; but most likely a lot of spurious things as well. +;;; +;;; Define an operation for Defsystem which will run XREF-FILE on the +;;; files of the system. Or yet simpler, when XREF sees a LOAD form +;;; for which the argument is a string, tries to recursively call +;;; XREF-FILE on the specified file. Then one could just XREF-FILE +;;; the file which loads the system. (This should be a program +;;; parameter.) +;;; +;;; Have special keywords which the user may place in a file to have +;;; XREF-FILE ignore a region. +;;; +;;; Should we distinguish flet and labels from defun? I.e., note that +;;; flet's definitions are locally defined, instead of just lumping +;;; them in with regular definitions. +;;; +;;; Add patterns for series, loop macro. +;;; +;;; Need to integrate the variable reference database with the other +;;; databases, yet maintain separation. So we can distinguish all +;;; the different types of variable and function references, without +;;; multiplying databases. +;;; +;;; Would pay to comment record-callers and record-callers* in more +;;; depth. +;;; +;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT) + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; XREF has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90) +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; +;;; XREF has been tested (unsuccessfully) in the following lisps: +;;; Ibuki Common Lisp (01/01, October 15, 1987) +;;; - if interpreted, runs into stack overflow +;;; - does not compile (tried ibcl on Suns, PMAXes and RTs) +;;; seems to be due to a limitation in the c compiler. +;;; +;;; XREF needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; Lucid Common Lisp (3.0, 4.0) +;;; KCL (June 3, 1987 or later) +;;; AKCL (1.86, June 30, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; HP Common Lisp (same as Lucid?) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; XREF analyzes a user's program, determining which functions call a +;;; given function, and the location of where variables are bound/assigned +;;; and used. The user may retrieve this information for either a single +;;; symbol, or display the call graph of portions of the program +;;; (including the entire program). This allows the programmer to debug +;;; and document the program's structure. +;;; +;;; XREF is primarily intended for analyzing large programs, where it is +;;; difficult, if not impossible, for the programmer to grasp the structure +;;; of the whole program. Nothing precludes using XREF for smaller programs, +;;; where it can be useful for inspecting the relationships between pieces +;;; of the program and for documenting the program. +;;; +;;; Two aspects of the Lisp programming language greatly simplify the +;;; analysis of Lisp programs: +;;; o Lisp programs are naturally represented as data. +;;; Successive definitions from a file are easily read in +;;; as list structure. +;;; o The basic syntax of Lisp is uniform. A list program +;;; consists of a set of nested forms, where each form is +;;; a list whose car is a tag (e.g., function name) that +;;; specifies the structure of the rest of the form. +;;; Thus Lisp programs, when represented as data, can be considered to be +;;; parse trees. Given a grammar of syntax patterns for the language, XREF +;;; recursively descends the parse tree for a given definition, computing +;;; a set of relations that hold for the definition at each node in the +;;; tree. For example, one kind of relation is that the function defined +;;; by the definition calls the functions in its body. The relations are +;;; stored in a database for later examination by the user. +;;; +;;; While XREF currently only works for programs written in Lisp, it could +;;; be extended to other programming languages by writing a function to +;;; generate parse trees for definitions in that language, and a core +;;; set of patterns for the language's syntax. +;;; +;;; Since XREF normally does a static syntactic analysis of the program, +;;; it does not detect references due to the expansion of a macro definition. +;;; To do this in full generality XREF would have to have knowledge about the +;;; semantics of the program (e.g., macros which call other functions to +;;; do the expansion). This entails either modifying the compiler to +;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing +;;; a walk of loaded code and macroexpanding as needed (PCL code walker). +;;; The former is not portable, while the latter requires that the code +;;; used by macros be loaded and in working order. On the other hand, then +;;; we would need no special knowledge about macros (excluding the 24 special +;;; forms of Lisp). +;;; +;;; Parameters may be set to enable macro expansion in XREF. Then XREF +;;; will expand any macros for which it does not have predefined patterns. +;;; (For example, most Lisps will implement dolist as a macro. Since XREF +;;; has a pattern defined for dolist, it will not call macroexpand-1 on +;;; a form whose car is dolist.) For this to work properly, the code must +;;; be loaded before being processed by XREF, and XREF's parameters should +;;; be set so that it processes forms in their proper packages. +;;; +;;; If macro expansion is disabled, the default rules for handling macro +;;; references may not be sufficient for some user-defined macros, because +;;; macros allow a variety of non-standard syntactic extensions to the +;;; language. In this case, the user may specify additional templates in +;;; a manner similar to that in which the core Lisp grammar was specified. +;;; + + +;;; ******************************** +;;; User Guide ********************* +;;; ******************************** +;;; ----- +;;; The following functions are called to cross reference the source files. +;;; +;;; XREF-FILES (&rest files) [FUNCTION] +;;; Grovels over the lisp code located in source file FILES, using +;;; xref-file. +;;; +;;; XREF-FILE (filename &optional clear-tables verbose) [Function] +;;; Cross references the function and variable calls in FILENAME by +;;; walking over the source code located in the file. Defaults type of +;;; filename to ".lisp". Chomps on the code using record-callers and +;;; record-callers*. If CLEAR-TABLES is T (the default), it clears the +;;; callers database before processing the file. Specify CLEAR-TABLES as +;;; nil to append to the database. If VERBOSE is T (the default), prints +;;; out the name of the file, one progress dot for each form processed, +;;; and the total number of forms. +;;; +;;; ----- +;;; The following functions display information about the uses of the +;;; specified symbol as a function, variable, or constant. +;;; +;;; LIST-CALLERS (symbol) [FUNCTION] +;;; Lists all functions which call SYMBOL as a function (function +;;; invocation). +;;; +;;; LIST-READERS (symbol) [FUNCTION] +;;; Lists all functions which refer to SYMBOL as a variable +;;; (variable reference). +;;; +;;; LIST-SETTERS (symbol) [FUNCTION] +;;; Lists all functions which bind/set SYMBOL as a variable +;;; (variable mutation). +;;; +;;; LIST-USERS (symbol) [FUNCTION] +;;; Lists all functions which use SYMBOL as a variable or function. +;;; +;;; WHO-CALLS (symbol &optional how) [FUNCTION] +;;; Lists callers of symbol. HOW may be :function, :reader, :setter, +;;; or :variable." +;;; +;;; WHAT-FILES-CALL (symbol) [FUNCTION] +;;; Lists names of files that contain uses of SYMBOL +;;; as a function, variable, or constant. +;;; +;;; SOURCE-FILE (symbol) [FUNCTION] +;;; Lists the names of files in which SYMBOL is defined/used. +;;; +;;; LIST-CALLEES (symbol) [FUNCTION] +;;; Lists names of functions and variables called by SYMBOL. +;;; +;;; ----- +;;; The following functions may be useful for viewing the database and +;;; debugging the calling patterns. +;;; +;;; *LAST-FORM* () [VARIABLE] +;;; The last form read from the file. Useful for figuring out what went +;;; wrong when xref-file drops into the debugger. +;;; +;;; *XREF-VERBOSE* t [VARIABLE] +;;; When T, xref-file(s) prints out the names of the files it looks at, +;;; progress dots, and the number of forms read. +;;; +;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2)) [VARIABLE] +;;; Default set of caller types (as specified in the patterns) to ignore +;;; in the database handling functions. :lisp is CLtL 1st edition, +;;; :lisp2 is additional patterns from CLtL 2nd edition. +;;; +;;; *HANDLE-PACKAGE-FORMS* () [VARIABLE] +;;; When non-NIL, and XREF-FILE sees a package-setting form like +;;; IN-PACKAGE, sets the current package to the specified package by +;;; evaluating the form. When done with the file, xref-file resets the +;;; package to its original value. In some of the displaying functions, +;;; when this variable is non-NIL one may specify that all symbols from a +;;; particular set of packages be ignored. This is only useful if the +;;; files use different packages with conflicting names. +;;; +;;; *HANDLE-FUNCTION-FORMS* t [VARIABLE] +;;; When T, XREF-FILE tries to be smart about forms which occur in +;;; a function position, such as lambdas and arbitrary Lisp forms. +;;; If so, it recursively calls record-callers with pattern 'FORM. +;;; If the form is a lambda, makes the caller a caller of +;;; :unnamed-lambda. +;;; +;;; *HANDLE-MACRO-FORMS* t [VARIABLE] +;;; When T, if the file was loaded before being processed by XREF, and +;;; the car of a form is a macro, it notes that the parent calls the +;;; macro, and then calls macroexpand-1 on the form. +;;; +;;; *DEFAULT-GRAPHING-MODE* :call-graph [VARIABLE] +;;; Specifies whether we graph up or down. If :call-graph, the children +;;; of a node are the functions it calls. If :caller-graph, the +;;; children of a node are the functions that call it. +;;; +;;; *INDENT-AMOUNT* 3 [VARIABLE] +;;; Number of spaces to indent successive levels in PRINT-INDENTED-TREE. +;;; +;;; DISPLAY-DATABASE (&optional database types-to-ignore) [FUNCTION] +;;; Prints out the name of each symbol and all its callers. Specify +;;; database :callers (the default) to get function call references, +;;; :file to the get files in which the symbol is called, :readers to get +;;; variable references, and :setters to get variable binding and +;;; assignments. Ignores functions of types listed in types-to-ignore. +;;; +;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact root-nodes) +;;; Prints the calling trees (which may actually be a full graph and not +;;; necessarily a DAG) as indented text trees using +;;; PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children +;;; of a node are the functions called by the node, or :caller-graph for +;;; trees where the children of a node are the functions the node calls. +;;; TYPES-TO-IGNORE is a list of funcall types (as specified in the +;;; patterns) to ignore in printing out the database. For example, +;;; '(:lisp) would ignore all calls to common lisp functions. COMPACT is +;;; a flag to tell the program to try to compact the trees a bit by not +;;; printing trees if they have already been seen. ROOT-NODES is a list +;;; of root nodes of trees to display. If ROOT-NODES is nil, tries to +;;; find all root nodes in the database. +;;; +;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact) +;;; Outputs list structure of a tree which roughly represents the +;;; possibly cyclical structure of the caller database. +;;; If mode is :call-graph, the children of a node are the functions +;;; it calls. If mode is :caller-graph, the children of a node are the +;;; functions that call it. +;;; If compact is T, tries to eliminate the already-seen nodes, so +;;; that the graph for a node is printed at most once. Otherwise it will +;;; duplicate the node's tree (except for cycles). This is usefull +;;; because the call tree is actually a directed graph, so we can either +;;; duplicate references or display only the first one. +;;; +;;; DETERMINE-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Makes a hash table of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically resolving +;;; file references for automatic creation of a system definition +;;; (defsystem). +;;; +;;; PRINT-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Prints a list of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically computing +;;; file loading constraints for a system definition tool. +;;; +;;; WRITE-CALLERS-DATABASE-TO-FILE (filename) [FUNCTION] +;;; Saves the contents of the current callers database to a file. This +;;; file can be loaded to restore the previous contents of the +;;; database. (For large systems it can take a long time to crunch +;;; through the code, so this can save some time.) +;;; +;;; ----- +;;; The following macros define new function and macro call patterns. +;;; They may be used to extend the static analysis tool to handle +;;; new def forms, extensions to Common Lisp, and program defs. +;;; +;;; DEFINE-PATTERN-SUBSTITUTION (name pattern) [MACRO] +;;; Defines NAME to be equivalent to the specified pattern. Useful for +;;; making patterns more readable. For example, the LAMBDA-LIST is +;;; defined as a pattern substitution, making the definition of the +;;; DEFUN caller-pattern simpler. +;;; +;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type) [MACRO] +;;; Defines NAME as a function/macro call with argument structure +;;; described by PATTERN. CALLER-TYPE, if specified, assigns a type to +;;; the pattern, which may be used to exclude references to NAME while +;;; viewing the database. For example, all the Common Lisp definitions +;;; have a caller-type of :lisp or :lisp2, so that you can exclude +;;; references to common lisp functions from the calling tree. +;;; +;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type) [MACRO] +;;; Defines NAME as a variable reference of type CALLER-TYPE. This is +;;; mainly used to establish the caller-type of the variable. +;;; +;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations) [MACRO] +;;; For defining function caller pattern syntax synonyms. For each name +;;; in DESTINATIONS, defines its pattern as a copy of the definition +;;; of SOURCE. Allows a large number of identical patterns to be defined +;;; simultaneously. Must occur after the SOURCE has been defined. +;;; +;;; ----- +;;; This system includes pattern definitions for the latest +;;; common lisp specification, as published in Guy Steele, +;;; Common Lisp: The Language, 2nd Edition. +;;; +;;; Patterns may be either structures to match, or a predicate +;;; like symbolp/numberp/stringp. The pattern specification language +;;; is similar to the notation used in CLtL2, but in a more lisp-like +;;; form: +;;; (:eq name) The form element must be eq to the symbol NAME. +;;; (:test test) TEST must be true when applied to the form element. +;;; (:typep type) The form element must be of type TYPE. +;;; (:or pat1 pat2 ...) Tries each of the patterns in left-to-right order, +;;; until one succeeds. +;;; Equivalent to { pat1 | pat2 | ... } +;;; (:rest pattern) The remaining form elements are grouped into a +;;; list which is matched against PATTERN. +;;; (:optional pat1 ...) The patterns may optionally match against the +;;; form element. +;;; Equivalent to [ pat1 ... ]. +;;; (:star pat1 ...) The patterns may match against the patterns +;;; any number of times, including 0. +;;; Equivalent to { pat1 ... }*. +;;; (:plus pat1 ...) The patterns may match against the patterns +;;; any number of times, but at least once. +;;; Equivalent to { pat1 ... }+. +;;; &optional, &key, Similar in behavior to the corresponding +;;; &rest lambda-list keywords. +;;; FORM A random lisp form. If a cons, assumes the +;;; car is a function or macro and tries to +;;; match the args against that symbol's pattern. +;;; If a symbol, assumes it's a variable reference. +;;; :ignore Ignores the corresponding form element. +;;; NAME The corresponding form element should be +;;; the name of a new definition (e.g., the +;;; first arg in a defun pattern is NAME. +;;; FUNCTION, MACRO The corresponding form element should be +;;; a function reference not handled by FORM. +;;; Used in the definition of apply and funcall. +;;; VAR The corresponding form element should be +;;; a variable definition or mutation. Used +;;; in the definition of let, let*, etc. +;;; VARIABLE The corresponding form element should be +;;; a variable reference. +;;; +;;; In all other pattern symbols, it looks up the symbols pattern substitution +;;; and recursively matches against the pattern. Automatically destructures +;;; list structure that does not include consing dots. +;;; +;;; Among the pattern substitution names defined are: +;;; STRING, SYMBOL, NUMBER Appropriate :test patterns. +;;; LAMBDA-LIST Matches against a lambda list. +;;; BODY Matches against a function body definition. +;;; FN Matches against #'function, 'function, +;;; and lambdas. This is used in the definition +;;; of apply, funcall, and the mapping patterns. +;;; and others... +;;; +;;; Here's some sample pattern definitions: +;;; (define-caller-pattern defun +;;; (name lambda-list +;;; (:star (:or documentation-string declaration)) +;;; (:star form)) +;;; :lisp) +;;; (define-caller-pattern funcall (fn (:star form)) :lisp) +;;; +;;; In general, the system is intelligent enough to handle any sort of +;;; simple funcall. One only need specify the syntax for functions and +;;; macros which use optional arguments, keyword arguments, or some +;;; argument positions are special, such as in apply and funcall, or +;;; to indicate that the function is of the specified caller type. +;;; +;;; +;;; NOTES: +;;; +;;; XRef assumes syntactically correct lisp code. +;;; +;;; This is by no means perfect. For example, let and let* are treated +;;; identically, instead of differentiating between serial and parallel +;;; binding. But it's still a useful tool. It can be helpful in +;;; maintaining code, debugging problems with patch files, determining +;;; whether functions are multiply defined, and help you remember where +;;; a function is defined or called. +;;; +;;; XREF runs best when compiled. + +;;; ******************************** +;;; References ********************* +;;; ******************************** +;;; +;;; Xerox Interlisp Masterscope Program: +;;; Larry M Masinter, Global program analysis in an interactive environment +;;; PhD Thesis, Stanford University, 1980. +;;; +;;; Symbolics Who-Calls Database: +;;; User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986 +;;; Genera 7.0, pp 183-185. +;;; + +;;; ******************************** +;;; Example ************************ +;;; ******************************** +;;; +;;; Here is an example of running XREF on a short program. +;;; [In Scribe documentation, give a simple short program and resulting +;;; XREF output, including postscript call graphs.] +#| + (xref:xref-file "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp") +Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp. +................................................ +48 forms processed. + (xref:display-database :readers) + +*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE. +*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO. +*DIRECTION* is referenced by CREATE-POSITION-INFO. +*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT. +*ROOT-IS-SEQUENCE* is referenced by GRAPH. +*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE. +*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO. +*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE. +*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE. +*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE. + (xref:print-caller-trees :root-nodes '(display-graph)) + +Rooted calling trees: + DISPLAY-GRAPH + CREATE-POSITION-INFO + CALCULATE-POSITION-INFO + CALCULATE-POSITION + NODE-POSITION-ALREADY-SET-FLAG + NODE-LEVEL-ALREADY-SET-FLAG + CALCULATE-POSITION-IN-LEVEL + NODE-CHILDREN + NODE-LEVEL + CALCULATE-POSITION + NEW-CALCULATE-BREADTH + NODE-CHILDREN + BREADTH + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + NEW-CALCULATE-BREADTH + NODE-PARENTS + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + OPPOSITE-POSITION + NODE-Y + NODE-X + NODE-LEVEL + CALCULATE-LEVEL-POSITION + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + DIMENSION + NODE-WIDTH + NODE-HEIGHT + CALCULATE-LEVEL-POSITION-BEFORE + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + NODE-WIDTH + NODE-HEIGHT + DIMENSION + NODE-WIDTH + NODE-HEIGHT +|# + +;;; **************************************************************** +;;; List Callers *************************************************** +;;; **************************************************************** + +(defpackage :pxref + (:use :common-lisp) + (:export #:list-callers + #:list-users + #:list-readers + #:list-setters + #:what-files-call + #:who-calls + #:list-callees + #:source-file + #:clear-tables + #:define-pattern-substitution + #:define-caller-pattern + #:define-variable-pattern + #:define-caller-pattern-synonyms + #:clear-patterns + #:*last-form* + #:*xref-verbose* + #:*handle-package-forms* + #:*handle-function-forms* + #:*handle-macro-forms* + #:*types-to-ignore* + #:*last-caller-tree* + #:*default-graphing-mode* + #:*indent-amount* + #:xref-file + #:xref-files + #:write-callers-database-to-file + #:display-database + #:print-caller-trees + #:make-caller-tree + #:print-indented-tree + #:determine-file-dependencies + #:print-file-dependencies + #:psgraph-xref + )) + +(in-package "PXREF") + +;;; Warn user if they're loading the source instead of compiling it first. +;(eval-when (compile load eval) +; (defvar compiled-p nil)) +;(eval-when (compile load) +; (setq compiled-p t)) +;(eval-when (load eval) +; (unless compiled-p +; (warn "This file should be compiled before loading for best results."))) +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + + +;;; ******************************** +;;; Primitives ********************* +;;; ******************************** +(defun lookup (symbol environment) + (dolist (frame environment) + (when (member symbol frame) + (return symbol)))) + +(defun car-eq (list item) + (and (consp list) + (eq (car list) item))) + +;;; ******************************** +;;; Callers Database *************** +;;; ******************************** +(defvar *file-callers-database* (make-hash-table :test #'equal) + "Contains name and list of file callers (files which call) for that name.") +(defvar *callers-database* (make-hash-table :test #'equal) + "Contains name and list of callers (function invocation) for that name.") +(defvar *readers-database* (make-hash-table :test #'equal) + "Contains name and list of readers (variable use) for that name.") +(defvar *setters-database* (make-hash-table :test #'equal) + "Contains name and list of setters (variable mutation) for that name.") +(defvar *callees-database* (make-hash-table :test #'equal) + "Contains name and list of functions and variables it calls.") +(defun callers-list (name &optional (database :callers)) + (case database + (:file (gethash name *file-callers-database*)) + (:callees (gethash name *callees-database*)) + (:callers (gethash name *callers-database*)) + (:readers (gethash name *readers-database*)) + (:setters (gethash name *setters-database*)))) +(defsetf callers-list (name &optional (database :callers)) (caller) + `(setf (gethash ,name (case ,database + (:file *file-callers-database*) + (:callees *callees-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*))) + ,caller)) + +(defun list-callers (symbol) + "Lists all functions which call SYMBOL as a function (function invocation)." + (callers-list symbol :callers)) +(defun list-readers (symbol) + "Lists all functions which refer to SYMBOL as a variable + (variable reference)." + (callers-list symbol :readers)) +(defun list-setters (symbol) + "Lists all functions which bind/set SYMBOL as a variable + (variable mutation)." + (callers-list symbol :setters)) +(defun list-users (symbol) + "Lists all functions which use SYMBOL as a variable or function." + (values (list-callers symbol) + (list-readers symbol) + (list-setters symbol))) +(defun who-calls (symbol &optional how) + "Lists callers of symbol. HOW may be :function, :reader, :setter, + or :variable." + ;; would be nice to have :macro and distinguish variable + ;; binding from assignment. (i.e., variable binding, assignment, and use) + (case how + (:function (list-callers symbol)) + (:reader (list-readers symbol)) + (:setter (list-setters symbol)) + (:variable (append (list-readers symbol) + (list-setters symbol))) + (otherwise (append (list-callers symbol) + (list-readers symbol) + (list-setters symbol))))) +(defun what-files-call (symbol) + "Lists names of files that contain uses of SYMBOL + as a function, variable, or constant." + (callers-list symbol :file)) +(defun list-callees (symbol) + "Lists names of functions and variables called by SYMBOL." + (callers-list symbol :callees)) + +(defvar *source-file* (make-hash-table :test #'equal) + "Contains function name and source file for that name.") +(defun source-file (symbol) + "Lists the names of files in which SYMBOL is defined/used." + (gethash symbol *source-file*)) +(defsetf source-file (name) (value) + `(setf (gethash ,name *source-file*) ,value)) + +(defun clear-tables () + (clrhash *file-callers-database*) + (clrhash *callers-database*) + (clrhash *callees-database*) + (clrhash *readers-database*) + (clrhash *setters-database*) + (clrhash *source-file*)) + + +;;; ******************************** +;;; Pattern Database *************** +;;; ******************************** +;;; Pattern Types +(defvar *pattern-caller-type* (make-hash-table :test #'equal)) +(defun pattern-caller-type (name) + (gethash name *pattern-caller-type*)) +(defsetf pattern-caller-type (name) (value) + `(setf (gethash ,name *pattern-caller-type*) ,value)) + +;;; Pattern Substitutions +(defvar *pattern-substitution-table* (make-hash-table :test #'equal) + "Stores general patterns for function destructuring.") +(defun lookup-pattern-substitution (name) + (gethash name *pattern-substitution-table*)) +(defmacro define-pattern-substitution (name pattern) + "Defines NAME to be equivalent to the specified pattern. Useful for + making patterns more readable. For example, the LAMBDA-LIST is + defined as a pattern substitution, making the definition of the + DEFUN caller-pattern simpler." + `(setf (gethash ',name *pattern-substitution-table*) + ',pattern)) + +;;; Function/Macro caller patterns: +;;; The car of the form is skipped, so we don't need to specify +;;; (:eq function-name) like we would for a substitution. +;;; +;;; Patterns must be defined in the XREF package because the pattern +;;; language is tested by comparing symbols (using #'equal) and not +;;; their printreps. This is fine for the lisp grammer, because the XREF +;;; package depends on the LISP package, so a symbol like 'xref::cons is +;;; translated automatically into 'lisp::cons. However, since +;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and +;;; 'baz::bar are inherited from the same package (e.g., LISP), +;;; if package handling is turned on the user must specify package +;;; names in the caller pattern definitions for functions that occur +;;; in packages other than LISP, otherwise the symbols will not match. +;;; +;;; Perhaps we should enforce the definition of caller patterns in the +;;; XREF package by wrapping the body of define-caller-pattern in +;;; the XREF package: +;;; (defmacro define-caller-pattern (name value &optional caller-type) +;;; (let ((old-package *package*)) +;;; (setf *package* (find-package "XREF")) +;;; (prog1 +;;; `(progn +;;; (when ',caller-type +;;; (setf (pattern-caller-type ',name) ',caller-type)) +;;; (when ',value +;;; (setf (gethash ',name *caller-pattern-table*) +;;; ',value))) +;;; (setf *package* old-package)))) +;;; Either that, or for the purpose of pattern testing we should compare +;;; printreps. [The latter makes the primitive patterns like VAR +;;; reserved words.] +(defvar *caller-pattern-table* (make-hash-table :test #'equal) + "Stores patterns for function destructuring.") +(defun lookup-caller-pattern (name) + (gethash name *caller-pattern-table*)) +(defmacro define-caller-pattern (name pattern &optional caller-type) + "Defines NAME as a function/macro call with argument structure + described by PATTERN. CALLER-TYPE, if specified, assigns a type to + the pattern, which may be used to exclude references to NAME while + viewing the database. For example, all the Common Lisp definitions + have a caller-type of :lisp or :lisp2, so that you can exclude + references to common lisp functions from the calling tree." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)) + (when ',pattern + (setf (gethash ',name *caller-pattern-table*) + ',pattern)))) + +;;; For defining variables +(defmacro define-variable-pattern (name &optional caller-type) + "Defines NAME as a variable reference of type CALLER-TYPE. This is + mainly used to establish the caller-type of the variable." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)))) + +;;; For defining synonyms. Means much less space taken up by the patterns. +(defmacro define-caller-pattern-synonyms (source destinations) + "For defining function caller pattern syntax synonyms. For each name + in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE. + Allows a large number of identical patterns to be defined simultaneously. + Must occur after the SOURCE has been defined." + `(let ((source-type (pattern-caller-type ',source)) + (source-pattern (gethash ',source *caller-pattern-table*))) + (when source-type + (dolist (dest ',destinations) + (setf (pattern-caller-type dest) source-type))) + (when source-pattern + (dolist (dest ',destinations) + (setf (gethash dest *caller-pattern-table*) + source-pattern))))) + +(defun clear-patterns () + (clrhash *pattern-substitution-table*) + (clrhash *caller-pattern-table*) + (clrhash *pattern-caller-type*)) + +;;; ******************************** +;;; Cross Reference Files ********** +;;; ******************************** +(defvar *last-form* () + "The last form read from the file. Useful for figuring out what went wrong + when xref-file drops into the debugger.") + +(defvar *xref-verbose* t + "When T, xref-file(s) prints out the names of the files it looks at, + progress dots, and the number of forms read.") + +;;; This needs to first clear the tables? +(defun xref-files (&rest files) + "Grovels over the lisp code located in source file FILES, using xref-file." + ;; If the arg is a list, use it. + (when (listp (car files)) (setq files (car files))) + (dolist (file files) + (xref-file file nil)) + (values)) + +(defvar *handle-package-forms* nil ;'(lisp::in-package) + "When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE, + sets the current package to the specified package by evaluating the + form. When done with the file, xref-file resets the package to its + original value. In some of the displaying functions, when this variable + is non-NIL one may specify that all symbols from a particular set of + packages be ignored. This is only useful if the files use different + packages with conflicting names.") + +(defvar *normal-readtable* (copy-readtable nil) + "Normal, unadulterated CL readtable.") + +(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*)) + "Cross references the function and variable calls in FILENAME by + walking over the source code located in the file. Defaults type of + filename to \".lisp\". Chomps on the code using record-callers and + record-callers*. If CLEAR-TABLES is T (the default), it clears the callers + database before processing the file. Specify CLEAR-TABLES as nil to + append to the database. If VERBOSE is T (the default), prints out the + name of the file, one progress dot for each form processed, and the + total number of forms." + ;; Default type to "lisp" + (when (and (null (pathname-type filename)) + (not (probe-file filename))) + (cond ((stringp filename) + (setf filename (concatenate 'string filename ".lisp"))) + ((pathnamep filename) + (setf filename (merge-pathnames filename + (make-pathname :type "lisp")))))) + (when clear-tables (clear-tables)) + (let ((count 0) + (old-package *package*) + (*readtable* *normal-readtable*)) + (when verbose + (format t "~&Cross-referencing file ~A.~&" filename)) + (with-open-file (stream filename :direction :input) + (do ((form (read stream nil :eof) (read stream nil :eof))) + ((eq form :eof)) + (incf count) + (when verbose + (format *standard-output* ".") + (force-output *standard-output*)) + (setq *last-form* form) + (record-callers filename form) + ;; Package Magic. + (when (and *handle-package-forms* + (consp form) + (member (car form) *handle-package-forms*)) + (eval form)))) + (when verbose + (format t "~&~D forms processed." count)) + (setq *package* old-package) + (values))) + +(defvar *handle-function-forms* t + "When T, XREF-FILE tries to be smart about forms which occur in + a function position, such as lambdas and arbitrary Lisp forms. + If so, it recursively calls record-callers with pattern 'FORM. + If the form is a lambda, makes the caller a caller of :unnamed-lambda.") + +(defvar *handle-macro-forms* t + "When T, if the file was loaded before being processed by XREF, and the + car of a form is a macro, it notes that the parent calls the macro, + and then calls macroexpand-1 on the form.") + +(defvar *callees-database-includes-variables* nil) + +(defun record-callers (filename form + &optional pattern parent (environment nil) + funcall) + "RECORD-CALLERS is the main routine used to walk down the code. It matches + the PATTERN against the FORM, possibly adding statements to the database. + PARENT is the name defined by the current outermost definition; it is + the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used + to keep track of the scoping of variables. FUNCALL deals with the type + of variable assignment and hence how the environment should be modified. + RECORD-CALLERS handles atomic patterns and simple list-structure patterns. + For complex list-structure pattern destructuring, it calls RECORD-CALLERS*." +; (when form) + (unless pattern (setq pattern 'FORM)) + (cond ((symbolp pattern) + (case pattern + (:IGNORE + ;; Ignores the rest of the form. + (values t parent environment)) + (NAME + ;; This is the name of a new definition. + (push filename (source-file form)) + (values t form environment)) + ((FUNCTION MACRO) + ;; This is the name of a call. + (cond ((and *handle-function-forms* (consp form)) + ;; If we're a cons and special handling is on, + (when (eq (car form) 'lambda) + (pushnew filename (callers-list :unnamed-lambda :file)) + (when parent + (pushnew parent (callers-list :unnamed-lambda + :callers)) + (pushnew :unnamed-lambda (callers-list parent + :callees)))) + (record-callers filename form 'form parent environment)) + (t + ;; If we're just a regular function name call. + (pushnew filename (callers-list form :file)) + (when parent + (pushnew parent (callers-list form :callers)) + (pushnew form (callers-list parent :callees))) + (values t parent environment)))) + (VAR + ;; This is the name of a new variable definition. + ;; Includes arglist parameters. + (when (and (symbolp form) (not (keywordp form)) + (not (member form lambda-list-keywords))) + (pushnew form (car environment)) + (pushnew filename (callers-list form :file)) + (when parent +; (pushnew form (callers-list parent :callees)) + (pushnew parent (callers-list form :setters))) + (values t parent environment))) + (VARIABLE + ;; VAR reference + (pushnew filename (callers-list form :file)) + (when (and parent (not (lookup form environment))) + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees)))) + (values t parent environment)) + (FORM + ;; A random form (var or funcall). + (cond ((consp form) + ;; Get new pattern from TAG. + (let ((new-pattern (lookup-caller-pattern (car form)))) + (pushnew filename (callers-list (car form) :file)) + (when parent + (pushnew parent (callers-list (car form) :callers)) + (pushnew (car form) (callers-list parent :callees))) + (cond ((and new-pattern (cdr form)) + ;; Special Pattern and there's stuff left + ;; to be processed. Note that we check if + ;; a pattern is defined for the form before + ;; we check to see if we can macroexpand it. + (record-callers filename (cdr form) new-pattern + parent environment :funcall)) + ((and *handle-macro-forms* + (symbolp (car form)) ; pnorvig 9/9/93 + (macro-function (car form))) + ;; The car of the form is a macro and + ;; macro processing is turned on. Macroexpand-1 + ;; the form and try again. + (record-callers filename + (macroexpand-1 form) + 'form parent environment + :funcall)) + ((null (cdr form)) + ;; No more left to be processed. Note that + ;; this must occur after the macros clause, + ;; since macros can expand into more code. + (values t parent environment)) + (t + ;; Random Form. We assume it is a function call. + (record-callers filename (cdr form) + '((:star FORM)) + parent environment :funcall))))) + (t + (when (and (not (lookup form environment)) + (not (numberp form)) + ;; the following line should probably be + ;; commented out? + (not (keywordp form)) + (not (stringp form)) + (not (eq form t)) + (not (eq form nil))) + (pushnew filename (callers-list form :file)) + ;; ??? :callers + (when parent + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees))))) + (values t parent environment)))) + (otherwise + ;; Pattern Substitution + (let ((new-pattern (lookup-pattern-substitution pattern))) + (if new-pattern + (record-callers filename form new-pattern + parent environment) + (when (eq pattern form) + (values t parent environment))))))) + ((consp pattern) + (case (car pattern) + (:eq (when (eq (second pattern) form) + (values t parent environment))) + (:test (when (funcall (eval (second pattern)) form) + (values t parent environment))) + (:typep (when (typep form (second pattern)) + (values t parent environment))) + (:or (dolist (subpat (rest pattern)) + (multiple-value-bind (processed parent environment) + (record-callers filename form subpat + parent environment) + (when processed + (return (values processed parent environment)))))) + (:rest ; (:star :plus :optional :rest) + (record-callers filename form (second pattern) + parent environment)) + (otherwise + (multiple-value-bind (d p env) + (record-callers* filename form pattern + parent (cons nil environment)) + (values d p (if funcall environment env)))))))) + +(defun record-callers* (filename form pattern parent environment + &optional continuation + in-optionals in-keywords) + "RECORD-CALLERS* handles complex list-structure patterns, such as + ordered lists of subpatterns, patterns involving :star, :plus, + &optional, &key, &rest, and so on. CONTINUATION is a stack of + unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding + stacks which determine whether &rest or &key has been seen yet in + the current pattern." + ;; form must be a cons or nil. +; (when form) + (if (null pattern) + (if (null continuation) + (values t parent environment) + (record-callers* filename form (car continuation) parent environment + (cdr continuation) + (cdr in-optionals) + (cdr in-keywords))) + (let ((pattern-elt (car pattern))) + (cond ((car-eq pattern-elt :optional) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cdr pattern) continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :star) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons pattern continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :plus) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cons (cons :star (cdr pattern-elt)) + (cdr pattern)) + continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords))) + ((car-eq pattern-elt :rest) + (record-callers filename form pattern-elt parent environment)) + ((eq pattern-elt '&optional) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons t in-optionals) + (cons (car in-keywords) in-keywords))) + ((eq pattern-elt '&rest) + (record-callers filename form (second pattern) + parent environment)) + ((eq pattern-elt '&key) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons (car in-optionals) in-optionals) + (cons t in-keywords))) + ((null form) + (when (or (car in-keywords) (car in-optionals)) + (values t parent environment))) + ((consp form) + (multiple-value-bind (processed parent environment) + (record-callers filename (if (car in-keywords) + (cadr form) + (car form)) + pattern-elt + parent environment) + (cond (processed + (record-callers* filename (if (car in-keywords) + (cddr form) + (cdr form)) + (cdr pattern) + parent environment + continuation + in-optionals in-keywords)) + ((or (car in-keywords) + (car in-optionals)) + (values t parent environment))))))))) + + +;;; ******************************** +;;; Misc Utilities ***************** +;;; ******************************** +(defvar *types-to-ignore* + '(:lisp ; CLtL 1st Edition + :lisp2 ; CLtL 2nd Edition additional patterns + ) + "Default set of caller types (as specified in the patterns) to ignore + in the database handling functions. :lisp is CLtL 1st edition, + :lisp2 is additional patterns from CLtL 2nd edition.") + +(defun display-database (&optional (database :callers) + (types-to-ignore *types-to-ignore*)) + "Prints out the name of each symbol and all its callers. Specify database + :callers (the default) to get function call references, :fill to the get + files in which the symbol is called, :readers to get variable references, + and :setters to get variable binding and assignments. Ignores functions + of types listed in types-to-ignore." + (maphash #'(lambda (name callers) + (unless (or (member (pattern-caller-type name) + types-to-ignore) + ;; When we're doing fancy package crap, + ;; allow us to ignore symbols based on their + ;; packages. + (when *handle-package-forms* + (member (symbol-package name) + types-to-ignore + :key #'find-package))) + (format t "~&~S is referenced by~{ ~S~}." + name callers))) + (ecase database + (:file *file-callers-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*)))) + +(defun write-callers-database-to-file (filename) + "Saves the contents of the current callers database to a file. This + file can be loaded to restore the previous contents of the + database. (For large systems it can take a long time to crunch + through the code, so this can save some time.)" + (with-open-file (stream filename :direction :output) + (format stream "~&(clear-tables)") + (maphash #'(lambda (x y) + (format stream "~&(setf (source-file '~S) '~S)" + x y)) + *source-file*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :file) '~S)" + x y)) + *file-callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callers) '~S)" + x y)) + *callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callees) '~S)" + x y)) + *callees-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :readers) '~S)" + x y)) + *readers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :setters) '~S)" + x y)) + *setters-database*))) + + +;;; ******************************** +;;; Print Caller Trees ************* +;;; ******************************** +;;; The following function is useful for reversing a caller table into +;;; a callee table. Possibly later we'll extend xref to create two +;;; such database hash tables. Needs to include vars as well. +(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*)) + "Makes a copy of the hash table in which (name value*) pairs + are inverted to (value name*) pairs." + (let ((target (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (dolist (value values) + (unless (member (pattern-caller-type key) + types-to-ignore) + (pushnew key (gethash value target))))) + table) + target)) + +;;; Resolve file references for automatic creation of a defsystem file. +(defun determine-file-dependencies (&optional (database *callers-database*)) + "Makes a hash table of file dependencies for the references listed in + DATABASE. This function may be useful for automatically resolving + file references for automatic creation of a system definition (defsystem)." + (let ((file-ref-ht (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (let ((key-file (source-file key))) + (when key + (dolist (value values) + (let ((value-file (source-file value))) + (when value-file + (dolist (s key-file) + (dolist (d value-file) + (pushnew d (gethash s file-ref-ht)))))))))) + database) + file-ref-ht)) + +(defun print-file-dependencies (&optional (database *callers-database*)) + "Prints a list of file dependencies for the references listed in DATABASE. + This function may be useful for automatically computing file loading + constraints for a system definition tool." + (maphash #'(lambda (key value) (format t "~&~S --> ~S" key value)) + (determine-file-dependencies database))) + +;;; The following functions demonstrate a possible way to interface +;;; xref to a graphical browser such as psgraph to mimic the capabilities +;;; of Masterscope's graphical browser. + +(defvar *last-caller-tree* nil) + +(defvar *default-graphing-mode* :call-graph + "Specifies whether we graph up or down. If :call-graph, the children + of a node are the functions it calls. If :caller-graph, the children + of a node are the functions that call it.") + +(defun gather-tree (parents &optional already-seen + (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Extends the tree, copying it into list structure, until it repeats + a reference (hits a cycle)." + (let ((*already-seen* nil) + (database (case mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (declare (special *already-seen*)) + (labels + ((amass-tree + (parents &optional already-seen) + (let (result this-item) + (dolist (parent parents) + (unless (member (pattern-caller-type parent) + types-to-ignore) + (pushnew parent *already-seen*) + (if (member parent already-seen) + (setq this-item nil) ; :ignore + (if compact + (multiple-value-setq (this-item already-seen) + (amass-tree (gethash parent database) + (cons parent already-seen))) + (setq this-item + (amass-tree (gethash parent database) + (cons parent already-seen))))) + (setq parent (format nil "~S" parent)) + (when (consp parent) (setq parent (cons :xref-list parent))) + (unless (eq this-item :ignore) + (push (if this-item + (list parent this-item) + parent) + result)))) + (values result ;(reverse result) + already-seen)))) + (values (amass-tree parents already-seen) + *already-seen*)))) + +(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*)) + "Returns a list of uncalled callers (roots) and called callers (potential + cycles)." + (let ((uncalled-callers nil) + (called-callers nil) + (database (ecase mode + (:call-graph *callers-database*) + (:caller-graph *callees-database*))) + (other-database (ecase mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (maphash #'(lambda (name value) + (declare (ignore value)) + (unless (member (pattern-caller-type name) + types-to-ignore) + (if (gethash name database) + (push name called-callers) + (push name uncalled-callers)))) + other-database) + (values uncalled-callers called-callers))) + +(defun make-caller-tree (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Outputs list structure of a tree which roughly represents the possibly + cyclical structure of the caller database. + If mode is :call-graph, the children of a node are the functions it calls. + If mode is :caller-graph, the children of a node are the functions that + call it. + If compact is T, tries to eliminate the already-seen nodes, so that + the graph for a node is printed at most once. Otherwise it will duplicate + the node's tree (except for cycles). This is usefull because the call tree + is actually a directed graph, so we can either duplicate references or + display only the first one." + ;; Would be nice to print out line numbers and whenever we skip a duplicated + ;; reference, print the line number of the full reference after the node. + (multiple-value-bind (uncalled-callers called-callers) + (find-roots-and-cycles mode types-to-ignore) + (multiple-value-bind (trees already-seen) + (gather-tree uncalled-callers nil mode types-to-ignore compact) + (setq *last-caller-tree* trees) + (let ((more-trees (gather-tree (set-difference called-callers + already-seen) + already-seen + mode types-to-ignore compact))) + (values trees more-trees))))) + +(defvar *indent-amount* 3 + "Number of spaces to indent successive levels in PRINT-INDENTED-TREE.") + +(defun print-indented-tree (trees &optional (indent 0)) + "Simple code to print out a list-structure tree (such as those created + by make-caller-tree) as indented text." + (when trees + (dolist (tree trees) + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (format t "~&~VT~A" indent (cdr tree))) + ((listp tree) + (format t "~&~VT~A" indent (car tree)) + (print-indented-tree (cadr tree) (+ indent *indent-amount*))) + (t + (format t "~&~VT~A" indent tree)))))) + +(defun print-caller-trees (&key (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) + compact + root-nodes) + "Prints the calling trees (which may actually be a full graph and not + necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE. + MODE is :call-graph for trees where the children of a node are the + functions called by the node, or :caller-graph for trees where the + children of a node are the functions the node calls. TYPES-TO-IGNORE + is a list of funcall types (as specified in the patterns) to ignore + in printing out the database. For example, '(:lisp) would ignore all + calls to common lisp functions. COMPACT is a flag to tell the program + to try to compact the trees a bit by not printing trees if they have + already been seen. ROOT-NODES is a list of root nodes of trees to + display. If ROOT-NODES is nil, tries to find all root nodes in the + database." + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (when rooted + (format t "~&Rooted calling trees:") + (print-indented-tree rooted 2)) + (when cycles + (when rooted + (format t "~2%")) + (format t "~&Cyclic calling trees:") + (print-indented-tree cycles 2)))) + + +;;; ******************************** +;;; Interface to PSGraph *********** +;;; ******************************** +#| +;;; Interface to Bates' PostScript Graphing Utility +(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph") + +(defparameter *postscript-output-directory* "") +(defun psgraph-xref (&key (mode *default-graphing-mode*) + (output-directory *postscript-output-directory*) + (types-to-ignore *types-to-ignore*) + (compact t) + (shrink t) + root-nodes + insert) + ;; If root-nodes is a non-nil list, uses that list as the starting + ;; position. Otherwise tries to find all roots in the database. + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (psgraph-output (append rooted cycles) output-directory shrink insert))) + +(defun psgraph-output (list-of-trees directory shrink &optional insert) + (let ((psgraph:*fontsize* 9) + (psgraph:*second-fontsize* 7) +; (psgraph:*boxkind* "fill") + (psgraph:*boxgray* "0") ; .8 + (psgraph:*edgewidth* "1") + (psgraph:*edgegray* "0")) + (labels ((stringify (thing) + (cond ((stringp thing) (string-downcase thing)) + ((symbolp thing) (string-downcase (symbol-name thing))) + ((and (listp thing) (eq (car thing) :xref-list)) + (stringify (cdr thing))) + ((listp thing) (stringify (car thing))) + (t (string thing))))) + (dolist (item list-of-trees) + (let* ((fname (stringify item)) + (filename (concatenate 'string directory + (string-trim '(#\: #\|) fname) + ".ps"))) + (format t "~&Creating PostScript file ~S." filename) + (with-open-file (*standard-output* filename + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + ;; Note that the #'eq prints the DAG as a tree. If + ;; you replace it with #'equal, it will print it as + ;; a DAG, which I think is slightly ugly. + (psgraph:psgraph item + #'caller-tree-children #'caller-info shrink + insert #'eq))))))) + +(defun caller-tree-children (tree) + (when (and tree (listp tree) (not (eq (car tree) :xref-list))) + (cadr tree))) + +(defun caller-tree-node (tree) + (when tree + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (cdr tree)) + ((listp tree) + (car tree)) + (t + tree)))) + +(defun caller-info (tree) + (let ((node (caller-tree-node tree))) + (list node))) +|# +#| +;;; Code to print out graphical trees of CLOS class hierarchies. +(defun print-class-hierarchy (&optional (start-class 'anything) + (file "classes.ps")) + (let ((start (find-class start-class))) + (when start + (with-open-file (*standard-output* file :direction :output) + (psgraph:psgraph start + #'clos::class-direct-subclasses + #'(lambda (x) + (list (format nil "~A" (clos::class-name x)))) + t nil #'eq))))) + +|# + + +;;; **************************************************************** +;;; Cross Referencing Patterns for Common Lisp ********************* +;;; **************************************************************** +(clear-patterns) + +;;; ******************************** +;;; Pattern Substitutions ********** +;;; ******************************** +(define-pattern-substitution integer (:test #'integerp)) +(define-pattern-substitution rational (:test #'rationalp)) +(define-pattern-substitution symbol (:test #'symbolp)) +(define-pattern-substitution string (:test #'stringp)) +(define-pattern-substitution number (:test #'numberp)) +(define-pattern-substitution lambda-list + ((:star var) + (:optional (:eq &optional) + (:star (:or var + (var (:optional form (:optional var)))))) + (:optional (:eq &rest) var) + (:optional (:eq &key) (:star (:or var + ((:or var + (keyword var)) + (:optional form (:optional var))))) + (:optional &allow-other-keys)) + (:optional (:eq &aux) + (:star (:or var + (var (:optional form))))))) +(define-pattern-substitution test form) +(define-pattern-substitution body + ((:star (:or declaration documentation-string)) + (:star form))) +(define-pattern-substitution documentation-string string) +(define-pattern-substitution initial-value form) +(define-pattern-substitution tag symbol) +(define-pattern-substitution declaration ((:eq declare)(:rest :ignore))) +(define-pattern-substitution destination form) +(define-pattern-substitution control-string string) +(define-pattern-substitution format-arguments + ((:star form))) +(define-pattern-substitution fn + (:or ((:eq quote) function) + ((:eq function) function) + function)) + +;;; ******************************** +;;; Caller Patterns **************** +;;; ******************************** + +;;; Types Related +(define-caller-pattern coerce (form :ignore) :lisp) +(define-caller-pattern type-of (form) :lisp) +(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2) +(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2) + +;;; Lambdas and Definitions +(define-variable-pattern lambda-list-keywords :lisp) +(define-variable-pattern lambda-parameters-limit :lisp) +(define-caller-pattern lambda (lambda-list (:rest body)) :lisp) + +(define-caller-pattern defun + (name lambda-list + (:star (:or documentation-string declaration)) + (:star form)) + :lisp) + +;;; perhaps this should use VAR, instead of NAME +(define-caller-pattern defvar + (var (:optional initial-value (:optional documentation-string))) + :lisp) +(define-caller-pattern defparameter + (var initial-value (:optional documentation-string)) + :lisp) +(define-caller-pattern defconstant + (var initial-value (:optional documentation-string)) + :lisp) + +(define-caller-pattern eval-when + (:ignore ; the situations + (:star form)) + :lisp) + +;;; Logical Values +(define-variable-pattern nil :lisp) +(define-variable-pattern t :lisp) + +;;; Predicates +(define-caller-pattern typep (form form) :lisp) +(define-caller-pattern subtypep (form form) :lisp) + +(define-caller-pattern null (form) :lisp) +(define-caller-pattern symbolp (form) :lisp) +(define-caller-pattern atom (form) :lisp) +(define-caller-pattern consp (form) :lisp) +(define-caller-pattern listp (form) :lisp) +(define-caller-pattern numberp (form) :lisp) +(define-caller-pattern integerp (form) :lisp) +(define-caller-pattern rationalp (form) :lisp) +(define-caller-pattern floatp (form) :lisp) +(define-caller-pattern realp (form) :lisp2) +(define-caller-pattern complexp (form) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern stringp (form) :lisp) +(define-caller-pattern bit-vector-p (form) :lisp) +(define-caller-pattern vectorp (form) :lisp) +(define-caller-pattern simple-vector-p (form) :lisp) +(define-caller-pattern simple-string-p (form) :lisp) +(define-caller-pattern simple-bit-vector-p (form) :lisp) +(define-caller-pattern arrayp (form) :lisp) +(define-caller-pattern packagep (form) :lisp) +(define-caller-pattern functionp (form) :lisp) +(define-caller-pattern compiled-function-p (form) :lisp) +(define-caller-pattern commonp (form) :lisp) + +;;; Equality Predicates +(define-caller-pattern eq (form form) :lisp) +(define-caller-pattern eql (form form) :lisp) +(define-caller-pattern equal (form form) :lisp) +(define-caller-pattern equalp (form form) :lisp) + +;;; Logical Operators +(define-caller-pattern not (form) :lisp) +(define-caller-pattern or ((:star form)) :lisp) +(define-caller-pattern and ((:star form)) :lisp) + +;;; Reference + +;;; Quote is a problem. In Defmacro & friends, we'd like to actually +;;; look at the argument, 'cause it hides internal function calls +;;; of the defmacro. +(define-caller-pattern quote (:ignore) :lisp) + +(define-caller-pattern function ((:or fn form)) :lisp) +(define-caller-pattern symbol-value (form) :lisp) +(define-caller-pattern symbol-function (form) :lisp) +(define-caller-pattern fdefinition (form) :lisp2) +(define-caller-pattern boundp (form) :lisp) +(define-caller-pattern fboundp (form) :lisp) +(define-caller-pattern special-form-p (form) :lisp) + +;;; Assignment +(define-caller-pattern setq ((:star var form)) :lisp) +(define-caller-pattern psetq ((:star var form)) :lisp) +(define-caller-pattern set (form form) :lisp) +(define-caller-pattern makunbound (form) :lisp) +(define-caller-pattern fmakunbound (form) :lisp) + +;;; Generalized Variables +(define-caller-pattern setf ((:star form form)) :lisp) +(define-caller-pattern psetf ((:star form form)) :lisp) +(define-caller-pattern shiftf ((:plus form) form) :lisp) +(define-caller-pattern rotatef ((:star form)) :lisp) +(define-caller-pattern define-modify-macro + (name + lambda-list + fn + (:optional documentation-string)) + :lisp) +(define-caller-pattern defsetf + (:or (name name (:optional documentation-string)) + (name lambda-list (var) + (:star (:or declaration documentation-string)) + (:star form))) + :lisp) +(define-caller-pattern define-setf-method + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern get-setf-method (form) :lisp) +(define-caller-pattern get-setf-method-multiple-value (form) :lisp) + + +;;; Function invocation +(define-caller-pattern apply (fn form (:star form)) :lisp) +(define-caller-pattern funcall (fn (:star form)) :lisp) + + +;;; Simple sequencing +(define-caller-pattern progn ((:star form)) :lisp) +(define-caller-pattern prog1 (form (:star form)) :lisp) +(define-caller-pattern prog2 (form form (:star form)) :lisp) + +;;; Variable bindings +(define-caller-pattern let + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern let* + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern compiler-let + (((:star (:or var (var form)))) + (:star form)) + :lisp) +(define-caller-pattern progv + (form form (:star form)) :lisp) +(define-caller-pattern flet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern labels + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern macrolet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern symbol-macrolet + (((:star (var form))) (:star declaration) (:star form)) + :lisp2) + +;;; Conditionals +(define-caller-pattern if (test form (:optional form)) :lisp) +(define-caller-pattern when (test (:star form)) :lisp) +(define-caller-pattern unless (test (:star form)) :lisp) +(define-caller-pattern cond ((:star (test (:star form)))) :lisp) +(define-caller-pattern case + (form + (:star ((:or symbol + ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern typecase (form (:star (symbol (:star form)))) + :lisp) + +;;; Blocks and Exits +(define-caller-pattern block (name (:star form)) :lisp) +(define-caller-pattern return-from (function (:optional form)) :lisp) +(define-caller-pattern return ((:optional form)) :lisp) + +;;; Iteration +(define-caller-pattern loop ((:star form)) :lisp) +(define-caller-pattern do + (((:star (:or var + (var (:optional form (:optional form)))))) ; init step + (form (:star form)) ; end-test result + (:star declaration) + (:star (:or tag form))) ; statement + :lisp) +(define-caller-pattern do* + (((:star (:or var + (var (:optional form (:optional form)))))) + (form (:star form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dolist + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dotimes + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) + +;;; Mapping +(define-caller-pattern mapcar (fn form (:star form)) :lisp) +(define-caller-pattern maplist (fn form (:star form)) :lisp) +(define-caller-pattern mapc (fn form (:star form)) :lisp) +(define-caller-pattern mapl (fn form (:star form)) :lisp) +(define-caller-pattern mapcan (fn form (:star form)) :lisp) +(define-caller-pattern mapcon (fn form (:star form)) :lisp) + +;;; The "Program Feature" +(define-caller-pattern tagbody ((:star (:or tag form))) :lisp) +(define-caller-pattern prog + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern prog* + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern go (tag) :lisp) + +;;; Multiple Values +(define-caller-pattern values ((:star form)) :lisp) +(define-variable-pattern multiple-values-limit :lisp) +(define-caller-pattern values-list (form) :lisp) +(define-caller-pattern multiple-value-list (form) :lisp) +(define-caller-pattern multiple-value-call (fn (:star form)) :lisp) +(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp) +(define-caller-pattern multiple-value-bind + (((:star var)) form + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp) +(define-caller-pattern nth-value (form form) :lisp2) + +;;; Dynamic Non-Local Exits +(define-caller-pattern catch (tag (:star form)) :lisp) +(define-caller-pattern throw (tag form) :lisp) +(define-caller-pattern unwind-protect (form (:star form)) :lisp) + +;;; Macros +(define-caller-pattern macro-function (form) :lisp) +(define-caller-pattern defmacro + (name + lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp) +(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp) +(define-variable-pattern *macroexpand-hook* :lisp) + +;;; Destructuring +(define-caller-pattern destructuring-bind + (lambda-list form + (:star declaration) + (:star form)) + :lisp2) + +;;; Compiler Macros +(define-caller-pattern define-compiler-macro + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern compiler-macro-function (form) :lisp2) +(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2) +(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore)) + :lisp2) + +;;; Environments +(define-caller-pattern variable-information (form &optional :ignore) + :lisp2) +(define-caller-pattern function-information (fn &optional :ignore) :lisp2) +(define-caller-pattern declaration-information (form &optional :ignore) :lisp2) +(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2) +(define-caller-pattern define-declaration + (name + lambda-list + (:star form)) + :lisp2) +(define-caller-pattern parse-macro (name lambda-list form) :lisp2) +(define-caller-pattern enclose (form &optional :ignore) :lisp2) + + +;;; Declarations +(define-caller-pattern declare ((:rest :ignore)) :lisp) +(define-caller-pattern proclaim ((:rest :ignore)) :lisp) +(define-caller-pattern locally ((:star declaration) (:star form)) :lisp) +(define-caller-pattern declaim ((:rest :ignore)) :lisp2) +(define-caller-pattern the (form form) :lisp) + +;;; Symbols +(define-caller-pattern get (form form (:optional form)) :lisp) +(define-caller-pattern remprop (form form) :lisp) +(define-caller-pattern symbol-plist (form) :lisp) +(define-caller-pattern getf (form form (:optional form)) :lisp) +(define-caller-pattern remf (form form) :lisp) +(define-caller-pattern get-properties (form form) :lisp) + +(define-caller-pattern symbol-name (form) :lisp) +(define-caller-pattern make-symbol (form) :lisp) +(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp) +(define-caller-pattern gensym ((:optional :ignore)) :lisp) +(define-variable-pattern *gensym-counter* :lisp2) +(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp) +(define-caller-pattern symbol-package (form) :lisp) +(define-caller-pattern keywordp (form) :lisp) + +;;; Packages +(define-variable-pattern *package* :lisp) +(define-caller-pattern make-package ((:rest :ignore)) :lisp) +(define-caller-pattern in-package ((:rest :ignore)) :lisp) +(define-caller-pattern find-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-name ((:rest :ignore)) :lisp) +(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp) +(define-caller-pattern rename-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-use-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp) +(define-caller-pattern list-all-packages () :lisp) +(define-caller-pattern delete-package ((:rest :ignore)) :lisp2) +(define-caller-pattern intern (form &optional :ignore) :lisp) +(define-caller-pattern find-symbol (form &optional :ignore) :lisp) +(define-caller-pattern unintern (form &optional :ignore) :lisp) + +(define-caller-pattern export ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern unexport ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadowing-import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadow ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) + +(define-caller-pattern use-package ((:rest :ignore)) :lisp) +(define-caller-pattern unuse-package ((:rest :ignore)) :lisp) +(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2) +(define-caller-pattern find-all-symbols (form) :lisp) +(define-caller-pattern do-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-external-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-all-symbols + ((var (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern with-package-iterator + ((name form (:plus :ignore)) + (:star form)) + :lisp2) + +;;; Modules +(define-variable-pattern *modules* :lisp) +(define-caller-pattern provide (form) :lisp) +(define-caller-pattern require (form &optional :ignore) :lisp) + + +;;; Numbers +(define-caller-pattern zerop (form) :lisp) +(define-caller-pattern plusp (form) :lisp) +(define-caller-pattern minusp (form) :lisp) +(define-caller-pattern oddp (form) :lisp) +(define-caller-pattern evenp (form) :lisp) + +(define-caller-pattern = (form (:star form)) :lisp) +(define-caller-pattern /= (form (:star form)) :lisp) +(define-caller-pattern > (form (:star form)) :lisp) +(define-caller-pattern < (form (:star form)) :lisp) +(define-caller-pattern <= (form (:star form)) :lisp) +(define-caller-pattern >= (form (:star form)) :lisp) + +(define-caller-pattern max (form (:star form)) :lisp) +(define-caller-pattern min (form (:star form)) :lisp) + +(define-caller-pattern - (form (:star form)) :lisp) +(define-caller-pattern + (form (:star form)) :lisp) +(define-caller-pattern * (form (:star form)) :lisp) +(define-caller-pattern / (form (:star form)) :lisp) +(define-caller-pattern 1+ (form) :lisp) +(define-caller-pattern 1- (form) :lisp) + +(define-caller-pattern incf (form form) :lisp) +(define-caller-pattern decf (form form) :lisp) + +(define-caller-pattern conjugate (form) :lisp) + +(define-caller-pattern gcd ((:star form)) :lisp) +(define-caller-pattern lcm ((:star form)) :lisp) + +(define-caller-pattern exp (form) :lisp) +(define-caller-pattern expt (form form) :lisp) +(define-caller-pattern log (form (:optional form)) :lisp) +(define-caller-pattern sqrt (form) :lisp) +(define-caller-pattern isqrt (form) :lisp) + +(define-caller-pattern abs (form) :lisp) +(define-caller-pattern phase (form) :lisp) +(define-caller-pattern signum (form) :lisp) +(define-caller-pattern sin (form) :lisp) +(define-caller-pattern cos (form) :lisp) +(define-caller-pattern tan (form) :lisp) +(define-caller-pattern cis (form) :lisp) +(define-caller-pattern asin (form) :lisp) +(define-caller-pattern acos (form) :lisp) +(define-caller-pattern atan (form &optional form) :lisp) +(define-variable-pattern pi :lisp) + +(define-caller-pattern sinh (form) :lisp) +(define-caller-pattern cosh (form) :lisp) +(define-caller-pattern tanh (form) :lisp) +(define-caller-pattern asinh (form) :lisp) +(define-caller-pattern acosh (form) :lisp) +(define-caller-pattern atanh (form) :lisp) + +;;; Type Conversions and Extractions +(define-caller-pattern float (form (:optional form)) :lisp) +(define-caller-pattern rational (form) :lisp) +(define-caller-pattern rationalize (form) :lisp) +(define-caller-pattern numerator (form) :lisp) +(define-caller-pattern denominator (form) :lisp) + +(define-caller-pattern floor (form (:optional form)) :lisp) +(define-caller-pattern ceiling (form (:optional form)) :lisp) +(define-caller-pattern truncate (form (:optional form)) :lisp) +(define-caller-pattern round (form (:optional form)) :lisp) + +(define-caller-pattern mod (form form) :lisp) +(define-caller-pattern rem (form form) :lisp) + +(define-caller-pattern ffloor (form (:optional form)) :lisp) +(define-caller-pattern fceiling (form (:optional form)) :lisp) +(define-caller-pattern ftruncate (form (:optional form)) :lisp) +(define-caller-pattern fround (form (:optional form)) :lisp) + +(define-caller-pattern decode-float (form) :lisp) +(define-caller-pattern scale-float (form form) :lisp) +(define-caller-pattern float-radix (form) :lisp) +(define-caller-pattern float-sign (form (:optional form)) :lisp) +(define-caller-pattern float-digits (form) :lisp) +(define-caller-pattern float-precision (form) :lisp) +(define-caller-pattern integer-decode-float (form) :lisp) + +(define-caller-pattern complex (form (:optional form)) :lisp) +(define-caller-pattern realpart (form) :lisp) +(define-caller-pattern imagpart (form) :lisp) + +(define-caller-pattern logior ((:star form)) :lisp) +(define-caller-pattern logxor ((:star form)) :lisp) +(define-caller-pattern logand ((:star form)) :lisp) +(define-caller-pattern logeqv ((:star form)) :lisp) + +(define-caller-pattern lognand (form form) :lisp) +(define-caller-pattern lognor (form form) :lisp) +(define-caller-pattern logandc1 (form form) :lisp) +(define-caller-pattern logandc2 (form form) :lisp) +(define-caller-pattern logorc1 (form form) :lisp) +(define-caller-pattern logorc2 (form form) :lisp) + +(define-caller-pattern boole (form form form) :lisp) +(define-variable-pattern boole-clr :lisp) +(define-variable-pattern boole-set :lisp) +(define-variable-pattern boole-1 :lisp) +(define-variable-pattern boole-2 :lisp) +(define-variable-pattern boole-c1 :lisp) +(define-variable-pattern boole-c2 :lisp) +(define-variable-pattern boole-and :lisp) +(define-variable-pattern boole-ior :lisp) +(define-variable-pattern boole-xor :lisp) +(define-variable-pattern boole-eqv :lisp) +(define-variable-pattern boole-nand :lisp) +(define-variable-pattern boole-nor :lisp) +(define-variable-pattern boole-andc1 :lisp) +(define-variable-pattern boole-andc2 :lisp) +(define-variable-pattern boole-orc1 :lisp) +(define-variable-pattern boole-orc2 :lisp) + +(define-caller-pattern lognot (form) :lisp) +(define-caller-pattern logtest (form form) :lisp) +(define-caller-pattern logbitp (form form) :lisp) +(define-caller-pattern ash (form form) :lisp) +(define-caller-pattern logcount (form) :lisp) +(define-caller-pattern integer-length (form) :lisp) + +(define-caller-pattern byte (form form) :lisp) +(define-caller-pattern byte-size (form) :lisp) +(define-caller-pattern byte-position (form) :lisp) +(define-caller-pattern ldb (form form) :lisp) +(define-caller-pattern ldb-test (form form) :lisp) +(define-caller-pattern mask-field (form form) :lisp) +(define-caller-pattern dpb (form form form) :lisp) +(define-caller-pattern deposit-field (form form form) :lisp) + +;;; Random Numbers +(define-caller-pattern random (form (:optional form)) :lisp) +(define-variable-pattern *random-state* :lisp) +(define-caller-pattern make-random-state ((:optional form)) :lisp) +(define-caller-pattern random-state-p (form) :lisp) + +;;; Implementation Parameters +(define-variable-pattern most-positive-fixnum :lisp) +(define-variable-pattern most-negative-fixnum :lisp) +(define-variable-pattern most-positive-short-float :lisp) +(define-variable-pattern least-positive-short-float :lisp) +(define-variable-pattern least-negative-short-float :lisp) +(define-variable-pattern most-negative-short-float :lisp) +(define-variable-pattern most-positive-single-float :lisp) +(define-variable-pattern least-positive-single-float :lisp) +(define-variable-pattern least-negative-single-float :lisp) +(define-variable-pattern most-negative-single-float :lisp) +(define-variable-pattern most-positive-double-float :lisp) +(define-variable-pattern least-positive-double-float :lisp) +(define-variable-pattern least-negative-double-float :lisp) +(define-variable-pattern most-negative-double-float :lisp) +(define-variable-pattern most-positive-long-float :lisp) +(define-variable-pattern least-positive-long-float :lisp) +(define-variable-pattern least-negative-long-float :lisp) +(define-variable-pattern most-negative-long-float :lisp) +(define-variable-pattern least-positive-normalized-short-float :lisp2) +(define-variable-pattern least-negative-normalized-short-float :lisp2) +(define-variable-pattern least-positive-normalized-single-float :lisp2) +(define-variable-pattern least-negative-normalized-single-float :lisp2) +(define-variable-pattern least-positive-normalized-double-float :lisp2) +(define-variable-pattern least-negative-normalized-double-float :lisp2) +(define-variable-pattern least-positive-normalized-long-float :lisp2) +(define-variable-pattern least-negative-normalized-long-float :lisp2) +(define-variable-pattern short-float-epsilon :lisp) +(define-variable-pattern single-float-epsilon :lisp) +(define-variable-pattern double-float-epsilon :lisp) +(define-variable-pattern long-float-epsilon :lisp) +(define-variable-pattern short-float-negative-epsilon :lisp) +(define-variable-pattern single-float-negative-epsilon :lisp) +(define-variable-pattern double-float-negative-epsilon :lisp) +(define-variable-pattern long-float-negative-epsilon :lisp) + +;;; Characters +(define-variable-pattern char-code-limit :lisp) +(define-variable-pattern char-font-limit :lisp) +(define-variable-pattern char-bits-limit :lisp) +(define-caller-pattern standard-char-p (form) :lisp) +(define-caller-pattern graphic-char-p (form) :lisp) +(define-caller-pattern string-char-p (form) :lisp) +(define-caller-pattern alpha-char-p (form) :lisp) +(define-caller-pattern upper-case-p (form) :lisp) +(define-caller-pattern lower-case-p (form) :lisp) +(define-caller-pattern both-case-p (form) :lisp) +(define-caller-pattern digit-char-p (form (:optional form)) :lisp) +(define-caller-pattern alphanumericp (form) :lisp) + +(define-caller-pattern char= ((:star form)) :lisp) +(define-caller-pattern char/= ((:star form)) :lisp) +(define-caller-pattern char< ((:star form)) :lisp) +(define-caller-pattern char> ((:star form)) :lisp) +(define-caller-pattern char<= ((:star form)) :lisp) +(define-caller-pattern char>= ((:star form)) :lisp) + +(define-caller-pattern char-equal ((:star form)) :lisp) +(define-caller-pattern char-not-equal ((:star form)) :lisp) +(define-caller-pattern char-lessp ((:star form)) :lisp) +(define-caller-pattern char-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-lessp ((:star form)) :lisp) + +(define-caller-pattern char-code (form) :lisp) +(define-caller-pattern char-bits (form) :lisp) +(define-caller-pattern char-font (form) :lisp) +(define-caller-pattern code-char (form (:optional form form)) :lisp) +(define-caller-pattern make-char (form (:optional form form)) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern char-upcase (form) :lisp) +(define-caller-pattern char-downcase (form) :lisp) +(define-caller-pattern digit-char (form (:optional form form)) :lisp) +(define-caller-pattern char-int (form) :lisp) +(define-caller-pattern int-char (form) :lisp) +(define-caller-pattern char-name (form) :lisp) +(define-caller-pattern name-char (form) :lisp) +(define-variable-pattern char-control-bit :lisp) +(define-variable-pattern char-meta-bit :lisp) +(define-variable-pattern char-super-bit :lisp) +(define-variable-pattern char-hyper-bit :lisp) +(define-caller-pattern char-bit (form form) :lisp) +(define-caller-pattern set-char-bit (form form form) :lisp) + +;;; Sequences +(define-caller-pattern complement (fn) :lisp2) +(define-caller-pattern elt (form form) :lisp) +(define-caller-pattern subseq (form form &optional form) :lisp) +(define-caller-pattern copy-seq (form) :lisp) +(define-caller-pattern length (form) :lisp) +(define-caller-pattern reverse (form) :lisp) +(define-caller-pattern nreverse (form) :lisp) +(define-caller-pattern make-sequence (form form &key form) :lisp) + +(define-caller-pattern concatenate (form (:star form)) :lisp) +(define-caller-pattern map (form fn form (:star form)) :lisp) +(define-caller-pattern map-into (form fn (:star form)) :lisp2) + +(define-caller-pattern some (fn form (:star form)) :lisp) +(define-caller-pattern every (fn form (:star form)) :lisp) +(define-caller-pattern notany (fn form (:star form)) :lisp) +(define-caller-pattern notevery (fn form (:star form)) :lisp) + +(define-caller-pattern reduce (fn form &key (:star form)) :lisp) +(define-caller-pattern fill (form form &key (:star form)) :lisp) +(define-caller-pattern replace (form form &key (:star form)) :lisp) +(define-caller-pattern remove (form form &key (:star form)) :lisp) +(define-caller-pattern remove-if (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern delete (form form &key (:star form)) :lisp) +(define-caller-pattern delete-if (fn form &key (:star form)) :lisp) +(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern substitute (form form form &key (:star form)) :lisp) +(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern substitute-if-not (form fn form &key (:star form)) + :lisp) +(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form)) + :lisp) +(define-caller-pattern find (form form &key (:star form)) :lisp) +(define-caller-pattern find-if (fn form &key (:star form)) :lisp) +(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern position (form form &key (:star form)) :lisp) +(define-caller-pattern position-if (fn form &key (:star form)) :lisp) +(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern count (form form &key (:star form)) :lisp) +(define-caller-pattern count-if (fn form &key (:star form)) :lisp) +(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern mismatch (form form &key (:star form)) :lisp) +(define-caller-pattern search (form form &key (:star form)) :lisp) +(define-caller-pattern sort (form fn &key (:star form)) :lisp) +(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp) +(define-caller-pattern merge (form form form fn &key (:star form)) :lisp) + +;;; Lists +(define-caller-pattern car (form) :lisp) +(define-caller-pattern cdr (form) :lisp) +(define-caller-pattern caar (form) :lisp) +(define-caller-pattern cadr (form) :lisp) +(define-caller-pattern cdar (form) :lisp) +(define-caller-pattern cddr (form) :lisp) +(define-caller-pattern caaar (form) :lisp) +(define-caller-pattern caadr (form) :lisp) +(define-caller-pattern cadar (form) :lisp) +(define-caller-pattern caddr (form) :lisp) +(define-caller-pattern cdaar (form) :lisp) +(define-caller-pattern cdadr (form) :lisp) +(define-caller-pattern cddar (form) :lisp) +(define-caller-pattern cdddr (form) :lisp) +(define-caller-pattern caaaar (form) :lisp) +(define-caller-pattern caaadr (form) :lisp) +(define-caller-pattern caadar (form) :lisp) +(define-caller-pattern caaddr (form) :lisp) +(define-caller-pattern cadaar (form) :lisp) +(define-caller-pattern cadadr (form) :lisp) +(define-caller-pattern caddar (form) :lisp) +(define-caller-pattern cadddr (form) :lisp) +(define-caller-pattern cdaaar (form) :lisp) +(define-caller-pattern cdaadr (form) :lisp) +(define-caller-pattern cdadar (form) :lisp) +(define-caller-pattern cdaddr (form) :lisp) +(define-caller-pattern cddaar (form) :lisp) +(define-caller-pattern cddadr (form) :lisp) +(define-caller-pattern cdddar (form) :lisp) +(define-caller-pattern cddddr (form) :lisp) + +(define-caller-pattern cons (form form) :lisp) +(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp) +(define-caller-pattern endp (form) :lisp) +(define-caller-pattern list-length (form) :lisp) +(define-caller-pattern nth (form form) :lisp) + +(define-caller-pattern first (form) :lisp) +(define-caller-pattern second (form) :lisp) +(define-caller-pattern third (form) :lisp) +(define-caller-pattern fourth (form) :lisp) +(define-caller-pattern fifth (form) :lisp) +(define-caller-pattern sixth (form) :lisp) +(define-caller-pattern seventh (form) :lisp) +(define-caller-pattern eighth (form) :lisp) +(define-caller-pattern ninth (form) :lisp) +(define-caller-pattern tenth (form) :lisp) + +(define-caller-pattern rest (form) :lisp) +(define-caller-pattern nthcdr (form form) :lisp) +(define-caller-pattern last (form (:optional form)) :lisp) +(define-caller-pattern list ((:star form)) :lisp) +(define-caller-pattern list* ((:star form)) :lisp) +(define-caller-pattern make-list (form &key (:star form)) :lisp) +(define-caller-pattern append ((:star form)) :lisp) +(define-caller-pattern copy-list (form) :lisp) +(define-caller-pattern copy-alist (form) :lisp) +(define-caller-pattern copy-tree (form) :lisp) +(define-caller-pattern revappend (form form) :lisp) +(define-caller-pattern nconc ((:star form)) :lisp) +(define-caller-pattern nreconc (form form) :lisp) +(define-caller-pattern push (form form) :lisp) +(define-caller-pattern pushnew (form form &key (:star form)) :lisp) +(define-caller-pattern pop (form) :lisp) +(define-caller-pattern butlast (form (:optional form)) :lisp) +(define-caller-pattern nbutlast (form (:optional form)) :lisp) +(define-caller-pattern ldiff (form form) :lisp) +(define-caller-pattern rplaca (form form) :lisp) +(define-caller-pattern rplacd (form form) :lisp) + +(define-caller-pattern subst (form form form &key (:star form)) :lisp) +(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern sublis (form form &key (:star form)) :lisp) +(define-caller-pattern nsublis (form form &key (:star form)) :lisp) +(define-caller-pattern member (form form &key (:star form)) :lisp) +(define-caller-pattern member-if (fn form &key (:star form)) :lisp) +(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp) + +(define-caller-pattern tailp (form form) :lisp) +(define-caller-pattern adjoin (form form &key (:star form)) :lisp) +(define-caller-pattern union (form form &key (:star form)) :lisp) +(define-caller-pattern nunion (form form &key (:star form)) :lisp) +(define-caller-pattern intersection (form form &key (:star form)) :lisp) +(define-caller-pattern nintersection (form form &key (:star form)) :lisp) +(define-caller-pattern set-difference (form form &key (:star form)) :lisp) +(define-caller-pattern nset-difference (form form &key (:star form)) :lisp) +(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern subsetp (form form &key (:star form)) :lisp) + +(define-caller-pattern acons (form form form) :lisp) +(define-caller-pattern pairlis (form form (:optional form)) :lisp) +(define-caller-pattern assoc (form form &key (:star form)) :lisp) +(define-caller-pattern assoc-if (fn form) :lisp) +(define-caller-pattern assoc-if-not (fn form) :lisp) +(define-caller-pattern rassoc (form form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp) + +;;; Hash Tables +(define-caller-pattern make-hash-table (&key (:star form)) :lisp) +(define-caller-pattern hash-table-p (form) :lisp) +(define-caller-pattern gethash (form form (:optional form)) :lisp) +(define-caller-pattern remhash (form form) :lisp) +(define-caller-pattern maphash (fn form) :lisp) +(define-caller-pattern clrhash (form) :lisp) +(define-caller-pattern hash-table-count (form) :lisp) +(define-caller-pattern with-hash-table-iterator + ((name form) (:star form)) :lisp2) +(define-caller-pattern hash-table-rehash-size (form) :lisp2) +(define-caller-pattern hash-table-rehash-threshold (form) :lisp2) +(define-caller-pattern hash-table-size (form) :lisp2) +(define-caller-pattern hash-table-test (form) :lisp2) +(define-caller-pattern sxhash (form) :lisp) + +;;; Arrays +(define-caller-pattern make-array (form &key (:star form)) :lisp) +(define-variable-pattern array-rank-limit :lisp) +(define-variable-pattern array-dimension-limit :lisp) +(define-variable-pattern array-total-size-limit :lisp) +(define-caller-pattern vector ((:star form)) :lisp) +(define-caller-pattern aref (form (:star form)) :lisp) +(define-caller-pattern svref (form form) :lisp) +(define-caller-pattern array-element-type (form) :lisp) +(define-caller-pattern array-rank (form) :lisp) +(define-caller-pattern array-dimension (form form) :lisp) +(define-caller-pattern array-dimensions (form) :lisp) +(define-caller-pattern array-total-size (form) :lisp) +(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp) +(define-caller-pattern array-row-major-index (form (:star form)) :lisp) +(define-caller-pattern row-major-aref (form form) :lisp2) +(define-caller-pattern adjustable-array-p (form) :lisp) + +(define-caller-pattern bit (form (:star form)) :lisp) +(define-caller-pattern sbit (form (:star form)) :lisp) + +(define-caller-pattern bit-and (form form (:optional form)) :lisp) +(define-caller-pattern bit-ior (form form (:optional form)) :lisp) +(define-caller-pattern bit-xor (form form (:optional form)) :lisp) +(define-caller-pattern bit-eqv (form form (:optional form)) :lisp) +(define-caller-pattern bit-nand (form form (:optional form)) :lisp) +(define-caller-pattern bit-nor (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-not (form (:optional form)) :lisp) + +(define-caller-pattern array-has-fill-pointer-p (form) :lisp) +(define-caller-pattern fill-pointer (form) :lisp) +(define-caller-pattern vector-push (form form) :lisp) +(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp) +(define-caller-pattern vector-pop (form) :lisp) +(define-caller-pattern adjust-array (form form &key (:star form)) :lisp) + +;;; Strings +(define-caller-pattern char (form form) :lisp) +(define-caller-pattern schar (form form) :lisp) +(define-caller-pattern string= (form form &key (:star form)) :lisp) +(define-caller-pattern string-equal (form form &key (:star form)) :lisp) +(define-caller-pattern string< (form form &key (:star form)) :lisp) +(define-caller-pattern string> (form form &key (:star form)) :lisp) +(define-caller-pattern string<= (form form &key (:star form)) :lisp) +(define-caller-pattern string>= (form form &key (:star form)) :lisp) +(define-caller-pattern string/= (form form &key (:star form)) :lisp) +(define-caller-pattern string-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp) + +(define-caller-pattern make-string (form &key (:star form)) :lisp) +(define-caller-pattern string-trim (form form) :lisp) +(define-caller-pattern string-left-trim (form form) :lisp) +(define-caller-pattern string-right-trim (form form) :lisp) +(define-caller-pattern string-upcase (form &key (:star form)) :lisp) +(define-caller-pattern string-downcase (form &key (:star form)) :lisp) +(define-caller-pattern string-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern string (form) :lisp) + +;;; Structures +(define-caller-pattern defstruct + ((:or name (name (:rest :ignore))) + (:optional documentation-string) + (:plus :ignore)) + :lisp) + +;;; The Evaluator +(define-caller-pattern eval (form) :lisp) +(define-variable-pattern *evalhook* :lisp) +(define-variable-pattern *applyhook* :lisp) +(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp) +(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp) +(define-caller-pattern constantp (form) :lisp) + +;;; Streams +(define-variable-pattern *standard-input* :lisp) +(define-variable-pattern *standard-output* :lisp) +(define-variable-pattern *error-output* :lisp) +(define-variable-pattern *query-io* :lisp) +(define-variable-pattern *debug-io* :lisp) +(define-variable-pattern *terminal-io* :lisp) +(define-variable-pattern *trace-output* :lisp) +(define-caller-pattern make-synonym-stream (symbol) :lisp) +(define-caller-pattern make-broadcast-stream ((:star form)) :lisp) +(define-caller-pattern make-concatenated-stream ((:star form)) :lisp) +(define-caller-pattern make-two-way-stream (form form) :lisp) +(define-caller-pattern make-echo-stream (form form) :lisp) +(define-caller-pattern make-string-input-stream (form &optional form form) + :lisp) +(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp) +(define-caller-pattern get-output-stream-string (form) :lisp) + +(define-caller-pattern with-open-stream + ((var form) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-input-from-string + ((var form &key (:star form)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-output-to-string + ((var (:optional form)) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern streamp (form) :lisp) +(define-caller-pattern open-stream-p (form) :lisp2) +(define-caller-pattern input-stream-p (form) :lisp) +(define-caller-pattern output-stream-p (form) :lisp) +(define-caller-pattern stream-element-type (form) :lisp) +(define-caller-pattern close (form (:rest :ignore)) :lisp) +(define-caller-pattern broadcast-stream-streams (form) :lisp2) +(define-caller-pattern concatenated-stream-streams (form) :lisp2) +(define-caller-pattern echo-stream-input-stream (form) :lisp2) +(define-caller-pattern echo-stream-output-stream (form) :lisp2) +(define-caller-pattern synonym-stream-symbol (form) :lisp2) +(define-caller-pattern two-way-stream-input-stream (form) :lisp2) +(define-caller-pattern two-way-stream-output-stream (form) :lisp2) +(define-caller-pattern interactive-stream-p (form) :lisp2) +(define-caller-pattern stream-external-format (form) :lisp2) + +;;; Reader +(define-variable-pattern *read-base* :lisp) +(define-variable-pattern *read-suppress* :lisp) +(define-variable-pattern *read-eval* :lisp2) +(define-variable-pattern *readtable* :lisp) +(define-caller-pattern copy-readtable (&optional form form) :lisp) +(define-caller-pattern readtablep (form) :lisp) +(define-caller-pattern set-syntax-from-char (form form &optional form form) + :lisp) +(define-caller-pattern set-macro-character (form fn &optional form) :lisp) +(define-caller-pattern get-macro-character (form (:optional form)) :lisp) +(define-caller-pattern make-dispatch-macro-character (form &optional form form) + :lisp) +(define-caller-pattern set-dispatch-macro-character + (form form fn (:optional form)) :lisp) +(define-caller-pattern get-dispatch-macro-character + (form form (:optional form)) :lisp) +(define-caller-pattern readtable-case (form) :lisp2) +(define-variable-pattern *print-readably* :lisp2) +(define-variable-pattern *print-escape* :lisp) +(define-variable-pattern *print-pretty* :lisp) +(define-variable-pattern *print-circle* :lisp) +(define-variable-pattern *print-base* :lisp) +(define-variable-pattern *print-radix* :lisp) +(define-variable-pattern *print-case* :lisp) +(define-variable-pattern *print-gensym* :lisp) +(define-variable-pattern *print-level* :lisp) +(define-variable-pattern *print-length* :lisp) +(define-variable-pattern *print-array* :lisp) +(define-caller-pattern with-standard-io-syntax + ((:star declaration) + (:star form)) + :lisp2) + +(define-caller-pattern read (&optional form form form form) :lisp) +(define-variable-pattern *read-default-float-format* :lisp) +(define-caller-pattern read-preserving-whitespace + (&optional form form form form) :lisp) +(define-caller-pattern read-delimited-list (form &optional form form) :lisp) +(define-caller-pattern read-line (&optional form form form form) :lisp) +(define-caller-pattern read-char (&optional form form form form) :lisp) +(define-caller-pattern unread-char (form (:optional form)) :lisp) +(define-caller-pattern peek-char (&optional form form form form) :lisp) +(define-caller-pattern listen ((:optional form)) :lisp) +(define-caller-pattern read-char-no-hang ((:star form)) :lisp) +(define-caller-pattern clear-input ((:optional form)) :lisp) +(define-caller-pattern read-from-string (form (:star form)) :lisp) +(define-caller-pattern parse-integer (form &rest :ignore) :lisp) +(define-caller-pattern read-byte ((:star form)) :lisp) + +(define-caller-pattern write (form &key (:star form)) :lisp) +(define-caller-pattern prin1 (form (:optional form)) :lisp) +(define-caller-pattern print (form (:optional form)) :lisp) +(define-caller-pattern pprint (form (:optional form)) :lisp) +(define-caller-pattern princ (form (:optional form)) :lisp) +(define-caller-pattern write-to-string (form &key (:star form)) :lisp) +(define-caller-pattern prin1-to-string (form) :lisp) +(define-caller-pattern princ-to-string (form) :lisp) +(define-caller-pattern write-char (form (:optional form)) :lisp) +(define-caller-pattern write-string (form &optional form &key (:star form)) + :lisp) +(define-caller-pattern write-line (form &optional form &key (:star form)) + :lisp) +(define-caller-pattern terpri ((:optional form)) :lisp) +(define-caller-pattern fresh-line ((:optional form)) :lisp) +(define-caller-pattern finish-output ((:optional form)) :lisp) +(define-caller-pattern force-output ((:optional form)) :lisp) +(define-caller-pattern clear-output ((:optional form)) :lisp) +(define-caller-pattern print-unreadable-object + ((form form &key (:star form)) + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern write-byte (form form) :lisp) +(define-caller-pattern format + (destination + control-string + (:rest format-arguments)) + :lisp) + +(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp) +(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp) + +;;; Pathnames +(define-caller-pattern wild-pathname-p (form &optional form) :lisp2) +(define-caller-pattern pathname-match-p (form form) :lisp2) +(define-caller-pattern translate-pathname (form form form &key (:star form)) + :lisp2) + +(define-caller-pattern logical-pathname (form) :lisp2) +(define-caller-pattern translate-logical-pathname (form &key (:star form)) + :lisp2) +(define-caller-pattern logical-pathname-translations (form) :lisp2) +(define-caller-pattern load-logical-pathname-translations (form) :lisp2) +(define-caller-pattern compile-file-pathname (form &key form) :lisp2) + +(define-caller-pattern pathname (form) :lisp) +(define-caller-pattern truename (form) :lisp) +(define-caller-pattern parse-namestring ((:star form)) :lisp) +(define-caller-pattern merge-pathnames ((:star form)) :lisp) +(define-variable-pattern *default-pathname-defaults* :lisp) +(define-caller-pattern make-pathname ((:star form)) :lisp) +(define-caller-pattern pathnamep (form) :lisp) +(define-caller-pattern pathname-host (form) :lisp) +(define-caller-pattern pathname-device (form) :lisp) +(define-caller-pattern pathname-directory (form) :lisp) +(define-caller-pattern pathname-name (form) :lisp) +(define-caller-pattern pathname-type (form) :lisp) +(define-caller-pattern pathname-version (form) :lisp) +(define-caller-pattern namestring (form) :lisp) +(define-caller-pattern file-namestring (form) :lisp) +(define-caller-pattern directory-namestring (form) :lisp) +(define-caller-pattern host-namestring (form) :lisp) +(define-caller-pattern enough-namestring (form (:optional form)) :lisp) +(define-caller-pattern user-homedir-pathname (&optional form) :lisp) +(define-caller-pattern open (form &key (:star form)) :lisp) +(define-caller-pattern with-open-file + ((var form (:rest :ignore)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern rename-file (form form) :lisp) +(define-caller-pattern delete-file (form) :lisp) +(define-caller-pattern probe-file (form) :lisp) +(define-caller-pattern file-write-date (form) :lisp) +(define-caller-pattern file-author (form) :lisp) +(define-caller-pattern file-position (form (:optional form)) :lisp) +(define-caller-pattern file-length (form) :lisp) +(define-caller-pattern file-string-length (form form) :lisp2) +(define-caller-pattern load (form &key (:star form)) :lisp) +(define-variable-pattern *load-verbose* :lisp) +(define-variable-pattern *load-print* :lisp2) +(define-variable-pattern *load-pathname* :lisp2) +(define-variable-pattern *load-truename* :lisp2) +(define-caller-pattern make-load-form (form) :lisp2) +(define-caller-pattern make-load-form-saving-slots (form &optional form) + :lisp2) +(define-caller-pattern directory (form &key (:star form)) :lisp) + +;;; Errors +(define-caller-pattern error (form (:star form)) :lisp) +(define-caller-pattern cerror (form form (:star form)) :lisp) +(define-caller-pattern warn (form (:star form)) :lisp) +(define-variable-pattern *break-on-warnings* :lisp) +(define-caller-pattern break (&optional form (:star form)) :lisp) +(define-caller-pattern check-type (form form (:optional form)) :lisp) +(define-caller-pattern assert + (form + (:optional ((:star var)) + (:optional form (:star form)))) + :lisp) +(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ecase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern ccase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) + +;;; The Compiler +(define-caller-pattern compile (form (:optional form)) :lisp) +(define-caller-pattern compile-file (form &key (:star form)) :lisp) +(define-variable-pattern *compile-verbose* :lisp2) +(define-variable-pattern *compile-print* :lisp2) +(define-variable-pattern *compile-file-pathname* :lisp2) +(define-variable-pattern *compile-file-truename* :lisp2) +(define-caller-pattern load-time-value (form (:optional form)) :lisp2) +(define-caller-pattern disassemble (form) :lisp) +(define-caller-pattern function-lambda-expression (fn) :lisp2) +(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form)) + :lisp2) + +;;; Documentation +(define-caller-pattern documentation (form form) :lisp) +(define-caller-pattern trace ((:star form)) :lisp) +(define-caller-pattern untrace ((:star form)) :lisp) +(define-caller-pattern step (form) :lisp) +(define-caller-pattern time (form) :lisp) +(define-caller-pattern describe (form &optional form) :lisp) +(define-caller-pattern describe-object (form &optional form) :lisp2) +(define-caller-pattern inspect (form) :lisp) +(define-caller-pattern room ((:optional form)) :lisp) +(define-caller-pattern ed ((:optional form)) :lisp) +(define-caller-pattern dribble ((:optional form)) :lisp) +(define-caller-pattern apropos (form (:optional form)) :lisp) +(define-caller-pattern apropos-list (form (:optional form)) :lisp) +(define-caller-pattern get-decoded-time () :lisp) +(define-caller-pattern get-universal-time () :lisp) +(define-caller-pattern decode-universal-time (form &optional form) :lisp) +(define-caller-pattern encode-universal-time + (form form form form form form &optional form) :lisp) +(define-caller-pattern get-internal-run-time () :lisp) +(define-caller-pattern get-internal-real-time () :lisp) +(define-caller-pattern sleep (form) :lisp) + +(define-caller-pattern lisp-implementation-type () :lisp) +(define-caller-pattern lisp-implementation-version () :lisp) +(define-caller-pattern machine-type () :lisp) +(define-caller-pattern machine-version () :lisp) +(define-caller-pattern machine-instance () :lisp) +(define-caller-pattern software-type () :lisp) +(define-caller-pattern software-version () :lisp) +(define-caller-pattern short-site-name () :lisp) +(define-caller-pattern long-site-name () :lisp) +(define-variable-pattern *features* :lisp) + +(define-caller-pattern identity (form) :lisp) + +;;; Pretty Printing +(define-variable-pattern *print-pprint-dispatch* :lisp2) +(define-variable-pattern *print-right-margin* :lisp2) +(define-variable-pattern *print-miser-width* :lisp2) +(define-variable-pattern *print-lines* :lisp2) +(define-caller-pattern pprint-newline (form &optional form) :lisp2) +(define-caller-pattern pprint-logical-block + ((var form &key (:star form)) + (:star form)) + :lisp2) +(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2) +(define-caller-pattern pprint-pop () :lisp2) +(define-caller-pattern pprint-indent (form form &optional form) :lisp2) +(define-caller-pattern pprint-tab (form form form &optional form) :lisp2) +(define-caller-pattern pprint-fill (form form &optional form form) :lisp2) +(define-caller-pattern pprint-linear (form form &optional form form) :lisp2) +(define-caller-pattern pprint-tabular (form form &optional form form form) + :lisp2) +(define-caller-pattern formatter (control-string) :lisp2) +(define-caller-pattern copy-pprint-dispatch (&optional form) :lisp2) +(define-caller-pattern pprint-dispatch (form &optional form) :lisp2) +(define-caller-pattern set-pprint-dispatch (form form &optional form form) + :lisp2) + +;;; CLOS +(define-caller-pattern add-method (fn form) :lisp2) +(define-caller-pattern call-method (form form) :lisp2) +(define-caller-pattern call-next-method ((:star form)) :lisp2) +(define-caller-pattern change-class (form form) :lisp2) +(define-caller-pattern class-name (form) :lisp2) +(define-caller-pattern class-of (form) :lisp2) +(define-caller-pattern compute-applicable-methods (fn (:star form)) :lisp2) +(define-caller-pattern defclass (name &rest :ignore) :lisp2) +(define-caller-pattern defgeneric (name lambda-list &rest :ignore) :lisp2) +(define-caller-pattern define-method-combination + (name lambda-list ((:star :ignore)) + (:optional ((:eq :arguments) :ignore)) + (:optional ((:eq :generic-function) :ignore)) + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern defmethod + (name (:star symbol) lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern ensure-generic-function (name &key (:star form)) :lisp2) +(define-caller-pattern find-class (form &optional form form) :lisp2) +(define-caller-pattern find-method (fn &rest :ignore) :lisp2) +(define-caller-pattern function-keywords (&rest :ignore) :lisp2) +(define-caller-pattern generic-flet (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-labels + (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-function (lambda-list) :lisp2) +(define-caller-pattern initialize-instance (form &key (:star form)) :lisp2) +(define-caller-pattern invalid-method-error (fn form (:star form)) :lisp2) +(define-caller-pattern make-instance (fn (:star form)) :lisp2) +(define-caller-pattern make-instances-obsolete (fn) :lisp2) +(define-caller-pattern method-combination-error (form (:star form)) :lisp2) +(define-caller-pattern method-qualifiers (fn) :lisp2) +(define-caller-pattern next-method-p () :lisp2) +(define-caller-pattern no-applicable-method (fn (:star form)) :lisp2) +(define-caller-pattern no-next-method (fn (:star form)) :lisp2) +(define-caller-pattern print-object (form form) :lisp2) +(define-caller-pattern reinitialize-instance (form (:star form)) :lisp2) +(define-caller-pattern remove-method (fn form) :lisp2) +(define-caller-pattern shared-initialize (form form (:star form)) :lisp2) +(define-caller-pattern slot-boundp (form form) :lisp2) +(define-caller-pattern slot-exists-p (form form) :lisp2) +(define-caller-pattern slot-makeunbound (form form) :lisp2) +(define-caller-pattern slot-missing (fn form form form &optional form) :lisp2) +(define-caller-pattern slot-unbound (fn form form) :lisp2) +(define-caller-pattern slot-value (form form) :lisp2) +(define-caller-pattern update-instance-for-different-class + (form form (:star form)) :lisp2) +(define-caller-pattern update-instance-for-redefined-class + (form form (:star form)) :lisp2) +(define-caller-pattern with-accessors + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern with-added-methods + ((name lambda-list) form + (:star form)) + :lisp2) +(define-caller-pattern with-slots + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) + +;;; Conditions +(define-caller-pattern signal (form (:star form)) :lisp2) +(define-variable-pattern *break-on-signals* :lisp2) +(define-caller-pattern handler-case (form (:star (form ((:optional var)) + (:star form)))) + :lisp2) +(define-caller-pattern ignore-errors ((:star form)) :lisp2) +(define-caller-pattern handler-bind (((:star (form form))) + (:star form)) + :lisp2) +(define-caller-pattern define-condition (name &rest :ignore) :lisp2) +(define-caller-pattern make-condition (form &rest :ignore) :lisp2) +(define-caller-pattern with-simple-restart + ((name form (:star form)) (:star form)) :lisp2) +(define-caller-pattern restart-case + (form + (:star (form form (:star form)))) + :lisp2) +(define-caller-pattern restart-bind + (((:star (name fn &key (:star form)))) + (:star form)) + :lisp2) +(define-caller-pattern with-condition-restarts + (form form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern compute-restarts (&optional form) :lisp2) +(define-caller-pattern restart-name (form) :lisp2) +(define-caller-pattern find-restart (form &optional form) :lisp2) +(define-caller-pattern invoke-restart (form (:star form)) :lisp2) +(define-caller-pattern invoke-restart-interactively (form) :lisp2) +(define-caller-pattern abort (&optional form) :lisp2) +(define-caller-pattern continue (&optional form) :lisp2) +(define-caller-pattern muffle-warning (&optional form) :lisp2) +(define-caller-pattern store-value (form &optional form) :lisp2) +(define-caller-pattern use-value (form &optional form) :lisp2) +(define-caller-pattern invoke-debugger (form) :lisp2) +(define-variable-pattern *debugger-hook* :lisp2) +(define-caller-pattern simple-condition-format-string (form) :lisp2) +(define-caller-pattern simple-condition-format-arguments (form) :lisp2) +(define-caller-pattern type-error-datum (form) :lisp2) +(define-caller-pattern type-error-expected-type (form) :lisp2) +(define-caller-pattern package-error-package (form) :lisp2) +(define-caller-pattern stream-error-stream (form) :lisp2) +(define-caller-pattern file-error-pathname (form) :lisp2) +(define-caller-pattern cell-error-name (form) :lisp2) +(define-caller-pattern arithmetic-error-operation (form) :lisp2) +(define-caller-pattern arithmetic-error-operands (form) :lisp2) + +;;; For ZetaLisp Flavors +(define-caller-pattern send (form fn (:star form)) :flavors) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/LICENSE b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/LICENSE new file mode 100644 index 0000000..5ea30c8 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/LICENSE @@ -0,0 +1,21 @@ +Copyright (C) 2001-2018, Arthur Lemmens et al. + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, copy, +modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/README.md b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/README.md new file mode 100644 index 0000000..47dc29b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/README.md @@ -0,0 +1,109 @@ +SPLIT-SEQUENCE +============== + +[SPLIT-SEQUENCE](http://cliki.net/split-sequence) is a member of the +[Common Lisp Utilities](http://cliki.net/Common%20Lisp%20Utilities) +family of programs, designed by community consensus. + + +_Function_ __SPLIT-SEQUENCE, SPLIT-SEQUENCE-IF, SPLIT-SEQUENCE-IF-NOT__ + + +__Syntax:__ + +__split-sequence__ _delimiter sequence `&key` count +remove-empty-subseqs from-end start end test test-not key ⇒ list, +index_ + +__split-sequence-if__ _predicate sequence `&key` count +remove-empty-subseqs from-end start end key ⇒ list, index_ + +__split-sequence-if-not__ _predicate sequence `&key` count +remove-empty-subseqs from-end start end key ⇒ list, index_ + + +__Arguments and Values:__ + +_delimiter_—an _object_. + +_predicate_—a designator for a _function_ of one _argument_ that +returns a _generalized boolean_. + +_sequence_—a _proper sequence_. + +_count_—an _integer_ or __nil__. The default is __nil__. + +_remove-empty-subseqs_—a _generalized boolean_. The default is +_false_. + +_from-end_—a _generalized boolean_. The default is _false_. + +_start, end_—_bounding index designators_ of _sequence_. The +defaults for _start_ and _end_ are __0__ and __nil__, respectively. + +_test_—a _designator_ for a _function_ of two _arguments_ that +returns a _generalized boolean_. + +_test-not_—a _designator_ for a _function_ of two _arguments_ +that returns a _generalized boolean_. + +_key_—a _designator_ for a _function_ of one _argument_, or +__nil__. + +_list_—a _proper sequence_. + +_index_—an _integer_ greater than or equal to zero, and less +than or equal to the _length_ of the _sequence_. + + +__Description:__ + +Splits _sequence_ into a list of subsequences delimited by objects +_satisfying the test_. + +_List_ is a list of sequences of the same kind as _sequence_ that has +elements consisting of subsequences of _sequence_ that were delimited +in the argument by elements _satisfying the test_. Index is an index +into _sequence_ indicating the unprocessed region, suitable as an +argument to +[subseq](http://www.lispworks.com/documentation/HyperSpec/Body/f_subseq.htm) +to continue processing in the same manner if desired. + +The _count_ argument, if supplied, limits the number of subsequences +in the first return value; if more than _count_ delimited subsequences +exist in _sequence_, the _count_ leftmost delimited subsequences will +be in order in the first return value, and the second return value +will be the index into _sequence_ at which processing stopped. + +If _from-end_ is non-null, _sequence_ is conceptually processed from +right to left, accumulating the subsequences in reverse order; +_from-end_ only makes a difference in the case of a non-null _count_ +argument. In the presence of _from-end_, the _count_ rightmost +delimited subsequences will be in the order that they are in +_sequence_ in the first return value, and the second is the index +indicating the end of the unprocessed region. + +The _start_ and _end_ keyword arguments permit a certain subsequence +of the _sequence_ to be processed without the need for a copying +stage; their use is conceptually equivalent to partitioning the +subsequence delimited by _start_ and _end_, only without the need for +copying. + +If _remove-empty-subseqs_ is null (the default), then empty +subsequences will be included in the result. + +In all cases, the subsequences in the first return value will be in +the order that they appeared in _sequence_. + + +__Examples:__ + +
+SPLIT-SEQUENCE> (split-sequence #\Space "A stitch in time saves nine.")
+⇒ ("A" "stitch" "in" "time" "saves" "nine.")
+⇒ 28
+
+SPLIT-SEQUENCE> (split-sequence #\, "foo,bar ,baz, foobar , barbaz,")
+⇒ ("foo" "bar " "baz" " foobar " " barbaz" "")
+⇒ 30
+
diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/api.lisp b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/api.lisp new file mode 100644 index 0000000..fad0af7 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/api.lisp @@ -0,0 +1,79 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :split-sequence) + +(defun list-long-enough-p (list length) + (or (zerop length) + (not (null (nthcdr (1- length) list))))) + +(defun check-bounds (sequence start end) + (progn + (check-type start unsigned-byte "a non-negative integer") + (check-type end (or null unsigned-byte) "a non-negative integer or NIL") + (typecase sequence + (list + (when end + (unless (list-long-enough-p sequence end) + (error "The list is too short: END was ~S but the list is ~S elements long." + end (length sequence))))) + (t + (let ((length (length sequence))) + (unless end (setf end length)) + (unless (<= start end length) + (error "Wrong sequence bounds. START: ~S END: ~S" start end))))))) + +(define-condition simple-program-error (program-error simple-condition) ()) + +(defmacro check-tests (test test-p test-not test-not-p) + `(progn + (when (and ,test-p ,test-not-p) + (error (make-condition 'simple-program-error + :format-control "Cannot specify both TEST and TEST-NOT."))) + (when (and ,test-not-p (not ,test-p)) + (check-type ,test-not (or function (and symbol (not null))))) + (when (and ,test-p (not ,test-not-p)) + (check-type ,test (or function (and symbol (not null))))))) + +(declaim (ftype (function (&rest t) (values list unsigned-byte)) + split-sequence split-sequence-if split-sequence-if-not)) + +(defun split-sequence (delimiter sequence &key (start 0) (end nil) (from-end nil) + (count nil) (remove-empty-subseqs nil) + (test #'eql test-p) (test-not nil test-not-p) + (key #'identity)) + (check-bounds sequence start end) + (check-tests test test-p test-not test-not-p) + (etypecase sequence + (list (split-list delimiter sequence start end from-end count + remove-empty-subseqs test test-not key)) + (vector (split-vector delimiter sequence start end from-end count + remove-empty-subseqs test test-not key)) + #+(or abcl sbcl) + (extended-sequence (split-extended-sequence delimiter sequence start end from-end count + remove-empty-subseqs test test-not key)))) + +(defun split-sequence-if (predicate sequence &key (start 0) (end nil) (from-end nil) + (count nil) (remove-empty-subseqs nil) (key #'identity)) + (check-bounds sequence start end) + (etypecase sequence + (list (split-list-if predicate sequence start end from-end count + remove-empty-subseqs key)) + (vector (split-vector-if predicate sequence start end from-end count + remove-empty-subseqs key)) + #+(or abcl sbcl) + (extended-sequence (split-extended-sequence-if predicate sequence start end from-end count + remove-empty-subseqs key)))) + +(defun split-sequence-if-not (predicate sequence &key (start 0) (end nil) (from-end nil) + (count nil) (remove-empty-subseqs nil) (key #'identity)) + (check-bounds sequence start end) + (etypecase sequence + (list (split-list-if-not predicate sequence start end from-end count + remove-empty-subseqs key)) + (vector (split-vector-if-not predicate sequence start end from-end count + remove-empty-subseqs key)) + #+(or abcl sbcl) + (extended-sequence (split-extended-sequence-if-not predicate sequence start end from-end count + remove-empty-subseqs key)))) + +(pushnew :split-sequence *features*) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/documentation.lisp b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/documentation.lisp new file mode 100644 index 0000000..f05c4eb --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/documentation.lisp @@ -0,0 +1,41 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :split-sequence) + +(setf (documentation 'split-sequence 'function) + "Return a list of subsequences in seq delimited by delimiter. +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. :count limits the number of subseqs in the main +resulting list. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped.") + +(setf (documentation 'split-sequence-if 'function) + "Return a list of subsequences in seq delimited by items satisfying +predicate. +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. :count limits the number of subseqs in the main +resulting list. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped.") + +(setf (documentation 'split-sequence-if-not 'function) + "Return a list of subsequences in seq delimited by items satisfying +\(CL:COMPLEMENT predicate). +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, +the behaviour of :from-end is possibly different from other versions +of this function; :from-end values of NIL and T are equivalent unless +:count is supplied. :count limits the number of subseqs in the main +resulting list. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped.") diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/extended-sequence.lisp b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/extended-sequence.lisp new file mode 100644 index 0000000..8341d5f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/extended-sequence.lisp @@ -0,0 +1,100 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :split-sequence) + +;;; For extended sequences, we make the assumption that all extended sequences +;;; can be at most ARRAY-DIMENSION-LIMIT long. This seems to match what SBCL +;;; assumes about them. + +;;; TODO test this code. This will require creating such an extended sequence. + +(deftype extended-sequence () + '(and sequence (not list) (not vector))) + +(declaim (inline + split-extended-sequence split-extended-sequence-if split-extended-sequence-if-not + split-extended-sequence-from-end split-extended-sequence-from-start)) + +(declaim (ftype (function (&rest t) (values list unsigned-byte)) + split-extended-sequence split-extended-sequence-if split-extended-sequence-if-not)) + +(declaim (ftype (function (function extended-sequence array-index + (or null fixnum) (or null fixnum) boolean) + (values list fixnum)) + split-extended-sequence-from-start split-extended-sequence-from-end)) + +(defun split-extended-sequence + (delimiter sequence start end from-end count remove-empty-subseqs test test-not key) + (cond + ((and (not from-end) (null test-not)) + (split-extended-sequence-from-start (lambda (sequence start) + (position delimiter sequence :start start :key key :test test)) + sequence start end count remove-empty-subseqs)) + ((and (not from-end) test-not) + (split-extended-sequence-from-start (lambda (sequence start) + (position delimiter sequence :start start :key key :test-not test-not)) + sequence start end count remove-empty-subseqs)) + ((and from-end (null test-not)) + (split-extended-sequence-from-end (lambda (sequence end) + (position delimiter sequence :end end :from-end t :key key :test test)) + sequence start end count remove-empty-subseqs)) + (t + (split-extended-sequence-from-end (lambda (sequence end) + (position delimiter sequence :end end :from-end t :key key :test-not test-not)) + sequence start end count remove-empty-subseqs)))) + +(defun split-extended-sequence-if + (predicate sequence start end from-end count remove-empty-subseqs key) + (if from-end + (split-extended-sequence-from-end (lambda (sequence end) + (position-if predicate sequence :end end :from-end t :key key)) + sequence start end count remove-empty-subseqs) + (split-extended-sequence-from-start (lambda (sequence start) + (position-if predicate sequence :start start :key key)) + sequence start end count remove-empty-subseqs))) + +(defun split-extended-sequence-if-not + (predicate sequence start end from-end count remove-empty-subseqs key) + (if from-end + (split-extended-sequence-from-end (lambda (sequence end) + (position-if-not predicate sequence :end end :from-end t :key key)) + sequence start end count remove-empty-subseqs) + (split-extended-sequence-from-start (lambda (sequence start) + (position-if-not predicate sequence :start start :key key)) + sequence start end count remove-empty-subseqs))) + +(defun split-extended-sequence-from-end (position-fn sequence start end count remove-empty-subseqs) + (declare (optimize (speed 3) (debug 0)) + (type (function (extended-sequence fixnum) (or null fixnum)) position-fn)) + (loop + :with length = (length sequence) + :with end = (or end length) + :for right := end :then left + :for left := (max (or (funcall position-fn sequence right) -1) + (1- start)) + :unless (and (= right (1+ left)) remove-empty-subseqs) + :if (and count (>= nr-elts count)) + :return (values (nreverse subseqs) right) + :else + :collect (subseq sequence (1+ left) right) into subseqs + :and :sum 1 :into nr-elts :of-type fixnum + :until (< left start) + :finally (return (values (nreverse subseqs) (1+ left))))) + +(defun split-extended-sequence-from-start (position-fn sequence start end count remove-empty-subseqs) + (declare (optimize (speed 3) (debug 0)) + (type (function (extended-sequence fixnum) (or null fixnum)) position-fn)) + (loop + :with length = (length sequence) + :with end = (or end length) + :for left := start :then (1+ right) + :for right := (min (or (funcall position-fn sequence left) length) + end) + :unless (and (= right left) remove-empty-subseqs) + :if (and count (>= nr-elts count)) + :return (values subseqs left) + :else + :collect (subseq sequence left right) :into subseqs + :and :sum 1 :into nr-elts :of-type fixnum + :until (>= right end) + :finally (return (values subseqs right)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/list.lisp b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/list.lisp new file mode 100644 index 0000000..7907d10 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/list.lisp @@ -0,0 +1,116 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :split-sequence) + +(declaim (inline + collect-until count-while + split-list split-list-if split-list-if-not + split-list-from-end split-list-from-start split-list-internal)) + +(declaim (ftype (function (&rest t) (values list unsigned-byte)) + split-list split-list-if split-list-if-not)) + +(declaim (ftype (function (function list unsigned-byte (or null unsigned-byte) (or null unsigned-byte) + boolean) + (values list unsigned-byte)) + split-list-from-start split-list-from-end split-list-internal)) + +(defun collect-until (predicate list end) + "Collect elements from LIST until one that satisfies PREDICATE is found. + + At most END elements will be examined. If END is null, all elements will be examined. + + Returns four values: + + * The collected items. + * The remaining items. + * The number of elements examined. + * Whether the search ended by running off the end, instead of by finding a delimiter." + (let ((examined 0) + (found nil)) + (flet ((examine (value) + (incf examined) + (setf found (funcall predicate value)))) + (loop :for (value . remaining) :on list + :until (eql examined end) + :until (examine value) + :collect value :into result + :finally (return (values result + remaining + examined + (and (not found) + (or (null end) + (= end examined))))))))) + +(defun count-while (predicate list end) + "Count the number of elements satisfying PREDICATE at the beginning of LIST. + + At most END elements will be counted. If END is null, all elements will be examined." + (if end + (loop :for value :in list + :for i :below end + :while (funcall predicate value) + :summing 1) + (loop :for value :in list + :while (funcall predicate value) + :summing 1))) + +(defun split-list-internal (predicate list start end count remove-empty-subseqs) + (let ((count count) + (done nil) + (index start) + (end (when end (- end start))) + (list (nthcdr start list))) + (flet ((should-collect-p (chunk) + (unless (and remove-empty-subseqs (null chunk)) + (when (numberp count) (decf count)) + t)) + (gather-chunk () + (multiple-value-bind (chunk remaining examined ran-off-end) + (collect-until predicate list end) + (incf index examined) + (when end (decf end examined)) + (setf list remaining + done ran-off-end) + chunk))) + (values (loop :with chunk + :until (or done (eql 0 count)) + :do (setf chunk (gather-chunk)) + :when (should-collect-p chunk) + :collect chunk) + (+ index + (if remove-empty-subseqs + (count-while predicate list end) ; chew off remaining empty seqs + 0)))))) + +(defun split-list-from-end (predicate list start end count remove-empty-subseqs) + (let ((length (length list))) + (multiple-value-bind (result index) + (split-list-internal predicate (reverse list) + (if end (- length end) 0) + (- length start) count remove-empty-subseqs) + (loop :for cons on result + :for car := (car cons) + :do (setf (car cons) (nreverse car))) + (values (nreverse result) (- length index))))) + +(defun split-list-from-start (predicate list start end count remove-empty-subseqs) + (split-list-internal predicate list start end count remove-empty-subseqs)) + +(defun split-list-if (predicate list start end from-end count remove-empty-subseqs key) + (let ((predicate (lambda (x) (funcall predicate (funcall key x))))) + (if from-end + (split-list-from-end predicate list start end count remove-empty-subseqs) + (split-list-from-start predicate list start end count remove-empty-subseqs)))) + +(defun split-list-if-not (predicate list start end from-end count remove-empty-subseqs key) + (split-list-if (complement predicate) list start end from-end count remove-empty-subseqs key)) + +(defun split-list + (delimiter list start end from-end count remove-empty-subseqs test test-not key) + (let ((predicate (if test-not + (lambda (x) (not (funcall test-not delimiter (funcall key x)))) + (lambda (x) (funcall test delimiter (funcall key x)))))) + (if from-end + (split-list-from-end predicate list start end count remove-empty-subseqs) + (split-list-from-start predicate list start end count remove-empty-subseqs)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/original-message.txt b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/original-message.txt new file mode 100644 index 0000000..fe4873c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/original-message.txt @@ -0,0 +1,150 @@ +From ... +Path: supernews.google.com!sn-xit-02!sn-xit-03!supernews.com!news.tele.dk!193.190.198.17!newsfeeds.belnet.be! +news.belnet.be!skynet.be!newsfeed2.news.nl.uu.net!sun4nl!not-for-mail +From: Arthur Lemmens +Newsgroups: comp.lang.lisp +Subject: Re: Q: on hashes and counting +Date: Mon, 23 Oct 2000 00:50:02 +0200 +Organization: Kikashi Software +Lines: 129 +Message-ID: <39F36F1A.B8F19D20@simplex.nl> +References: <8sl58e$ivq$1@nnrp1.deja.com> <878zrlp1cr.fsf@orion.bln.pmsf.de> +Mime-Version: 1.0 +Content-Type: text/plain; charset=us-ascii +Content-Transfer-Encoding: 7bit +X-Trace: porthos.nl.uu.net 972255051 2606 193.78.46.221 (22 Oct 2000 22:50:51 GMT) +X-Complaints-To: abuse@nl.uu.net +NNTP-Posting-Date: 22 Oct 2000 22:50:51 GMT +X-Mailer: Mozilla 4.5 [en] (Win98; I) +X-Accept-Language: en +Xref: supernews.google.com comp.lang.lisp:2515 + + +Pierre R. Mai wrote: + +> ;;; The following functions are based on the versions by Arthur +> ;;; Lemmens of the original code by Bernard Pfahringer posted to +> ;;; comp.lang.lisp. I only renamed and diddled them a bit. +> +> (defun partition + +[snip] + +> ;; DO: Find a more efficient way to take care of :from-end T. +> (when from-end +> (setf seq (reverse seq)) +> (psetf start (- len end) +> end (- len start))) + +I've written a different version now for dealing with :FROM-END T. +It doesn't call REVERSE anymore, which makes it more efficient. +Also, I prefer the new semantics. Stuff like + (split #\space "one two three " :from-end t) +now returns + ("three" "two" "one") +which I find a lot more useful than + ("eerht" "owt" "eno") +If you prefer the latter, it's easy enough to use + (split #\space (reverse "one two three ")) + + +Here it is (feel free to use this code any way you like): + +(defun SPLIT (delimiter seq + &key (maximum nil) + (keep-empty-subseqs nil) + (from-end nil) + (start 0) + (end nil) + (test nil test-supplied) + (test-not nil test-not-supplied) + (key nil key-supplied)) + +"Return a list of subsequences in delimited by . +If :keep-empty-subseqs is true, empty subsequences will be included +in the result; otherwise they will be discarded. +If :maximum is supplied, the result will contain no more than :maximum +(possibly empty) subsequences. The second result value contains the +unsplit rest of the sequence. +All other keywords work analogously to those for CL:POSITION." + +;; DO: Make ":keep-delimiters t" include the delimiters in the result (?). + + (let ((len (length seq)) + (other-keys (nconc (when test-supplied + (list :test test)) + (when test-not-supplied + (list :test-not test-not)) + (when key-supplied + (list :key key))))) + +(unless end (setq end len)) +(if from-end + (loop for right = end then left + for left = (max (or (apply #'position delimiter seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left) ) + (not keep-empty-subseqs)) ; empty subseq we don't want + if (and maximum (>= nr-elts maximum)) + ;; We can't take any more. Return now. + return (values subseqs (subseq seq start right)) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (<= left start) + finally return (values subseqs (subseq seq start (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position delimiter seq + :start left + other-keys) + len) + end) + unless (and (= right left) + (not keep-empty-subseqs)) ; empty subseq we don't want + if (and maximum (>= nr-elts maximum)) + ;; We can't take any more. Return now. + return (values subseqs (subseq seq left end)) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (= right end) + finally return (values subseqs (subseq seq right end)))))) + + + +Here are some examples of how you can use this: + + +CL-USER 2 > (split #\space "word1 word2 word3") +("word1" "word2" "word3") +"" + +CL-USER 3 > (split #\space "word1 word2 word3" :from-end t) +("word3" "word2" "word1") +"" + +CL-USER 4 > (split nil '(a b nil c d e nil nil nil nil f) :maximum 2) +((A B) (C D E)) +(F) + +CL-USER 5 > (split #\space "Nospaceshere.") +("Nospaceshere.") +"" + +CL-USER 6 > (split #\; "12;13;;14" :keep-empty-subseqs t) + +("12" "13" "" "14") +"" + +CL-USER 7 > (split #\; "12;13;;14" :keep-empty-subseqs t :from-end t) + +("14" "" "13" "12") +"" + +CL-USER 8 > (split #\space "Nospaceshere. ") +("Nospaceshere.") +"" diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/package.lisp b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/package.lisp new file mode 100644 index 0000000..71f5001 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/package.lisp @@ -0,0 +1,37 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- +;;; +;;; SPLIT-SEQUENCE +;;; +;;; This code was based on Arthur Lemmens' in +;;; ; +;;; +;;; changes include: +;;; +;;; * altering the behaviour of the :from-end keyword argument to +;;; return the subsequences in original order, for consistency with +;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only +;;; affects the answer if :count is less than the number of +;;; subsequences, by analogy with the above-referenced functions). +;;; +;;; * changing the :maximum keyword argument to :count, by analogy +;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. +;;; +;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather +;;; than SPLIT. +;;; +;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. +;;; +;;; * The second return value is now an index rather than a copy of a +;;; portion of the sequence; this index is the `right' one to feed to +;;; CL:SUBSEQ for continued processing. + +;;; There's a certain amount of code duplication in the vector and +;;; extended sequence modules, which is kept to illustrate the +;;; relationship between the SPLIT-SEQUENCE functions and the +;;; CL:POSITION functions. + +(defpackage #:split-sequence + (:use #:common-lisp) + (:export #:split-sequence + #:split-sequence-if + #:split-sequence-if-not)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/split-sequence.asd b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/split-sequence.asd new file mode 100644 index 0000000..868d840 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/split-sequence.asd @@ -0,0 +1,28 @@ +;;; -*- Lisp -*- + +(defsystem :split-sequence + :author "Arthur Lemmens " + :maintainer "Sharp Lispers " + :description "Splits a sequence into a list of subsequences + delimited by objects satisfying a test." + :license "MIT" + :version (:read-file-form "version.sexp") + :components ((:static-file "version.sexp") + (:file "package") + (:file "vector") + (:file "list") + (:file "extended-sequence" :if-feature (:or :sbcl :abcl)) + (:file "api") + (:file "documentation"))) + +(defsystem :split-sequence/tests + :author "Arthur Lemmens " + :maintainer "Sharp Lispers " + :description "Split-Sequence test suite" + :license "MIT" + :depends-on (:split-sequence :fiveam) + :components ((:file "tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system :split-sequence)))) + (load-system :split-sequence/tests) + (symbol-call :5am :run! :split-sequence)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/tests.lisp b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/tests.lisp new file mode 100644 index 0000000..691c546 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/tests.lisp @@ -0,0 +1,268 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(defpackage :split-sequence/tests + (:use :common-lisp :split-sequence :fiveam)) + +(in-package :split-sequence/tests) + +(in-suite* :split-sequence) + +;;; UNIT TESTS + +(defmacro define-test (name (&key input output index) &body forms) + ;; This macro automatically generates test code for testing vector and list input. + ;; Vector input and output is automatically coerced into list form for the list tests. + ;; (DEFINE-TEST FOO ...) generates FIVEAM tests FOO.VECTOR and FOO.LIST. + (check-type name symbol) + (check-type input (cons symbol (cons vector null))) + (check-type output (cons symbol (cons list null))) + (check-type index (cons symbol (cons unsigned-byte null))) + (let* ((input-symbol (first input)) (vector-input (second input)) + (output-symbol (first output)) (vector-output (second output)) + (index-symbol (first index)) (index-value (second index)) + (list-input (coerce vector-input 'list)) + (list-output (mapcar (lambda (x) (coerce x 'list)) vector-output)) + (vector-name (intern (concatenate 'string (symbol-name name) ".VECTOR"))) + (list-name (intern (concatenate 'string (symbol-name name) ".LIST")))) + `(progn + (test (,vector-name :compile-at :definition-time) + (let ((,input-symbol ',vector-input) + (,output-symbol ',vector-output) + (,index-symbol ,index-value)) + ,@forms)) + (test (,list-name :compile-at :definition-time) + (let ((,input-symbol ',list-input) + (,output-symbol ',list-output) + (,index-symbol ,index-value)) + ,@forms))))) + +(define-test split-sequence.0 (:input (input "") + :output (output ("")) + :index (index 0)) + (is (equalp (split-sequence #\; input) + (values output index)))) + +(define-test split-sequence.1 (:input (input "a;;b;c") + :output (output ("a" "" "b" "c")) + :index (index 6)) + (is (equalp (split-sequence #\; input) + (values output index)))) + +(define-test split-sequence.2 (:input (input "a;;b;c") + :output (output ("a" "" "b" "c")) + :index (index 0)) + (is (equalp (split-sequence #\; input :from-end t) + (values output index)))) + +(define-test split-sequence.3 (:input (input "a;;b;c") + :output (output ("c")) + :index (index 4)) + (is (equalp (split-sequence #\; input :from-end t :count 1) + (values output index)))) + +(define-test split-sequence.4 (:input (input "a;;b;c") + :output (output ("a" "b" "c")) + :index (index 6)) + (is (equalp (split-sequence #\; input :remove-empty-subseqs t) + (values output index)))) + +(define-test split-sequence.5 (:input (input ";oo;bar;ba;") + :output (output ("oo" "bar" "b")) + :index (index 9)) + (is (equalp (split-sequence #\; input :start 1 :end 9) + (values output index)))) + +(define-test split-sequence.6 (:input (input "abracadabra") + :output (output ("" "br" "c" "d" "br" "")) + :index (index 11)) + (is (equalp (split-sequence #\A input :key #'char-upcase) + (values output index)))) + +(define-test split-sequence.7 (:input (input "abracadabra") + :output (output ("r" "c" "d")) + :index (index 7)) + (is (equalp (split-sequence #\A input :key #'char-upcase :start 2 :end 7) + (values output index)))) + +(define-test split-sequence.8 (:input (input "abracadabra") + :output (output ("r" "c" "d")) + :index (index 2)) + (is (equalp (split-sequence #\A input :key #'char-upcase :start 2 :end 7 :from-end t) + (values output index)))) + +(define-test split-sequence.9 (:input (input #(1 2 0)) + :output (output (#(1 2) #())) + :index (index 0)) + (is (equalp (split-sequence 0 input :from-end t) + (values output index)))) + +(define-test split-sequence.10 (:input (input #(2 0 0 2 3 2 0 1 0 3)) + :output (output ()) + :index (index 8)) + (is (equalp (split-sequence 0 input :start 8 :end 9 :from-end t :count 0 :remove-empty-subseqs t) + (values output index)))) + +(define-test split-sequence.11 (:input (input #(0 1 3 0 3 1 2 2 1 0)) + :output (output ()) + :index (index 0)) + (is (equalp (split-sequence 0 input :start 0 :end 0 :remove-empty-subseqs t) + (values output index)))) + +(define-test split-sequence.12 (:input (input #(3 0 0 0 3 3 0 3 1 0)) + :output (output ()) + :index (index 10)) + (is (equalp (split-sequence 0 input :start 9 :end 10 :from-end t :count 0) + (values output index)))) + +(define-test split-sequence.13 (:input (input #(3 3 3 3 0 2 0 0 1 2)) + :output (output (#(1))) + :index (index 6)) + (is (equalp (split-sequence 0 input :start 6 :end 9 :from-end t :count 1 :remove-empty-subseqs t) + (values output index)))) + +(define-test split-sequence.14 (:input (input #(1 0)) + :output (output (#(1))) + :index (index 0)) + (is (equalp (split-sequence 0 input :from-end t :count 1 :remove-empty-subseqs t) + (values output index)))) + +(define-test split-sequence.15 (:input (input #(0 0)) + :output (output ()) + :index (index 1)) + (is (equalp (split-sequence 0 input :start 0 :end 1 :count 0 :remove-empty-subseqs t) + (values output index)))) + +(define-test split-sequence.16 (:input (input "a;;b;c") + :output (output ("" ";;" ";" "")) + :index (index 6)) + (is (equalp (split-sequence #\; input :test-not #'eql) + (values output index)))) + +(define-test split-sequence.17 (:input (input "a;;b;c") + :output (output ("" ";;" ";" "")) + :index (index 0)) + (is (equalp (split-sequence #\; input :from-end t :test-not #'eql) + (values output index)))) + +(define-test split-sequence.18 (:input (input #(1 0 2 0 3 0 4)) + :output (output (#(1) #(2) #(3))) + :index (index 6)) + (is (equalp (split-sequence 0 input :count 3) + (values output index)))) + +(define-test split-sequence-if.1 (:input (input "abracadabra") + :output (output ("" "" "r" "c" "d" "" "r" "")) + :index (index 11)) + (is (equalp (split-sequence-if (lambda (x) (member x '(#\a #\b))) input) + (values output index)))) + +(define-test split-sequence-if.2 (:input (input "123456") + :output (output ("1" "3" "5")) + :index (index 6)) + (is (equalp (split-sequence-if (lambda (x) (evenp (parse-integer (string x)))) input + :remove-empty-subseqs t) + (values output index)))) + +(define-test split-sequence-if.3 (:input (input "123456") + :output (output ("1" "3" "5" "")) + :index (index 6)) + (is (equalp (split-sequence-if (lambda (x) (evenp (parse-integer (string x)))) input) + (values output index)))) + +(define-test split-sequence-if-not.1 (:input (input "abracadabra") + :output (output ("ab" "a" "a" "ab" "a")) + :index (index 11)) + (is (equalp (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) input) + (values output index)))) + +(test split-sequence.start-end-error + (signals error (split-sequence 0 #(0 1 2 3) :start nil)) + (signals error (split-sequence 0 #(0 1 2 3) :end '#:end)) + (signals error (split-sequence 0 #(0 1 2 3) :start 0 :end 8)) + (signals error (split-sequence 0 #(0 1 2 3) :start 2 :end 0))) + +(test split-sequence.test-provided + ;; Neither provided + (is (equal '((1) (3)) (split-sequence 2 '(1 2 3)))) + ;; Either provided + (is (equal '((1) (3)) (split-sequence 2 '(1 2 3) :test #'eql))) + (is (equal '(() (2) ()) (split-sequence 2 '(1 2 3) :test-not #'eql))) + (signals type-error (split-sequence 2 '(1 2 3) :test nil)) + (signals type-error (split-sequence 2 '(1 2 3) :test-not nil)) + ;; Both provided + (signals program-error (split-sequence 2 '(1 2 3) :test #'eql :test-not nil)) + (signals program-error (split-sequence 2 '(1 2 3) :test nil :test-not #'eql)) + (signals program-error (split-sequence 2 '(1 2 3) :test #'eql :test-not #'eql)) + (signals program-error (split-sequence 2 '(1 2 3) :test nil :test-not nil))) + +;;; FUZZ TEST + +(test split-sequence.fuzz + (fuzz :verbose nil :fiveamp t)) + +(defun fuzz (&key (max-length 100) (repetitions 1000000) (verbose t) (print-every 10000) (fiveamp nil)) + (flet ((random-vector (n) + (let ((vector (make-array n :element-type '(unsigned-byte 2)))) + (dotimes (i n) (setf (aref vector i) (random 4))) + vector)) + (random-boolean () (if (= 0 (random 2)) t nil)) + (fuzz-failure (vector start end from-end count remove-empty-subseqs + expected-splits expected-index actual-splits actual-index) + (format nil "Fuzz failure: +\(MULTIPLE-VALUE-CALL #'VALUES + (SPLIT-SEQUENCE 0 ~S + :START ~S :END ~S :FROM-END ~S :COUNT ~S :REMOVE-EMPTY-SUBSEQS ~S) + (SPLIT-SEQUENCE 0 (COERCE ~S 'LIST) + :START ~S :END ~S :FROM-END ~S :COUNT ~S :REMOVE-EMPTY-SUBSEQS ~S)) +~S~%~S~%~S~%~S" + vector start end from-end count remove-empty-subseqs + vector start end from-end count remove-empty-subseqs + expected-splits expected-index actual-splits actual-index))) + (let ((failure-string nil) + (predicate (lambda (x) (= x 0))) + (predicate-not (lambda (x) (/= x 0)))) + (dotimes (i repetitions) + (when (and verbose (= 0 (mod (1+ i) print-every))) + (format t "Fuzz: Pass ~D passed.~%" (1+ i))) + (let* ((length (1+ (random max-length))) + (vector (random-vector length)) + (list (coerce vector 'list)) + (remove-empty-subseqs (random-boolean)) + (start 0) end from-end count) + (case (random 5) + (0) + (1 (setf start (random length))) + (2 (setf start (random length) + end (+ start (random (1+ (- length start)))))) + (3 (setf start (random length) + end (+ start (random (1+ (- length start)))) + from-end t)) + (4 (setf start (random length) + end (+ start (random (1+ (- length start)))) + from-end t + count (random (1+ (- end start)))))) + (let ((args (list :start start :end end :from-end from-end :count count + :remove-empty-subseqs remove-empty-subseqs))) + (multiple-value-bind (expected-splits expected-index) + (case (random 3) + (0 (apply #'split-sequence 0 vector args)) + (1 (apply #'split-sequence-if predicate vector args)) + (2 (apply #'split-sequence-if-not predicate-not vector args))) + (multiple-value-bind (actual-splits actual-index) + (case (random 3) + (0 (apply #'split-sequence 0 list args)) + (1 (apply #'split-sequence-if predicate list args)) + (2 (apply #'split-sequence-if-not predicate-not list args))) + (let* ((expected-splits (mapcar (lambda (x) (coerce x 'list)) expected-splits)) + (result (and (equal actual-splits expected-splits) + (= expected-index actual-index)))) + (unless result + (let ((string (fuzz-failure + vector start end from-end count remove-empty-subseqs + expected-splits expected-index actual-splits actual-index))) + (cond (fiveamp + (setf failure-string string) + (return)) + (t (assert result () string))))))))))) + (when fiveamp + (is (not failure-string) failure-string))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/vector.lisp b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/vector.lisp new file mode 100644 index 0000000..247a337 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/vector.lisp @@ -0,0 +1,94 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :split-sequence) + +(declaim (inline + split-vector split-vector-if split-vector-if-not + split-vector-from-end split-vector-from-start)) + +(deftype array-index (&optional (length array-dimension-limit)) + `(integer 0 (,length))) + +(declaim (ftype (function (&rest t) (values list unsigned-byte)) + split-vector split-vector-if split-vector-if-not)) + +(declaim (ftype (function (function vector array-index + (or null array-index) (or null array-index) boolean) + (values list unsigned-byte)) + split-vector-from-start split-vector-from-end)) + +(defun split-vector + (delimiter vector start end from-end count remove-empty-subseqs test test-not key) + (cond + ((and (not from-end) (null test-not)) + (split-vector-from-start (lambda (vector start) + (position delimiter vector :start start :key key :test test)) + vector start end count remove-empty-subseqs)) + ((and (not from-end) test-not) + (split-vector-from-start (lambda (vector start) + (position delimiter vector :start start :key key :test-not test-not)) + vector start end count remove-empty-subseqs)) + ((and from-end (null test-not)) + (split-vector-from-end (lambda (vector end) + (position delimiter vector :end end :from-end t :key key :test test)) + vector start end count remove-empty-subseqs)) + (t + (split-vector-from-end (lambda (vector end) + (position delimiter vector :end end :from-end t :key key :test-not test-not)) + vector start end count remove-empty-subseqs)))) + +(defun split-vector-if + (predicate vector start end from-end count remove-empty-subseqs key) + (if from-end + (split-vector-from-end (lambda (vector end) + (position-if predicate vector :end end :from-end t :key key)) + vector start end count remove-empty-subseqs) + (split-vector-from-start (lambda (vector start) + (position-if predicate vector :start start :key key)) + vector start end count remove-empty-subseqs))) + +(defun split-vector-if-not + (predicate vector start end from-end count remove-empty-subseqs key) + (if from-end + (split-vector-from-end (lambda (vector end) + (position-if-not predicate vector :end end :from-end t :key key)) + vector start end count remove-empty-subseqs) + (split-vector-from-start (lambda (vector start) + (position-if-not predicate vector :start start :key key)) + vector start end count remove-empty-subseqs))) + +(defun split-vector-from-end (position-fn vector start end count remove-empty-subseqs) + (declare (optimize (speed 3) (debug 0)) + (type (function (vector fixnum) (or null fixnum)) position-fn)) + (loop + :with end = (or end (length vector)) + :for right := end :then left + :for left := (max (or (funcall position-fn vector right) -1) + (1- start)) + :unless (and (= right (1+ left)) remove-empty-subseqs) + :if (and count (>= nr-elts count)) + :return (values (nreverse subseqs) right) + :else + :collect (subseq vector (1+ left) right) into subseqs + :and :sum 1 :into nr-elts :of-type fixnum + :until (< left start) + :finally (return (values (nreverse subseqs) (1+ left))))) + +(defun split-vector-from-start (position-fn vector start end count remove-empty-subseqs) + (declare (optimize (speed 3) (debug 0)) + (type vector vector) + (type (function (vector fixnum) (or null fixnum)) position-fn)) + (let ((length (length vector))) + (loop + :with end = (or end (length vector)) + :for left := start :then (1+ right) + :for right := (min (or (funcall position-fn vector left) length) + end) + :unless (and (= right left) remove-empty-subseqs) + :if (and count (>= nr-elts count)) + :return (values subseqs left) + :else + :collect (subseq vector left right) :into subseqs + :and :sum 1 :into nr-elts :of-type fixnum + :until (>= right end) + :finally (return (values subseqs right))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/version.sexp b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/version.sexp new file mode 100644 index 0000000..925cb56 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/split-sequence-v2.0.0/version.sexp @@ -0,0 +1,2 @@ +;; -*- lisp -*- +"2.0.0" diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/COPYING b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/COPYING new file mode 100644 index 0000000..fcb4fe7 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/COPYING @@ -0,0 +1,22 @@ + Copyright (c) 2005 David Lichteblau + Copyright (c) 2013 Anton Vodonosov + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation files + (the "Software"), to deal in the Software without restriction, + including without limitation the rights to use, copy, modify, merge, + publish, distribute, sublicense, and/or sell copies of the Software, + and to permit persons to whom the Software is furnished to do so, + subject to the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS + BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN + ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/Makefile b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/Makefile new file mode 100644 index 0000000..f6d297c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/Makefile @@ -0,0 +1,3 @@ +.PHONY: clean +clean: + rm -f *.fasl *.x86f *.fas *.ufsl *.lib *.pfsl diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/README b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/README new file mode 100644 index 0000000..4e49ce1 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/README @@ -0,0 +1,40 @@ +trivial-gray-streams +==================== + +Gray streams is an interface proposed for inclusion with ANSI CL +by David N. Gray in Issue STREAM-DEFINITION-BY-USER +(http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html). +The proposal did not make it into ANSI CL, but most popular +CL implementations implement this facility anyway. + +This system provides an extremely thin compatibility layer for gray +streams. + +How to use it +============= + +Use the package TRIVIAL-GRAY-STREAMS to refer Gray stream +classes to inherit from, generic functions to implement. + +Extensions +========== + +The Gray proposal was made before the ANCI CL standard was finalized, +and was based on the Common Lisp The Language book. + +The book does not have cl:file-position, cl:read-sequence, cl:write-sequence +functions. That's why (we think) the Gray proposal does not specify +their counterparts: stream-file-position, stream-read-sequence, stream-write-sequence. + +trivial-gray-streams supports these functions: + +Generic function STREAM-READ-SEQUENCE (stream sequence start end &key) +Generic function STREAM-WRITE-SEQUENCE (stream sequence start end &key) + + Notice that we use two required arguments and allow additional + keyword arguments. Your methods on these function should have + compliant lambda lists: + (stream sequence start end &key) + +Generic function STREAM-FILE-POSITION (stream) => file position +Generic function (SETF STREAM-FILE-POSITION) (position-spec stream) => successp diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/build.xcvb b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/build.xcvb new file mode 100644 index 0000000..abd5622 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/build.xcvb @@ -0,0 +1,7 @@ +#+xcvb +(module + (:fullname "trivial-gray-streams" + :depends-on + ("package" + "streams") + :supersedes-asdf ("trivial-gray-streams"))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/package.lisp b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/package.lisp new file mode 100644 index 0000000..c5fac85 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/package.lisp @@ -0,0 +1,77 @@ +#+xcvb (module ()) + +(in-package :cl-user) + +#+:abcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :gray-streams)) + +#+(or cmu genera) +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :gray-streams)) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (fboundp 'excl:stream-write-string) + (require "streamc.fasl"))) + +#+(or ecl clasp) +(eval-when (:compile-toplevel :load-toplevel :execute) + (gray::redefine-cl-functions)) + +(macrolet + ((frob () + (let ((gray-class-symbols + '(#:fundamental-stream + #:fundamental-input-stream #:fundamental-output-stream + #:fundamental-character-stream #:fundamental-binary-stream + #:fundamental-character-input-stream #:fundamental-character-output-stream + #:fundamental-binary-input-stream #:fundamental-binary-output-stream)) + (gray-function-symbols + '(#:stream-read-char + #:stream-unread-char #:stream-read-char-no-hang + #:stream-peek-char #:stream-listen #:stream-read-line + #:stream-clear-input #:stream-write-char #:stream-line-column + #:stream-start-line-p #:stream-write-string #:stream-terpri + #:stream-fresh-line #:stream-finish-output #:stream-force-output + #:stream-clear-output #:stream-advance-to-column + #:stream-read-byte #:stream-write-byte))) + `(progn + + (defpackage impl-specific-gray + (:use :cl) + (:import-from + #+sbcl :sb-gray + #+allegro :excl + #+cmu :ext + #+(or clisp ecl mocl clasp) :gray + #+openmcl :ccl + #+lispworks :stream + #+(or abcl genera) :gray-streams + #-(or sbcl allegro cmu clisp openmcl lispworks ecl clasp abcl mocl genera) ... + ,@gray-class-symbols + ,@gray-function-symbols) + (:export + ,@gray-class-symbols + ,@gray-function-symbols)) + + (defpackage :trivial-gray-streams + (:use :cl) + (:import-from #:impl-specific-gray + ;; We import and re-export only + ;; function symbols; + ;; But we define our own classes + ;; mirroring the gray class hierarchy + ;; of the lisp implementation (this + ;; is necessary to define our methods + ;; for particular generic functions) + ,@gray-function-symbols) + (:export ,@gray-class-symbols + ,@gray-function-symbols + ;; extension functions + #:stream-read-sequence + #:stream-write-sequence + #:stream-file-position + ;; deprecated + #:trivial-gray-stream-mixin)))))) + (frob)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/streams.lisp b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/streams.lisp new file mode 100644 index 0000000..c4101d0 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/streams.lisp @@ -0,0 +1,292 @@ +#+xcvb (module (:depends-on ("package"))) + +(in-package :trivial-gray-streams) + +(defclass fundamental-stream (impl-specific-gray:fundamental-stream) ()) +(defclass fundamental-input-stream + (fundamental-stream impl-specific-gray:fundamental-input-stream) ()) +(defclass fundamental-output-stream + (fundamental-stream impl-specific-gray:fundamental-output-stream) ()) +(defclass fundamental-character-stream + (fundamental-stream impl-specific-gray:fundamental-character-stream) ()) +(defclass fundamental-binary-stream + (fundamental-stream impl-specific-gray:fundamental-binary-stream) ()) +(defclass fundamental-character-input-stream + (fundamental-input-stream fundamental-character-stream + impl-specific-gray:fundamental-character-input-stream) ()) +(defclass fundamental-character-output-stream + (fundamental-output-stream fundamental-character-stream + impl-specific-gray:fundamental-character-output-stream) ()) +(defclass fundamental-binary-input-stream + (fundamental-input-stream fundamental-binary-stream + impl-specific-gray:fundamental-binary-input-stream) ()) +(defclass fundamental-binary-output-stream + (fundamental-output-stream fundamental-binary-stream + impl-specific-gray:fundamental-binary-output-stream) ()) + +(defgeneric stream-read-sequence + (stream sequence start end &key &allow-other-keys)) +(defgeneric stream-write-sequence + (stream sequence start end &key &allow-other-keys)) + +(defgeneric stream-file-position (stream)) +(defgeneric (setf stream-file-position) (newval stream)) + +;;; Default methods for stream-read/write-sequence. +;;; +;;; It would be nice to implement default methods +;;; in trivial gray streams, maybe borrowing the code +;;; from some of CL implementations. But now, for +;;; simplicity we will fallback to default implementation +;;; of the implementation-specific analogue function which calls us. + +(defmethod stream-read-sequence ((stream fundamental-input-stream) seq start end &key) + (declare (ignore seq start end)) + 'fallback) + +(defmethod stream-write-sequence ((stream fundamental-output-stream) seq start end &key) + (declare (ignore seq start end)) + 'fallback) + +(defmacro or-fallback (&body body) + `(let ((result ,@body)) + (if (eq result (quote fallback)) + (call-next-method) + result))) + +;; Implementations should provide this default method, I believe, but +;; at least sbcl and allegro don't. +(defmethod stream-terpri ((stream fundamental-output-stream)) + (write-char #\newline stream)) + +;; stream-file-position could be specialized to +;; fundamental-stream, but to support backward +;; compatibility with flexi-streams, we specialize +;; it on T. The reason: flexi-streams calls stream-file-position +;; for non-gray stream: +;; https://github.com/edicl/flexi-streams/issues/4 +(defmethod stream-file-position ((stream t)) + nil) + +(defmethod (setf stream-file-position) (newval (stream t)) + (declare (ignore newval)) + nil) + +#+abcl +(progn + (defmethod gray-streams:stream-read-sequence + ((s fundamental-input-stream) seq &optional start end) + (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) + + (defmethod gray-streams:stream-write-sequence + ((s fundamental-output-stream) seq &optional start end) + (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) + + (defmethod gray-streams:stream-write-string + ((stream xp::xp-structure) string &optional (start 0) (end (length string))) + (xp::write-string+ string stream start end)) + + #+#.(cl:if (cl:and (cl:find-package :gray-streams) + (cl:find-symbol "STREAM-FILE-POSITION" :gray-streams)) + '(:and) + '(:or)) + (defmethod gray-streams:stream-file-position + ((s fundamental-stream) &optional position) + (if position + (setf (stream-file-position s) position) + (stream-file-position s)))) + +#+allegro +(progn + (defmethod excl:stream-read-sequence + ((s fundamental-input-stream) seq &optional start end) + (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) + + (defmethod excl:stream-write-sequence + ((s fundamental-output-stream) seq &optional start end) + (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) + + (defmethod excl::stream-file-position + ((stream fundamental-stream) &optional position) + (if position + (setf (stream-file-position stream) position) + (stream-file-position stream)))) + +;; Untill 2014-08-09 CMUCL did not have stream-file-position: +;; http://trac.common-lisp.net/cmucl/ticket/100 +#+cmu +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-symbol (string '#:stream-file-position) '#:ext) + (pushnew :cmu-has-stream-file-position *features*))) + +#+cmu +(progn + (defmethod ext:stream-read-sequence + ((s fundamental-input-stream) seq &optional start end) + (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) + (defmethod ext:stream-write-sequence + ((s fundamental-output-stream) seq &optional start end) + (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) + + #+cmu-has-stream-file-position + (defmethod ext:stream-file-position ((stream fundamental-stream)) + (stream-file-position stream)) + + #+cmu-has-stream-file-position + (defmethod (setf ext:stream-file-position) (position (stream fundamental-stream)) + (setf (stream-file-position stream) position))) + +#+lispworks +(progn + (defmethod stream:stream-read-sequence + ((s fundamental-input-stream) seq start end) + (or-fallback (stream-read-sequence s seq start end))) + (defmethod stream:stream-write-sequence + ((s fundamental-output-stream) seq start end) + (or-fallback (stream-write-sequence s seq start end))) + + (defmethod stream:stream-file-position ((stream fundamental-stream)) + (stream-file-position stream)) + (defmethod (setf stream:stream-file-position) + (newval (stream fundamental-stream)) + (setf (stream-file-position stream) newval))) + +#+openmcl +(progn + (defmethod ccl:stream-read-vector + ((s fundamental-input-stream) seq start end) + (or-fallback (stream-read-sequence s seq start end))) + (defmethod ccl:stream-write-vector + ((s fundamental-output-stream) seq start end) + (or-fallback (stream-write-sequence s seq start end))) + + (defmethod ccl:stream-read-list ((s fundamental-input-stream) list count) + (or-fallback (stream-read-sequence s list 0 count))) + (defmethod ccl:stream-write-list ((s fundamental-output-stream) list count) + (or-fallback (stream-write-sequence s list 0 count))) + + (defmethod ccl::stream-position ((stream fundamental-stream) &optional new-position) + (if new-position + (setf (stream-file-position stream) new-position) + (stream-file-position stream)))) + +;; up to version 2.43 there were no +;; stream-read-sequence, stream-write-sequence +;; functions in CLISP +#+clisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-symbol (string '#:stream-read-sequence) '#:gray) + (pushnew :clisp-has-stream-read/write-sequence *features*))) + +#+clisp +(progn + + #+clisp-has-stream-read/write-sequence + (defmethod gray:stream-read-sequence + (seq (s fundamental-input-stream) &key start end) + (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) + + #+clisp-has-stream-read/write-sequence + (defmethod gray:stream-write-sequence + (seq (s fundamental-output-stream) &key start end) + (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) + + ;;; for old CLISP + (defmethod gray:stream-read-byte-sequence + ((s fundamental-input-stream) + seq + &optional start end no-hang interactive) + (when no-hang + (error "this stream does not support the NO-HANG argument")) + (when interactive + (error "this stream does not support the INTERACTIVE argument")) + (or-fallback (stream-read-sequence s seq start end))) + + (defmethod gray:stream-write-byte-sequence + ((s fundamental-output-stream) + seq + &optional start end no-hang interactive) + (when no-hang + (error "this stream does not support the NO-HANG argument")) + (when interactive + (error "this stream does not support the INTERACTIVE argument")) + (or-fallback (stream-write-sequence s seq start end))) + + (defmethod gray:stream-read-char-sequence + ((s fundamental-input-stream) seq &optional start end) + (or-fallback (stream-read-sequence s seq start end))) + + (defmethod gray:stream-write-char-sequence + ((s fundamental-output-stream) seq &optional start end) + (or-fallback (stream-write-sequence s seq start end))) + + ;;; end of old CLISP read/write-sequence support + + (defmethod gray:stream-position ((stream fundamental-stream) position) + (if position + (setf (stream-file-position stream) position) + (stream-file-position stream)))) + +#+sbcl +(progn + (defmethod sb-gray:stream-read-sequence + ((s fundamental-input-stream) seq &optional start end) + (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) + (defmethod sb-gray:stream-write-sequence + ((s fundamental-output-stream) seq &optional start end) + (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) + (defmethod sb-gray:stream-file-position + ((stream fundamental-stream) &optional position) + (if position + (setf (stream-file-position stream) position) + (stream-file-position stream))) + ;; SBCL extension: + (defmethod sb-gray:stream-line-length ((stream fundamental-stream)) + 80)) + +#+(or ecl clasp) +(progn + (defmethod gray::stream-file-position + ((stream fundamental-stream) &optional position) + (if position + (setf (stream-file-position stream) position) + (stream-file-position stream))) + (defmethod gray:stream-read-sequence + ((s fundamental-input-stream) seq &optional start end) + (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) + (defmethod gray:stream-write-sequence + ((s fundamental-output-stream) seq &optional start end) + (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))) + +#+mocl +(progn + (defmethod gray:stream-read-sequence + ((s fundamental-input-stream) seq &optional start end) + (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) + (defmethod gray:stream-write-sequence + ((s fundamental-output-stream) seq &optional start end) + (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) + (defmethod gray:stream-file-position + ((stream fundamental-stream) &optional position) + (if position + (setf (stream-file-position stream) position) + (stream-file-position stream)))) + +#+genera +(progn + (defmethod gray-streams:stream-read-sequence + ((s fundamental-input-stream) seq &optional start end) + (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) + (defmethod gray-streams:stream-write-sequence + ((s fundamental-output-stream) seq &optional start end) + (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) + (defmethod gray-streams:stream-file-position + ((stream fundamental-stream)) + (stream-file-position stream)) + (defmethod (setf gray-streams:stream-file-position) + (position (stream fundamental-stream)) + (setf (stream-file-position stream) position))) + +;; deprecated +(defclass trivial-gray-stream-mixin () ()) + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/package.lisp b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/package.lisp new file mode 100644 index 0000000..e836637 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/package.lisp @@ -0,0 +1,6 @@ +(defpackage trivial-gray-streams-test + (:use :cl #:trivial-gray-streams) + (:shadow #:method) + (:export #:run-tests + #:failed-test-names)) + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/run-on-many-lisps.lisp b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/run-on-many-lisps.lisp new file mode 100644 index 0000000..9a2a9a3 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/run-on-many-lisps.lisp @@ -0,0 +1,66 @@ +(ql:quickload :trivial-gray-streams) +(ql:quickload :test-grid-agent) +(ql:quickload :cl-fad) +(in-package :cl-user) + +(defparameter *abcl* (make-instance 'lisp-exe:abcl + :java-exe-path "C:\\Program Files\\Java\\jdk1.6.0_26\\bin\\java" + :abcl-jar-path "C:\\Users\\anton\\unpacked\\abcl\\abcl-bin-1.1.0\\abcl.jar")) +(defparameter *clisp* (make-instance 'lisp-exe:clisp :exe-path "clisp")) +(defparameter *ccl-1.8-x86* (make-instance 'lisp-exe:ccl + :exe-path "C:\\Users\\anton\\unpacked\\ccl\\ccl-1.8-windows\\wx86cl.exe")) +(defparameter *ccl-1.8-x86-64* (make-instance 'lisp-exe:ccl + :exe-path "C:\\Users\\anton\\unpacked\\ccl\\ccl-1.8-windows\\wx86cl64.exe")) +(defparameter *sbcl-1.1.0.45* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files (x86)\\Steel Bank Common Lisp\\1.1.0.45\\run.bat")) +(defparameter *sbcl-win-branch-64* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files\\Steel Bank Common Lisp\\1.1.0.36.mswinmt.1201-284e340\\run.bat")) +(defparameter *sbcl-win-branch-32* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files (x86)\\Steel Bank Common Lisp\\1.1.0.36.mswinmt.1201-284e340\\run.bat")) +(defparameter *ecl-bytecode* (make-instance 'lisp-exe:ecl + :exe-path "C:\\Users\\anton\\projects\\ecl\\bin\\ecl.exe" + :compiler :bytecode)) +(defparameter *ecl-lisp-to-c* (make-instance 'lisp-exe:ecl + :exe-path "C:\\Users\\anton\\projects\\ecl\\bin\\ecl.exe" + :compiler :lisp-to-c)) +(defparameter *acl* (make-instance 'lisp-exe:acl :exe-path "C:\\Program Files (x86)\\acl90express\\alisp.exe")) + +(defun run-on-many-lisps (run-description test-run-dir quicklisp-dir lisps) + (ensure-directories-exist test-run-dir) + (let ((fasl-root (merge-pathnames "fasl/" test-run-dir))) + (labels ((log-name (lisp) + (substitute #\- #\. + ;; Substitute dots by hypens if our main process is CCL, it + ;; prepends the > symbol before dots; + ;; for example: 1.1.0.36.mswinmt.1201-284e340 => 1>.1>.0>.36>.mswinmt.1201-284e340 + ;; When we pass such a pathname to another lisps, they can't handle it. + (string-downcase (tg-agent::implementation-identifier lisp)))) + (fasl-dir (lisp) + (merge-pathnames (format nil "~A/" (log-name lisp)) + fasl-root)) + (run (lisp) + (let* ((lib-result (tg-agent::proc-run-libtest lisp + :trivial-gray-streams + run-description + (merge-pathnames (log-name lisp) test-run-dir) + quicklisp-dir + (fasl-dir lisp))) + (status (getf lib-result :status))) + (if (listp status) + (getf status :failed-tests) + status)))) + (let ((results (mapcar (lambda (lisp) + (list (tg-agent::implementation-identifier lisp) + (run lisp))) + lisps))) + (tg-utils::write-to-file results (merge-pathnames "resutls.lisp" test-run-dir)) + (cl-fad:delete-directory-and-files fasl-root) + results)))) + +(run-on-many-lisps '(:lib-world "quicklisp 2013-02-17 + trivial-gray-streams.head" + :contact-email "avodonosov@yandex.ru") + "C:\\Users\\anton\\projects\\trivial-gray-streams\\test\\" + (merge-pathnames "quicklisp/" (user-homedir-pathname)) + (list *sbcl-1.1.0.45* *sbcl-win-branch-64* *sbcl-win-branch-32* + *abcl* + *clisp* + *ccl-1.8-x86* *ccl-1.8-x86-64* + *ecl-bytecode* *ecl-lisp-to-c* + *acl*)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/test-framework.lisp b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/test-framework.lisp new file mode 100644 index 0000000..8f9717a --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/test-framework.lisp @@ -0,0 +1,60 @@ +(in-package :trivial-gray-streams-test) + +;;; test framework + +#| + Used like this: + + (list (test (add) (assert (= 5 (+ 2 2)))) + (test (mul) (assert (= 4 (* 2 2)))) + (test (subst) (assert (= 3 (- 4 2))))) + + => ;; list of test results, 2 failed 1 passed + (# + # + #) + +|# + +(defclass test-result () + ((name :type symbol + :initarg :name + :initform (error ":name is requierd") + :accessor name) + (status :type (or (eql :ok) (eql :fail)) + :initform :ok + :initarg :status + :accessor status) + (cause :type (or null condition) + :initform nil + :initarg :cause + :accessor cause))) + +(defun failed-p (test-result) + (eq (status test-result) :fail)) + +(defmethod print-object ((r test-result) stream) + (print-unreadable-object (r stream :type t) + (format stream "~S ~S~@[ ~A~]" (name r) (status r) (cause r)))) + +(defparameter *allow-debugger* nil) + +(defun test-impl (name body-fn) + (flet ((make-result (status &optional cause) + (make-instance 'test-result :name name :status status :cause cause))) + (handler-bind ((serious-condition + (lambda (c) + (unless *allow-debugger* + (format t "FAIL: ~A~%" c) + (let ((result (make-result :fail c))) + (return-from test-impl result)))))) + (format t "Running test ~S... " name) + (funcall body-fn) + (format t "OK~%") + (make-result :ok)))) + +(defmacro test ((name) &body body) + "If the BODY signals a SERIOUS-CONDITION +this macro returns a failed TEST-RESULT; otherwise +returns a successfull TEST-RESULT." + `(test-impl (quote ,name) (lambda () ,@body))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/test.lisp b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/test.lisp new file mode 100644 index 0000000..0baed1b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/test.lisp @@ -0,0 +1,213 @@ +(in-package :trivial-gray-streams-test) + +;;; assert-invoked - a tool to check that specified method with parameters has +;;; been invoked during execution of a code body + +(define-condition invoked () + ((method :type (or symbol cons) ;; cons is for (setf method) + :accessor method + :initarg :method + :initform (error ":method is required")) + (args :type list + :accessor args + :initarg :args + :initform nil))) + +(defun assert-invoked-impl (method args body-fn) + (let ((expected-invocation (cons method args)) + (actual-invocations nil)) + (handler-bind ((invoked (lambda (i) + (let ((invocation (cons (method i) (args i)))) + (when (equalp invocation expected-invocation) + (return-from assert-invoked-impl nil)) + (push invocation actual-invocations))))) + (funcall body-fn)) + (let ((*package* (find-package :keyword))) ; ensures package prefixes are printed + (error "expected invocation: ~(~S~) actual: ~{~(~S~)~^, ~}" + expected-invocation (reverse actual-invocations))))) + +(defmacro assert-invoked ((method &rest args) &body body) + "If during execution of the BODY the specified METHOD with ARGS +hasn't been invoked, signals an ERROR." + `(assert-invoked-impl (quote ,method) (list ,@args) (lambda () ,@body))) + +(defun invoked (method &rest args) + (signal 'invoked :method method :args args)) + +;;; The tests. + +#| + We will define a gray stream class, specialise + the gray generic function methods on it and test that the methods + are invoked when we call functions from common-lisp package + on that stream. + + Some of the gray generic functions are only invoked by default + methods of other generic functions: + + cl:format ~t or cl:pprint -> stream-advance-to-column -> stream-line-column + stream-write-char + cl:fresh-line -> stream-fresh-line -> stream-start-line-p -> stream-line-column + stream-terpri + + + If we define our methods for stream-advance-to-column and stream-fresh-line, + then stream-start-line-p, stream-terpri, stram-line-column are not invoked. + + Therefore we define another gray stream class. The first class is used + for all lower level functions (stream-terpri). The second class + is used to test methods for higher level functions (stream-fresh-line). +|# + +(defclass test-stream (fundamental-binary-input-stream + fundamental-binary-output-stream + fundamental-character-input-stream + fundamental-character-output-stream) + ()) + +(defclass test-stream2 (test-stream) ()) + +(defmethod stream-read-char ((stream test-stream)) + (invoked 'stream-read-char stream)) + +(defmethod stream-unread-char ((stream test-stream) char) + (invoked 'stream-unread-char stream char)) + +(defmethod stream-read-char-no-hang ((stream test-stream)) + (invoked 'stream-read-char-no-hang stream)) + +(defmethod stream-peek-char ((stream test-stream)) + (invoked 'stream-peek-char stream)) + +(defmethod stream-listen ((stream test-stream)) + (invoked 'stream-listen stream)) + +(defmethod stream-read-line ((stream test-stream)) + (invoked 'stream-read-line stream)) + +(defmethod stream-clear-input ((stream test-stream)) + (invoked 'stream-clear-input stream)) + +(defmethod stream-write-char ((stream test-stream) char) + (invoked 'stream-write-char stream char)) + +(defmethod stream-line-column ((stream test-stream)) + (invoked 'stream-line-column stream)) + +(defmethod stream-start-line-p ((stream test-stream)) + (invoked 'stream-start-line-p stream)) + +(defmethod stream-write-string ((stream test-stream) string &optional start end) + (invoked 'stream-write-string stream string start end)) + +(defmethod stream-terpri ((stream test-stream)) + (invoked 'stream-terpri stream)) + +(defmethod stream-fresh-line ((stream test-stream2)) + (invoked 'stream-fresh-line stream)) + +(defmethod stream-finish-output ((stream test-stream)) + (invoked 'stream-finish-output stream)) + +(defmethod stream-force-output ((stream test-stream)) + (invoked 'stream-force-output stream)) + +(defmethod stream-clear-output ((stream test-stream)) + (invoked 'stream-clear-output stream)) + +(defmethod stream-advance-to-column ((stream test-stream2) column) + (invoked 'stream-advance-to-column stream column)) + +(defmethod stream-read-byte ((stream test-stream)) + (invoked 'stream-read-byte stream)) + +(defmethod stream-write-byte ((stream test-stream) byte) + (invoked 'stream-write-byte stream byte)) + +(defmethod stream-read-sequence ((s test-stream) seq start end &key) + (invoked 'stream-read-sequence s seq :start start :end end)) + +(defmethod stream-write-sequence ((s test-stream) seq start end &key) + (invoked 'stream-write-sequence s seq :start start :end end)) + +(defmethod stream-file-position ((s test-stream)) + (invoked 'stream-file-position s)) + +(defmethod (setf stream-file-position) (newval (s test-stream)) + (invoked '(setf stream-file-position) newval s)) + +;; Convinience macro, used when we want to name +;; the test case with the same name as of the gray streams method we test. +(defmacro test-invoked ((method &rest args) &body body) + `(test (,method) + (assert-invoked (,method ,@args) + ,@body))) + +(defun run-tests () + (let ((s (make-instance 'test-stream)) + (s2 (make-instance 'test-stream2))) + (list + (test-invoked (stream-read-char s) + (read-char s)) + (test-invoked (stream-unread-char s #\a) + (unread-char #\a s)) + (test-invoked (stream-read-char-no-hang s) + (read-char-no-hang s)) + (test-invoked (stream-peek-char s) + (peek-char nil s)) + (test-invoked (stream-listen s) + (listen s)) + (test-invoked (stream-read-line s) + (read-line s)) + (test-invoked (stream-clear-input s) + (clear-input s)) + (test-invoked (stream-write-char s #\b) + (write-char #\b s)) + (test-invoked (stream-line-column s) + (format s "~10,t")) + (test-invoked (stream-start-line-p s) + (fresh-line s)) + (test-invoked (stream-write-string s "hello" 1 4) + (write-string "hello" s :start 1 :end 4)) + (test-invoked (stream-terpri s) + (fresh-line s)) + (test-invoked (stream-fresh-line s2) + (fresh-line s2)) + (test-invoked (stream-finish-output s) + (finish-output s)) + (test-invoked (stream-force-output s) + (force-output s)) + (test-invoked (stream-clear-output s) + (clear-output s)) + (test-invoked (stream-advance-to-column s2 10) + (format s2 "~10,t")) + (test-invoked (stream-read-byte s) + (read-byte s)) + (test-invoked (stream-write-byte s 1) + (write-byte 1 s)) + ;;; extensions + (let ((seq (vector 1 2))) + (test-invoked (stream-read-sequence s seq :start 0 :end 1) + (read-sequence seq s :start 0 :end 1)) + (test-invoked (stream-write-sequence s seq :start 0 :end 1) + (write-sequence seq s :start 0 :end 1))) + (test-invoked (stream-file-position s) + (file-position s)) + (test (setf-stream-file-position) + (assert-invoked ((setf stream-file-position) 9 s) + (file-position s 9)))))) + +(defun failed-tests (results) + (remove-if-not #'failed-p results)) + +(defun failed-test-names (results) + (mapcar (lambda (result) + (string-downcase (name result))) + (failed-tests results))) + +#| +(failed-test-names (run-tests)) + +(setf *allow-debugger* nil)) + +|# diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams-test.asd b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams-test.asd new file mode 100644 index 0000000..9eb6b74 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams-test.asd @@ -0,0 +1,10 @@ +;;; -*- mode: lisp -*- + +(defsystem :trivial-gray-streams-test + :version "2.0" + :depends-on (:trivial-gray-streams) + :pathname #P"test/" + :serial t + :components ((:file "package") + (:file "test-framework") + (:file "test"))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams.asd b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams.asd new file mode 100644 index 0000000..d57afff --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams.asd @@ -0,0 +1,10 @@ +;;; -*- mode: lisp -*- + +(defsystem :trivial-gray-streams + :description "Compatibility layer for Gray Streams (see http://www.cliki.net/Gray%20streams)." + :license "MIT" + :author "David Lichteblau" + :maintainer "Anton Vodonosov " + :version "2.0" + :serial t + :components ((:file "package") (:file "streams"))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/.gitignore b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/.gitignore new file mode 100644 index 0000000..b25c15b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/.gitignore @@ -0,0 +1 @@ +*~ diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/CHANGES b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/CHANGES new file mode 100644 index 0000000..00eadb5 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/CHANGES @@ -0,0 +1,211 @@ +0.8.3: + + * New experimental backend: Mezzano (contributed by Bruno Cichon, #51) + * Bugfix: WAIT-FOR-INPUT fails to honor :ready-only t (#57, thanks to @Reepca for reporting this issue) + * Bugfix: [ECL] Fix read-select in backend/sbcl.lisp to loop if interrupted (#54, #55, thanks to @thijs) + * [CCL] Fix compiling with (readtable-case readtable-case) of :invert. (#56, patch from @genworks) + * [Genera] added file attibutes (to all USOCKET lisp files) for Genera. + +0.8.2: (June 11, 2019) + + * General: now the HOST-OR-IP slot of NS-CONDITION has been exported. (#46) + * Bugfix: NS-HOST-NOT-FOUND-ERROR condition has unbound HOST-OR-IP slot (#46) + * Bugfix: [SBCL/LW] WAIT-FOR-INPUT waits only in the first call (when W-F-I is called with a single usocket, introduced in 0.8.0) (#50, thanks to @Hamayama for reporting/hints/testing this issue) + +0.8.1: (Feb 27, 2019) + +* New backend: clasp (patch from Christian Schafmeister, #45) +* Bugfix: [SBCL] fixed loading usocket.asd in SBCL 1.5.0 + +0.8.0: (Feb 4, 2019) + +* New backend (experimental): IOlib. (Push :USOCKET-IOLIB to *FEATURES* to enable this feature) +* New feature: Optimized WAIT-FOR-INPUT for single-socket case (one-time consing) +* New feature: Exported host-to-hostname (#42) +* Bugfix: [SBCL] more robust/thread-safe WAIT-FOR-INPUT-INTERNAL + +0.7.1: (Aug 31, 2018) + +* New feature: GET-(RANDOM)-HOST-BY-NAME (now exported) prefer IPv4 on mixed IPv4/IPv6 (suggested by Mark H. David) +* New backend: Symbolics Open Genera (Lisp machine) (patch from @Symbolics, #33) +* Bugfix: [CLISP] fixed issues in server sockets and error handling. (patch from @vibs29, #28, #29) +* Bugfix: [SBCL, ECL] Fix wait-for-input on Windows SBCL and ECL. (patch from Stas Boukarev, #30) +* Bugfix: [LW] fixed non-existing system calls in LW 5.0 (comm::socket-set-tcp-nodelay) + +0.7.0: (Oct 25, 2016) + +* General: Separated USOCKET and USOCKET-SERVER systems (only the server part depends on Portable-threads) +* General: USOCKET now depends on SPLIT-SEQUENCE (the exactly same vendor code is removed from usocket code base) +* New feature: [LW] (SOCKET-OPTION :TCP-NODELAY) and its SETF version now works on LispWorks 4/5/6/7. +* New feature: [LW] SOCKET-CONNECT now supports setting "tcp_nodelay" in version 4.x and 5.0. +* Bugfix: [CCL] fixed issues in SOCKET-SHUTDOWN +* Bugfix: [CLISP] fixed issues in WAIT-FOR-INPUT (Thanks to a patch by @vibs29, #27) +* Bugfix: [LW] fixed loading in version <= 6.0 (actually 0.6.5 only fixed loading in LW 6.1) +* Bugfix: [ECL] all compilation warnings were checked and fixed. + +0.6.5: (Oct 19, 2016) + +* New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for :SEND-TIMEOUT (thanks to John Pallister) +* Bugfix: Let (WAIT-FOR-INPUT NIL &TIMEOUT) return NIL with respect to TIMEOUT. +* Bugfix: [LW] fixed loading in LispWorks 5.x & 6.x. +* Bugfix: [LW] fixed SOCKET-SHUTDOWN in all versions. +* Bugfix: [ABCL] Fixed incorrect IPv6 addresses (#26), patch from Elias Mårtenson (lokedhs) + +0.6.4: (Mar 17, 2016) + +* New feature: [SBCL] IPv6 support (patch from Guillaume LE VAILLANT, #15) +* New feature: [API] SOCKET-SHUTDOWN added (patch from Thayne McCombs #9) +* New feature: [Corman] minimal initial support of this platform +* Bugfix: [SBCL/win32] wait-for-input nil-timeout bug (patch from Michal Herda, #13) +* Bugfix: [ECL] included unistd.h for gethostname() (patch from Daniel Kochmanski, #7) +* Bugfix: [LispWorks] SOCKET-RECEIVE now updates %READ-P (patch from Frank James) + +0.6.3: (May 23, 2015) + +* Bugfix: [CCL] Further fixed CCL-1.11 compatibility and a typo in SOCKET-CONNECT for CCL-1.10. +* Bugfix: [ECL] Fixed build in some versions. +* Bugfix: [LispWorks] SOCKET-SEND and SOCKET-RECEIVE now throw conditions if something goes wrong. + +0.6.2: (Apr 20, 2015) + +* Bugfix: [CCL] Fixed CCL-1.11 compatibility. +* Bugfix: [ECL] Fixed compatibility on recent versions. +* Bugfix: [LispWorks] Added support address-in-use-error condition on LW/Win32. (patch from Sergey Katrevich). + +0.6.1: (Jun 21, 2013) + +* New feature: [MOCL] Initial MOCL support (TCP only, no W-F-I, patch from github.com/Wukix/usocket). +* New feature: [MCL] Initial UDP support for Macintosh Common Lisp (MCL/RMCL). +* New feature: Added TCP-NO-DELAY (TCP_NODELAY) support in SOCKET-OPTION, for TCP client +* Bugfix: [CCL] Added (:external-format ccl:*default-external-format*) to SOCKET-CONNECT, to prevent it fallback to ISO-8859-1 on NIL. (Patch from Vsevolod Dyomkin) +* Bugfix: [CCL] Performance improved WAIT-FOR-INPUT and other fixes. (patch from Faré ) + +0.6.0: (Dec 26, 2012) + +* New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for seting and geting various socket options. +* New feature: SOCKET-SEND now support an CCL-like OFFSET keyword for sending only parts of the whole buffer. +* New feature: [ECL] Added support for ECL DFFI mode on Windows. (no need for C compilers now) +* Bugfix: [ECL] ECL now list sb-bsd-sockets as a dependency but relies on REQUIRE. (patched by Juanjo) +* Bugfix: [ABCL] Make USOCKET compile warning-free on ABCL again: MAKE-IMMEDIATE-OBJECT was deprecated a while ago in favor of 2 predefined constants. +* Bugfix: [LispWorks] remove redundant call to hcl:flag-special-free-action. (reported by Kamil Shakirov) +* Bugfix: [CLISP] improved HANDLE-CONDITION for more CLISP environments. + +0.5.5: (Feb 27, 2012) + +* Enhancement: SOCKET-CONNECT argument :nodelay can now set to :if-supported (patch from Anton Vodonosov). +* Enhancement: [Server] adding *remote-host* *remote-port* to socket-server stream handler functions (suggested by Matthew Curry) +* Bugfix: [LispWorks] Fixed UDP support for LispWorks 6.1 (patch from Camille Troillard by Martin Simmons). +* Bugfix: [LispWorks] Stop using hcl:add-special-free-action for reclaiming unused UDP socket fds to improve multi-threading stablity (suggested by Camille Troillard). +* Bugfix: [LispWorks] Fixed SOCKET-CONNECT on Windows, now LOCAL-PORT never have *auto-port* (0) as default value. + +0.5.4: (Oct 1, 2011) + +* Bugfix: [ECL] Fixed for ECL's MAKE-BUILD by removing some unecessary code (reported by Juan Jose Garcia-Ripoll, the ECL maintainer) +* Bugfix: [ACL] Fixed for Allegro CL modern mode. +* Bugfix: [SBCL] SOCKET-CONNECT on TCP won't call bind() when keyword arguments LOCAL-HOST or LOCAL-PORT is not set. (reported by Robert Brown) + +0.5.3: (Aug 13, 2011) + +* Bugfix: [MCL] Fixed SOCKET-LISTEN on vector addresses like #(0 0 0 0) +* Bugfix: [MCL] Fixed WAIT-FOR-INPUT on passive sockets (stream-server-usocket) +* Bugfix: [LispWorks] Fixed using OPEN-UDP-SOCKET in delivered applications (thanks to Camille Troillard and Martin Simmons, this fix is from LispWorks-UDP project). +* Bugfix: [SBCL] Fixed for "SBCL data flush problem", reported by Robert Brown and confirmed by Nikodemus Siivola. + +0.5.2: (May 11, 2011) + +* General: [SBCL] SOCKET-CONNECT's TIMEOUT argument was limited on non-Windows platforms. +* Bugfix: [CLISP] WAIT-FOR-INPUT now functions right (with/without READY-ONLY), this made Hunchentoot working on CLISP. (Thanks to Anton Vodonosov ) +* Bugfix: [ABCL] Fix SOCKET-ACCEPT to follow the documented API so that when called without an :ELEMENT-TYPE argument. (Thanks to Mark Evenson, the ABCL developer) +* Bugfix: [LispWorks] Fixed SOCKET-ACCEPT (Windows only) on WAIT-FOR-INPUTed sockets. +* Bugfix: [SBCL, ECL] Fixed wrongly STATE set/unset for WAIT-FOR-INPUT on Windows (report by Elliott Slaughter) +* Enhancement: Additional NAME keyword argument for SOCKET-SERVER for setting the server thread name. +* Enhancement: [ABCL] GET-ADDRESS now works with underlying IPv6 addresses. +* Enhancement: [CLISP] missing GET-LOCAL-* methods for STREAM-SERVER-USOCKET was now added. + +0.5.1: (Apr 2, 2011) + +* New feature: [CLISP] UDP (Datagram) support based on FFI (Win/Mac/Linux), no RAWSOCK needed. +* Enhancement: SOCKET-SERVER return a second value (socket) when calling in new-thread mode. +* Enhancement: [CLISP] Full support of DNS helper functions (GET-HOST-BY-NAME, ...) added. +* Enhancement: [CLISP] Better network error type detection based on OS error code. +* Enhancement: [LispWorks] Better network error type detection based on OS error code. +* Bugfix: Fixed wrong macro expansions of {IP|PORT}-{FROM|TO}-OCTET-BUFFER functions (since 0.4.0) +* Bugfix: SOCKET-CONNECT didn't set CONNECTED-P for datagram usockets on most backends. +* Bugfix: [SBCL] Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko +* Bugfix: [SBCL] Fixed SOCKET-SERVER (UDP) on SBCL due to a issue in SOCKET-CONNECT when HOST is NIL. +* Bugfix: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout". +* Bugfix: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL. +* Bugfix: [CLISP] Fixed and confirmed UDP (Datagram) support (RAWSOCK version). + +0.5.0: (Mar 12, 2011) + +* New supported platform: Macintosh Common Lisp (5.0 and up, plus RMCL) +* Support for UDP (datagram-usocket) was added (for all supported platform except MCL) +* Add WAIT-FOR-INPUT support for SBCL and ECL on win32. +* Simple TCP and UDP server API: SOCKET-SERVER +* Completely rewritten full-feature ABCL backends using latest Java interfaces +* Lots of bug fixed since 0.4.1 + +0.4.1: (Dec 27, 2008) + +* fixes for ECL, LispWorks, SBCL, SCL + +0.4.0: (Oct 28, 2008) + +* select()-like api: make a single thread wait for multiple sockets. +* various socket options for socket-creation with SOCKET-CONNECT. + +0.3.6: (Jun 21, 2008) + +* Code fixups based on advice from the ECL and OpenMCL maintainers. +* New exported symbols: WITH-MAPPED-CONDITIONS, NS-CONDITION, NS-ERROR, NS-UNKNOWN-ERROR and NS-UNKNOWN-CONDITION. + +0.3.4: (Jul 25, 2007) + +* Fix clisp get-host-name, multiple ECL fixes. + +0.3.3: (Jun 05, 2007) + +* Fix where host resolution routine was unable to resolve would return NIL instead of erroring. + +0.3.2: (Mar 04, 2007) + +* Fixes for many backends related to closing sockets. +* LispWorks fix for broken server sockets. +* API guarantee adjustments in preparation of porting Drakma. + +0.3.1: (Feb 28, 2007) + +* fixed with-server-socket; prevent creation of invalid sockets; 2 more convenience macros. + +0.3.0: (Jan 21, 2007) + +* Server sockets + +0.2.5: (Jan 19, 2007) + +* Allegro compilation fix. + +0.2.4: (Jan 17, 2007) + +* Various fixes for CMUCL, OpenMCL, Allegro and LispWorks. + +0.2.3: (Jan 04, 2007) + +* Add :element-type support to support stacking flexi-streams on socket streams for portable :external-format support. + +0.2.2: (Jan 03, 2007) + +* Add ECL support and a small SBCL bugfix. + +0.2.1: (Dec 21, 2006) + +* Remove 'open-stream' interface which is supposed to be provided by the 'trivial-usocket' package. + +0.2.0: (Dec 18, 2006) + +* Add support for Scieneer Common Lisp, fix issue #6 and API preparation for server side sockets (not in this release) + +0.1.0: (Feb 13, 2006) + +* Initial release diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/CONTRIBUTORS b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/CONTRIBUTORS new file mode 100644 index 0000000..fd761cd --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/CONTRIBUTORS @@ -0,0 +1,47 @@ +-*- Mode: outline -*- + +List of major USOCKET contributors: + +* Erik Enge +* Erik Huelsmann + - original authors + +* Chun Tian +* Hans Huebner + - current maintainers + +* Attila Lendvai + - better handling of unsupported Lisps + +* Vladimir Sekissov + - fixes for CMUCL implementation + +* Pierre Thierry + - added license information + +* Stelian Ionescu + - finished conversion from generic functions + - enabled running thread-safe code in unthreaded lisps + +* Douglas Crosher + - added Scieneer Common Lisp support + +* Frank James + - UDP fixes and test cases + +* Mark H. David + - UDP test cases + - Suggestions on fixing GET-HOST-BY-NAME and HOST-TO-HBO + +* Elliott Slaughter + - Advanced WAIT-FOR-INPUT test case + +* Anton Vodonosov + - CLISP fixes + +* Terje Norderhaug + - MCL vendor code + +* @Hamayama + + - Reporting/hints/testing of issue #50 (regression in 0.8.0, 0.8.1) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/LICENSE b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/LICENSE new file mode 100644 index 0000000..1b94618 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/LICENSE @@ -0,0 +1,25 @@ +(This is the MIT / X Consortium license as taken from + http://www.opensource.org/licenses/mit-license.html) + +Copyright (c) 2003 Erik Enge +Copyright (c) 2006-2007 Erik Huelsmann +Copyright (c) 2008-2019 Hans Hueber and Chun Tian + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/README.md b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/README.md new file mode 100644 index 0000000..b121c4a --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/README.md @@ -0,0 +1,148 @@ +## USOCKET - Universal socket library for Common Lisp + +https://common-lisp.net/project/usocket/ + +This is the usocket Common Lisp sockets library: a library to bring +sockets access to the broadest of common lisp implementations as possible. + +## The library currently supports: + +1. Allegro CL +2. ABCL (ArmedBear) +3. Clasp +4. Clozure CL +5. Corman Lisp +6. GNU CLISP +7. CMUCL +8. ECL +9. LispWorks (4.3 and up) +10. Digitool MCL and RMCL (5.0 and up) +11. Mezzano +12. MOCL +13. SBCL +14. Scieneer CL +15. Symbolics Lisp Machine (Genera) + +If your favorite common lisp misses in the list above, please contact +usocket-devel@common-lisp.net and submit a request. Please include +references to available sockets functions in your lisp implementation. + +The library has been ASDF (http://cliki.net/ASDF) enabled, meaning +that you can tar up a checkout and use that to ASDF-INSTALL:INSTALL +the package in your system package site. (Or use your usual ASDF +tricks to use the checkout directly.) + +## Remarks on licensing + +Even though the source code has an MIT style license attached to it, +when compiling this code with some of the supported lisp implementations +you may not end up with an MIT style binary version due to the licensing +of the implementations themselves. ECL is such an example and - when +it will become supported - GCL is like that too. + +## Non-support of :external-format + +Because of its definition in the hyperspec, there's no common +external-format between lisp implementations: every vendor has chosen +a different way to solve the problem of newline translation or +character set recoding. + +Because there's no way to avoid platform specific code in the application +when using external-format, the purpose of a portability layer gets +defeated. So, for now, usocket doesn't support external-format. + +The workaround to get reasonably portable external-format support is to +layer a flexi-stream (from flexi-streams) on top of a usocket stream. + +## API definition + + - usocket (class) + - stream-usocket (class; usocket derivative) + - stream-server-usocket (class; usocket derivative) + - socket-connect (function) [ to create an active/connected socket ] + socket-connect host port &key element-type + where `host' is a vectorized ip + or a string representation of a dotted ip address + or a hostname for lookup in the DNS system + - socket-listen (function) [ to create a passive/listening socket ] + socket-listen host port &key reuseaddress backlog element-type + where `host' has the same definition as above + - socket-accept (method) [ to create an active/connected socket ] + socket-accept socket &key element-type + returns (server side) a connected socket derived from a + listening/passive socket. + - socket-close (method) + socket-close socket + where socket a previously returned socket + - socket (usocket slot accessor), + the internal/implementation defined socket representation + - socket-stream (usocket slot accessor), + socket-stream socket + the return value of which satisfies the normal stream interface + - socket-shutdown + +### Errors: + - address-in-use-error + - address-not-available-error + - bad-file-descriptor-error + - connection-refused-error + - connection-aborted-error + - connection-reset-error + - invalid-argument-error + - no-buffers-error + - operation-not-supported-error + - operation-not-permitted-error + - protocol-not-supported-error + - socket-type-not-supported-error + - network-unreachable-error + - network-down-error + - network-reset-error + - host-down-error + - host-unreachable-error + - shutdown-error + - timeout-error + - unkown-error + +### Non-fatal conditions: + - interrupted-condition + - unkown-condition + +(for a description of the API methods and functions see + https://common-lisp.net/project/usocket/api-docs.shtml) + +## Test suite + +The test suite unfortunately isn't mature enough yet to run without +some manual configuration. Several elements are required which are +hard to programatically detect. Please adjust the test file before +running the tests, for these variables: + +- +non-existing-host+: The stringified IP address of a host on the + same subnet. No physical host may be present. +- +unused-local-port+: A port number of a port not in use on the + machine the tests run on. +- +common-lisp-net+: A vector with 4 integer elements which make up + an IP address. This must be the IP "common-lisp.net" resolves to. + +## Known problems + +- CMUCL error reporting wrt sockets raises only simple-errors + meaning there's no way to tell different error conditions apart. + All errors are mapped to unknown-error on CMUCL. + +- The ArmedBear backend doesn't do any error mapping (yet). Java + defines exceptions at the wrong level (IMO), since the exception + reported bares a relation to the function failing, not the actual + error that occurred: for example 'Address already in use' (when + creating a passive socket) is reported as a BindException with + an error text of 'Address already in use'. There's no way to sanely + map 'BindException' to a meaningfull error in usocket. [This does not + mean the backend should not at least map to 'unknown-error'!] + +- When using the library with ECL, you need the C compiler installed + to be able to compile and load the Foreign Function Interface. + Not all ECL targets support DFFI yet, so on some targets this would + be the case anyway. By depending on this technique, usocket can + reuse the FFI code on all platforms (including Windows). This benefit + currently outweighs the additional requirement. (hey, it's *Embeddable* + Common Lisp, so, you probably wanted to embed it all along, right?) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/TODO b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/TODO new file mode 100644 index 0000000..e631798 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/TODO @@ -0,0 +1,5 @@ +- Fix condition systems (making all implementation generate same error) +- Add INET6 support. +- IOlib backend + +For more TODO items, see http://trac.common-lisp.net/usocket/report. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/.gitignore b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/.gitignore new file mode 100644 index 0000000..b25c15b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/.gitignore @@ -0,0 +1 @@ +*~ diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/abcl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/abcl.lisp new file mode 100644 index 0000000..d73c552 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/abcl.lisp @@ -0,0 +1,436 @@ +;;;; New ABCL networking support (replacement to old armedbear.lisp) +;;;; Author: Chun Tian (binghe) + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;;; Java Classes ($*...) +(defvar $*boolean (jclass "boolean")) +(defvar $*byte (jclass "byte")) +(defvar $*byte[] (jclass "[B")) +(defvar $*int (jclass "int")) +(defvar $*long (jclass "long")) +(defvar $*|Byte| (jclass "java.lang.Byte")) +(defvar $*DatagramChannel (jclass "java.nio.channels.DatagramChannel")) +(defvar $*DatagramPacket (jclass "java.net.DatagramPacket")) +(defvar $*DatagramSocket (jclass "java.net.DatagramSocket")) +(defvar $*Inet4Address (jclass "java.net.Inet4Address")) +(defvar $*InetAddress (jclass "java.net.InetAddress")) +(defvar $*InetSocketAddress (jclass "java.net.InetSocketAddress")) +(defvar $*Iterator (jclass "java.util.Iterator")) +(defvar $*SelectableChannel (jclass "java.nio.channels.SelectableChannel")) +(defvar $*SelectionKey (jclass "java.nio.channels.SelectionKey")) +(defvar $*Selector (jclass "java.nio.channels.Selector")) +(defvar $*ServerSocket (jclass "java.net.ServerSocket")) +(defvar $*ServerSocketChannel (jclass "java.nio.channels.ServerSocketChannel")) +(defvar $*Set (jclass "java.util.Set")) +(defvar $*Socket (jclass "java.net.Socket")) +(defvar $*SocketAddress (jclass "java.net.SocketAddress")) +(defvar $*SocketChannel (jclass "java.nio.channels.SocketChannel")) +(defvar $*String (jclass "java.lang.String")) + +;;; Java Constructor ($%.../n) +(defvar $%Byte/0 (jconstructor $*|Byte| $*byte)) +(defvar $%DatagramPacket/3 (jconstructor $*DatagramPacket $*byte[] $*int $*int)) +(defvar $%DatagramPacket/5 (jconstructor $*DatagramPacket $*byte[] $*int $*int $*InetAddress $*int)) +(defvar $%DatagramSocket/0 (jconstructor $*DatagramSocket)) +(defvar $%DatagramSocket/1 (jconstructor $*DatagramSocket $*int)) +(defvar $%DatagramSocket/2 (jconstructor $*DatagramSocket $*int $*InetAddress)) +(defvar $%InetSocketAddress/1 (jconstructor $*InetSocketAddress $*int)) +(defvar $%InetSocketAddress/2 (jconstructor $*InetSocketAddress $*InetAddress $*int)) +(defvar $%ServerSocket/0 (jconstructor $*ServerSocket)) +(defvar $%ServerSocket/1 (jconstructor $*ServerSocket $*int)) +(defvar $%ServerSocket/2 (jconstructor $*ServerSocket $*int $*int)) +(defvar $%ServerSocket/3 (jconstructor $*ServerSocket $*int $*int $*InetAddress)) +(defvar $%Socket/0 (jconstructor $*Socket)) +(defvar $%Socket/2 (jconstructor $*Socket $*InetAddress $*int)) +(defvar $%Socket/4 (jconstructor $*Socket $*InetAddress $*int $*InetAddress $*int)) + +;;; Java Methods ($@...[/Class]/n) +(defvar $@accept/0 (jmethod $*ServerSocket "accept")) +(defvar $@bind/DatagramSocket/1 (jmethod $*DatagramSocket "bind" $*SocketAddress)) +(defvar $@bind/ServerSocket/1 (jmethod $*ServerSocket "bind" $*SocketAddress)) +(defvar $@bind/ServerSocket/2 (jmethod $*ServerSocket "bind" $*SocketAddress $*int)) +(defvar $@bind/Socket/1 (jmethod $*Socket "bind" $*SocketAddress)) +(defvar $@byteValue/0 (jmethod $*|Byte| "byteValue")) +(defvar $@channel/0 (jmethod $*SelectionKey "channel")) +(defvar $@close/DatagramSocket/0 (jmethod $*DatagramSocket "close")) +(defvar $@close/Selector/0 (jmethod $*Selector "close")) +(defvar $@close/ServerSocket/0 (jmethod $*ServerSocket "close")) +(defvar $@close/Socket/0 (jmethod $*Socket "close")) +(defvar $@shutdownInput/Socket/0 (jmethod $*Socket "shutdownInput")) +(defvar $@shutdownOutput/Socket/0 (jmethod $*Socket "shutdownOutput")) +(defvar $@configureBlocking/1 (jmethod $*SelectableChannel "configureBlocking" $*boolean)) +(defvar $@connect/DatagramChannel/1 (jmethod $*DatagramChannel "connect" $*SocketAddress)) +(defvar $@connect/Socket/1 (jmethod $*Socket "connect" $*SocketAddress)) +(defvar $@connect/Socket/2 (jmethod $*Socket "connect" $*SocketAddress $*int)) +(defvar $@connect/SocketChannel/1 (jmethod $*SocketChannel "connect" $*SocketAddress)) +(defvar $@getAddress/0 (jmethod $*InetAddress "getAddress")) +(defvar $@getAllByName/1 (jmethod $*InetAddress "getAllByName" $*String)) +(defvar $@getByName/1 (jmethod $*InetAddress "getByName" $*String)) +(defvar $@getChannel/DatagramSocket/0 (jmethod $*DatagramSocket "getChannel")) +(defvar $@getChannel/ServerSocket/0 (jmethod $*ServerSocket "getChannel")) +(defvar $@getChannel/Socket/0 (jmethod $*Socket "getChannel")) +(defvar $@getAddress/DatagramPacket/0 (jmethod $*DatagramPacket "getAddress")) +(defvar $@getHostName/0 (jmethod $*InetAddress "getHostName")) +(defvar $@getInetAddress/DatagramSocket/0 (jmethod $*DatagramSocket "getInetAddress")) +(defvar $@getInetAddress/ServerSocket/0 (jmethod $*ServerSocket "getInetAddress")) +(defvar $@getInetAddress/Socket/0 (jmethod $*Socket "getInetAddress")) +(defvar $@getLength/DatagramPacket/0 (jmethod $*DatagramPacket "getLength")) +(defvar $@getLocalAddress/DatagramSocket/0 (jmethod $*DatagramSocket "getLocalAddress")) +(defvar $@getLocalAddress/Socket/0 (jmethod $*Socket "getLocalAddress")) +(defvar $@getLocalPort/DatagramSocket/0 (jmethod $*DatagramSocket "getLocalPort")) +(defvar $@getLocalPort/ServerSocket/0 (jmethod $*ServerSocket "getLocalPort")) +(defvar $@getLocalPort/Socket/0 (jmethod $*Socket "getLocalPort")) +(defvar $@getOffset/DatagramPacket/0 (jmethod $*DatagramPacket "getOffset")) +(defvar $@getPort/DatagramPacket/0 (jmethod $*DatagramPacket "getPort")) +(defvar $@getPort/DatagramSocket/0 (jmethod $*DatagramSocket "getPort")) +(defvar $@getPort/Socket/0 (jmethod $*Socket "getPort")) +(defvar $@hasNext/0 (jmethod $*Iterator "hasNext")) +(defvar $@iterator/0 (jmethod $*Set "iterator")) +(defvar $@next/0 (jmethod $*Iterator "next")) +(defvar $@open/DatagramChannel/0 (jmethod $*DatagramChannel "open")) +(defvar $@open/Selector/0 (jmethod $*Selector "open")) +(defvar $@open/ServerSocketChannel/0 (jmethod $*ServerSocketChannel "open")) +(defvar $@open/SocketChannel/0 (jmethod $*SocketChannel "open")) +(defvar $@receive/1 (jmethod $*DatagramSocket "receive" $*DatagramPacket)) +(defvar $@register/2 (jmethod $*SelectableChannel "register" $*Selector $*int)) +(defvar $@select/0 (jmethod $*Selector "select")) +(defvar $@select/1 (jmethod $*Selector "select" $*long)) +(defvar $@selectedKeys/0 (jmethod $*Selector "selectedKeys")) +(defvar $@send/1 (jmethod $*DatagramSocket "send" $*DatagramPacket)) +(defvar $@setReuseAddress/1 (jmethod $*ServerSocket "setReuseAddress" $*boolean)) +(defvar $@setSoTimeout/DatagramSocket/1 (jmethod $*DatagramSocket "setSoTimeout" $*int)) +(defvar $@setSoTimeout/Socket/1 (jmethod $*Socket "setSoTimeout" $*int)) +(defvar $@setTcpNoDelay/1 (jmethod $*Socket "setTcpNoDelay" $*boolean)) +(defvar $@socket/DatagramChannel/0 (jmethod $*DatagramChannel "socket")) +(defvar $@socket/ServerSocketChannel/0 (jmethod $*ServerSocketChannel "socket")) +(defvar $@socket/SocketChannel/0 (jmethod $*SocketChannel "socket")) +(defvar $@validOps/0 (jmethod $*SelectableChannel "validOps")) + +;;; Java Field Variables ($+...) +(defvar $+op-accept (jfield $*SelectionKey "OP_ACCEPT")) +(defvar $+op-connect (jfield $*SelectionKey "OP_CONNECT")) +(defvar $+op-read (jfield $*SelectionKey "OP_READ")) +(defvar $+op-write (jfield $*SelectionKey "OP_WRITE")) + + +;;; Wrapper functions (return-type: java-object) +(defun %get-address (address) + (jcall $@getAddress/0 address)) +(defun %get-all-by-name (string) ; return a simple vector + (jstatic $@getAllByName/1 $*InetAddress string)) +(defun %get-by-name (string) + (jstatic $@getByName/1 $*InetAddress string)) + +(defun host-to-inet4 (host) + "USOCKET host formats to Java Inet4Address, used internally." + (%get-by-name (host-to-hostname host))) + +;;; HANDLE-CONTITION + +(defparameter +abcl-error-map+ + `(("java.net.BindException" . operation-not-permitted-error) + ("java.net.ConnectException" . connection-refused-error) + ("java.net.NoRouteToHostException" . network-unreachable-error) ; untested + ("java.net.PortUnreachableException" . protocol-not-supported-error) ; untested + ("java.net.ProtocolException" . protocol-not-supported-error) ; untested + ("java.net.SocketException" . socket-type-not-supported-error) ; untested + ("java.net.SocketTimeoutException" . timeout-error))) + +(defparameter +abcl-nameserver-error-map+ + `(("java.net.UnknownHostException" . ns-host-not-found-error))) + +(defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) + (typecase condition + (java-exception + (let ((java-cause (java-exception-cause condition))) + (let* ((usock-error (cdr (assoc (jclass-of java-cause) +abcl-error-map+ + :test #'string=))) + (usock-error (if (functionp usock-error) + (funcall usock-error condition) + usock-error)) + (nameserver-error (cdr (assoc (jclass-of java-cause) +abcl-nameserver-error-map+ + :test #'string=)))) + (if nameserver-error + (error nameserver-error :socket socket :host-or-ip host-or-ip) + (when usock-error + (error usock-error :socket socket)))))))) + +;;; GET-HOSTS-BY-NAME + +(defun get-address (address) + (when address + (let* ((array (%get-address address)) + (length (jarray-length array))) + (labels ((jbyte (n) + (let ((byte (jarray-ref array n))) + (if (minusp byte) (+ 256 byte) byte)))) + (cond + ((= 4 length) + (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3))) + ((= 16 length) + (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3) + (jbyte 4) (jbyte 5) (jbyte 6) (jbyte 7) + (jbyte 8) (jbyte 9) (jbyte 10) (jbyte 11) + (jbyte 12) (jbyte 13) (jbyte 14) (jbyte 15))) + (t nil)))))) ; neither a IPv4 nor IPv6 address?! + +(defun get-hosts-by-name (name) + (with-mapped-conditions (nil name) + (map 'list #'get-address (%get-all-by-name name)))) + +;;; GET-HOST-BY-ADDRESS + +(defun get-host-by-address (host) + (let ((inet4 (host-to-inet4 host))) + (with-mapped-conditions (nil host) + (jcall $@getHostName/0 inet4)))) + +;;; SOCKET-CONNECT + +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) + timeout deadline (nodelay t nodelay-supplied-p) + local-host local-port) + (when deadline (unsupported 'deadline 'socket-connect)) + (let (socket stream usocket) + (ecase protocol + (:stream ; TCP + (let ((channel (jstatic $@open/SocketChannel/0 $*SocketChannel)) + (address (jnew $%InetSocketAddress/2 (host-to-inet4 host) port))) + (setq socket (jcall $@socket/SocketChannel/0 channel)) + ;; bind to local address if needed + (when (or local-host local-port) + (let ((local-address (jnew $%InetSocketAddress/2 (host-to-inet4 local-host) (or local-port 0)))) + (with-mapped-conditions (nil host) + (jcall $@bind/Socket/1 socket local-address)))) + ;; connect to dest address + (with-mapped-conditions (nil host) + (jcall $@connect/SocketChannel/1 channel address)) + (setq stream (ext:get-socket-stream socket :element-type element-type) + usocket (make-stream-socket :stream stream :socket socket)) + (when nodelay-supplied-p + (jcall $@setTcpNoDelay/1 socket (if nodelay ;; both t and :if-supported mean java:+true+ + java:+true+ java:+false+))) + (when timeout + (jcall $@setSoTimeout/Socket/1 socket (truncate (* 1000 timeout)))))) + (:datagram ; UDP + (let ((channel (jstatic $@open/DatagramChannel/0 $*DatagramChannel))) + (setq socket (jcall $@socket/DatagramChannel/0 channel)) + ;; bind to local address if needed + (when (or local-host local-port) + (let ((local-address (jnew $%InetSocketAddress/2 (host-to-inet4 local-host) (or local-port 0)))) + (with-mapped-conditions (nil local-host) + (jcall $@bind/DatagramSocket/1 socket local-address)))) + ;; connect to dest address if needed + (when (and host port) + (let ((address (jnew $%InetSocketAddress/2 (host-to-inet4 host) port))) + (with-mapped-conditions (nil host) + (jcall $@connect/DatagramChannel/1 channel address)))) + (setq usocket (make-datagram-socket socket :connected-p (if (and host port) t nil))) + (when timeout + (jcall $@setSoTimeout/DatagramSocket/1 socket (truncate (* 1000 timeout))))))) + usocket)) + +;;; SOCKET-LISTEN + +(defun socket-listen (host port &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5 backlog-supplied-p) + (element-type 'character)) + (declare (type boolean reuse-address)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (channel (jstatic $@open/ServerSocketChannel/0 $*ServerSocketChannel)) + (socket (jcall $@socket/ServerSocketChannel/0 channel)) + (endpoint (jnew $%InetSocketAddress/2 (host-to-inet4 host) (or port 0)))) + (jcall $@setReuseAddress/1 socket (if reuseaddress java:+true+ java:+false+)) + (with-mapped-conditions (socket host) + (if backlog-supplied-p + (jcall $@bind/ServerSocket/2 socket endpoint backlog) + (jcall $@bind/ServerSocket/1 socket endpoint))) + (make-stream-server-socket socket :element-type element-type))) + +;;; SOCKET-ACCEPT + +(defmethod socket-accept ((usocket stream-server-usocket) + &key (element-type 'character element-type-p)) + (with-mapped-conditions (usocket) + (let* ((client-socket (jcall $@accept/0 (socket usocket))) + (element-type (if element-type-p + element-type + (element-type usocket))) + (stream (ext:get-socket-stream client-socket :element-type element-type))) + (make-stream-socket :stream stream :socket client-socket)))) + +;;; SOCKET-CLOSE + +(defmethod socket-close ((usocket stream-server-usocket)) + (with-mapped-conditions (usocket) + (jcall $@close/ServerSocket/0 (socket usocket)))) + +(defmethod socket-close ((usocket stream-usocket)) + (with-mapped-conditions (usocket) + (close (socket-stream usocket)) + (jcall $@close/Socket/0 (socket usocket)))) + +(defmethod socket-close ((usocket datagram-usocket)) + (with-mapped-conditions (usocket) + (jcall $@close/DatagramSocket/0 (socket usocket)))) + +(defmethod socket-shutdown ((usocket stream-usocket) direction) + (with-mapped-conditions (usocket) + (ecase direction + (:input + (jcall $@shutdownInput/Socket/0 (socket usocket))) + (:output + (jcall $@shutdownOutput/Socket/0 (socket usocket)))))) + +;;; GET-LOCAL/PEER-NAME/ADDRESS/PORT + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defmethod get-local-address ((usocket stream-usocket)) + (get-address (jcall $@getLocalAddress/Socket/0 (socket usocket)))) + +(defmethod get-local-address ((usocket stream-server-usocket)) + (get-address (jcall $@getInetAddress/ServerSocket/0 (socket usocket)))) + +(defmethod get-local-address ((usocket datagram-usocket)) + (get-address (jcall $@getLocalAddress/DatagramSocket/0 (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (get-address (jcall $@getInetAddress/Socket/0 (socket usocket)))) + +(defmethod get-peer-address ((usocket datagram-usocket)) + (get-address (jcall $@getInetAddress/DatagramSocket/0 (socket usocket)))) + +(defmethod get-local-port ((usocket stream-usocket)) + (jcall $@getLocalPort/Socket/0 (socket usocket))) + +(defmethod get-local-port ((usocket stream-server-usocket)) + (jcall $@getLocalPort/ServerSocket/0 (socket usocket))) + +(defmethod get-local-port ((usocket datagram-usocket)) + (jcall $@getLocalPort/DatagramSocket/0 (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (jcall $@getPort/Socket/0 (socket usocket))) + +(defmethod get-peer-port ((usocket datagram-usocket)) + (jcall $@getPort/DatagramSocket/0 (socket usocket))) + +;;; SOCKET-SEND & SOCKET-RECEIVE + +(defun *->byte (data) + (declare (type (unsigned-byte 8) data)) ; required by SOCKET-SEND + (jnew $%Byte/0 (if (> data 127) (- data 256) data))) + +(defun byte->* (byte &optional (element-type '(unsigned-byte 8))) + (let* ((ub8 (if (minusp byte) (+ 256 byte) byte))) + (if (eq element-type 'character) + (code-char ub8) + ub8))) + +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) + (let* ((socket (socket usocket)) + (byte-array (jnew-array $*byte size)) + (packet (if (and host port) + (jnew $%DatagramPacket/5 byte-array 0 size (host-to-inet4 host) port) + (jnew $%DatagramPacket/3 byte-array 0 size)))) + ;; prepare sending data + (loop for i from offset below (+ size offset) + do (setf (jarray-ref byte-array i) (*->byte (aref buffer i)))) + (with-mapped-conditions (usocket host) + (jcall $@send/1 socket packet)))) + +;;; TODO: return-host and return-port cannot be get ... +(defmethod socket-receive ((usocket datagram-usocket) buffer length + &key (element-type '(unsigned-byte 8))) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port + (let* ((socket (socket usocket)) + (real-length (or length +max-datagram-packet-size+)) + (byte-array (jnew-array $*byte real-length)) + (packet (jnew $%DatagramPacket/3 byte-array 0 real-length))) + (with-mapped-conditions (usocket) + (jcall $@receive/1 socket packet)) + (let* ((receive-length (jcall $@getLength/DatagramPacket/0 packet)) + (return-buffer (or buffer (make-array receive-length :element-type element-type)))) + (loop for i from 0 below receive-length + do (setf (aref return-buffer i) + (byte->* (jarray-ref byte-array i) element-type))) + (let ((return-host (if (connected-p usocket) + (get-peer-address usocket) + (get-address (jcall $@getAddress/DatagramPacket/0 packet)))) + (return-port (if (connected-p usocket) + (get-peer-port usocket) + (jcall $@getPort/DatagramPacket/0 packet)))) + (values return-buffer + receive-length + return-host + return-port))))) + +;;; WAIT-FOR-INPUT + +(defun socket-channel-class (usocket) + (cond ((stream-usocket-p usocket) $*SocketChannel) + ((stream-server-usocket-p usocket) $*ServerSocketChannel) + ((datagram-usocket-p usocket) $*DatagramChannel))) + +(defun get-socket-channel (usocket) + (let ((method (cond ((stream-usocket-p usocket) $@getChannel/Socket/0) + ((stream-server-usocket-p usocket) $@getChannel/ServerSocket/0) + ((datagram-usocket-p usocket) $@getChannel/DatagramSocket/0)))) + (jcall method (socket usocket)))) + +(defun wait-for-input-internal (wait-list &key timeout) + (let* ((sockets (wait-list-waiters wait-list)) + (ops (logior $+op-read $+op-accept)) + (selector (jstatic $@open/Selector/0 $*Selector)) + (channels (mapcar #'get-socket-channel sockets))) + (unwind-protect + (with-mapped-conditions () + (dolist (channel channels) + (jcall $@configureBlocking/1 channel java:+false+) + (jcall $@register/2 channel selector (logand ops (jcall $@validOps/0 channel)))) + (let ((ready-count (if timeout + (jcall $@select/1 selector (truncate (* timeout 1000))) + (jcall $@select/0 selector)))) + (when (plusp ready-count) + (let* ((keys (jcall $@selectedKeys/0 selector)) + (iterator (jcall $@iterator/0 keys)) + (%wait (wait-list-%wait wait-list))) + (loop while (jcall $@hasNext/0 iterator) + do (let* ((key (jcall $@next/0 iterator)) + (channel (jcall $@channel/0 key))) + (setf (state (gethash channel %wait)) :read))))))) + (jcall $@close/Selector/0 selector) + (dolist (channel channels) + (jcall $@configureBlocking/1 channel java:+true+))))) + +;;; WAIT-LIST + +;;; NOTE from original worker (Erik): +;;; Note that even though Java has the concept of the Selector class, which +;;; remotely looks like a wait-list, it requires the sockets to be non-blocking. +;;; usocket however doesn't make any such guarantees and is therefore unable to +;;; use the concept outside of the waiting routine itself (blergh!). + +(defun %setup-wait-list (wl) + (setf (wait-list-%wait wl) + (make-hash-table :test #'equal :rehash-size 1.3d0))) + +(defun %add-waiter (wl w) + (setf (gethash (get-socket-channel w) (wait-list-%wait wl)) w)) + +(defun %remove-waiter (wl w) + (remhash (get-socket-channel w) (wait-list-%wait wl))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/allegro.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/allegro.lisp new file mode 100644 index 0000000..4af38af --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/allegro.lisp @@ -0,0 +1,228 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +#+cormanlisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :acl-socket)) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + ;; for wait-for-input: + (require :process) + ;; note: the line below requires ACL 6.2+ + (require :osi)) + +(defun get-host-name () + ;; note: the line below requires ACL 7.0+ to actually *work* on windows + #+allegro (excl.osi:gethostname) + #+cormanlisp "") + +(defparameter +allegro-identifier-error-map+ + '((:address-in-use . address-in-use-error) + (:address-not-available . address-not-available-error) + (:network-down . network-down-error) + (:network-reset . network-reset-error) + (:network-unreachable . network-unreachable-error) + (:connection-aborted . connection-aborted-error) + (:connection-reset . connection-reset-error) + (:no-buffer-space . no-buffers-error) + (:shutdown . shutdown-error) + (:connection-timed-out . timeout-error) + (:connection-refused . connection-refused-error) + (:host-down . host-down-error) + (:host-unreachable . host-unreachable-error))) + +;; TODO: what's the error class of Corman Lisp? +(defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) + "Dispatch correct usocket condition." + (typecase condition + #+allegro + (excl:socket-error + (let ((usock-error + (cdr (assoc (excl:stream-error-identifier condition) + +allegro-identifier-error-map+)))) + (declare (type symbol usock-error)) + (if usock-error + (cond ((subtypep usock-error 'ns-error) + (error usock-error :socket socket :host-or-ip host-or-ip)) + (t + (error usock-error :socket socket))) + (error 'unknown-error + :real-error condition + :socket socket)))))) + +(defun to-format (element-type) + (if (subtypep element-type 'character) + :text + :binary)) + +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) + timeout deadline + (nodelay t) ;; nodelay == t is the ACL default + local-host local-port) + (when timeout (unsupported 'timeout 'socket-connect)) + (when deadline (unsupported 'deadline 'socket-connect)) + (when (eq nodelay :if-supported) + (setf nodelay t)) + + (let ((socket)) + (setf socket + (with-mapped-conditions (socket (or host local-host)) + (ecase protocol + (:stream + (labels ((make-socket () + (socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :local-host (when local-host + (host-to-hostname local-host)) + :local-port local-port + :format (to-format element-type) + :nodelay nodelay))) + #+allegro + (if timeout + (mp:with-timeout (timeout nil) + (make-socket)) + (make-socket)) + #+cormanlisp (make-socket))) + (:datagram + (apply #'socket:make-socket + (nconc (list :type protocol + :address-family :internet + :local-host (when local-host + (host-to-hostname local-host)) + :local-port local-port + :format (to-format element-type)) + (if (and host port) + (list :connect :active + :remote-host (host-to-hostname host) + :remote-port port) + (list :connect :passive)))))))) + (ecase protocol + (:stream + (make-stream-socket :socket socket :stream socket)) + (:datagram + (make-datagram-socket socket :connected-p (and host port t)))))) + +;; One socket close method is sufficient, +;; because socket-streams are also sockets. +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defmethod socket-shutdown ((usocket stream-usocket) direction) + (with-mapped-conditions (usocket) + (socket:shutdown (socket usocket) :direction direction))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + ;; Allegro and OpenMCL socket interfaces bear very strong resemblence + ;; whatever you change here, change it also for OpenMCL + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (sock (with-mapped-conditions (nil host) + (apply #'socket:make-socket + (append (list :connect :passive + :reuse-address reuseaddress + :local-port port + :backlog backlog + :format (to-format element-type) + ;; allegro now ignores :format + ) + (when (ip/= host *wildcard-host*) + (list :local-host host))))))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (declare (ignore element-type)) ;; allegro streams are multivalent + (let ((stream-sock + (with-mapped-conditions (socket) + (socket:accept-connection (socket socket))))) + (make-stream-socket :socket stream-sock :stream stream-sock))) + +(defmethod get-local-address ((usocket usocket)) + (hbo-to-vector-quad (socket:local-host (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (hbo-to-vector-quad (socket:remote-host (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (socket:local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + #+allegro + (socket:remote-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +#+allegro +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) + (with-mapped-conditions (usocket host) + (let ((s (socket usocket))) + (socket:send-to s + (if (zerop offset) + buffer + (subseq buffer offset (+ offset size))) + size + :remote-host host + :remote-port port)))) + +#+allegro +(defmethod socket-receive ((usocket datagram-usocket) buffer length &key) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port + (with-mapped-conditions (usocket) + (let ((s (socket usocket))) + (socket:receive-from s length :buffer buffer :extract t)))) + +(defun get-host-by-address (address) + (with-mapped-conditions (nil address) + (socket:ipaddr-to-hostname (host-to-hbo address)))) + +(defun get-hosts-by-name (name) + ;;###FIXME: ACL has the acldns module which returns all A records + ;; only problem: it doesn't fall back to tcp (from udp) if the returned + ;; structure is too long. + (with-mapped-conditions (nil name) + (list (hbo-to-vector-quad (socket:lookup-hostname + (host-to-hostname name)))))) + +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (push (socket waiter) (wait-list-%wait wait-list))) + +(defun %remove-waiter (wait-list waiter) + (setf (wait-list-%wait wait-list) + (remove (socket waiter) (wait-list-%wait wait-list)))) + +#+allegro +(defun wait-for-input-internal (wait-list &key timeout) + (with-mapped-conditions () + (let ((active-internal-sockets + (if timeout + (mp:wait-for-input-available (wait-list-%wait wait-list) + :timeout timeout) + (mp:wait-for-input-available (wait-list-%wait wait-list))))) + ;; this is quadratic, but hey, the active-internal-sockets + ;; list is very short and it's only quadratic in the length of that one. + ;; When I have more time I could recode it to something of linear + ;; complexity. + ;; [Same code is also used in openmcl.lisp] + (dolist (x active-internal-sockets) + (setf (state (gethash x (wait-list-map wait-list))) + :read)) + wait-list))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clasp.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clasp.lisp new file mode 100644 index 0000000..6a41eb0 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clasp.lisp @@ -0,0 +1,158 @@ +(in-package :usocket) + +#-clasp +(progn + #-:wsock + (ffi:clines + "#include " + "#include " + "#include ") + #+:wsock + (ffi:clines + "#ifndef FD_SETSIZE" + "#define FD_SETSIZE 1024" + "#endif" + "#include ") + (ffi:clines + #+:msvc "#include " + #-:msvc "#include " + "#include ")) +(progn + #-clasp + (defun cerrno () + (ffi:c-inline () () :int + "errno" :one-liner t)) + #+clasp + (defun cerrno () + (sockets-internal:errno)) + + #-clasp + (defun fd-setsize () + (ffi:c-inline () () :fixnum + "FD_SETSIZE" :one-liner t)) + #+clasp + (defun fd-setsize () (sockets-internal:fd-setsize)) + + #-clasp + (defun fdset-alloc () + (ffi:c-inline () () :pointer-void + "ecl_alloc_atomic(sizeof(fd_set))" :one-liner t)) + #+clasp (defun fdset-alloc () (sockets-internal::alloc-atomic-sizeof-fd-set)) + + #-clasp + (defun fdset-zero (fdset) + (ffi:c-inline (fdset) (:pointer-void) :void + "FD_ZERO((fd_set*)#0)" :one-liner t)) + #+clasp(defun fdset-zero (fdset) (sockets-internal:fdset-zero fdset)) + + #-clasp + (defun fdset-set (fdset fd) + (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void + "FD_SET(#1,(fd_set*)#0)" :one-liner t)) + #+clasp(defun fdset-set (fdset fd) (sockets-internal:fdset-set fd fdset)) + + #-clasp + (defun fdset-clr (fdset fd) + (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void + "FD_CLR(#1,(fd_set*)#0)" :one-liner t)) + #+clasp(defun fdset-clr (fdset fd) (sockets-internal:fdset-clr fd fdset)) + + #-clasp + (defun fdset-fd-isset (fdset fd) + (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool + "FD_ISSET(#1,(fd_set*)#0)" :one-liner t)) + #+clasp(defun fdset-fd-isset (fdset fd) (sockets-internal:fdset-isset fd fdset)) + + (declaim (inline cerrno + fd-setsize + fdset-alloc + fdset-zero + fdset-set + fdset-clr + fdset-fd-isset)) + #-clasp + (defun get-host-name () + (ffi:c-inline + () () :object + "{ char *buf = (char *) ecl_alloc_atomic(257); + + if (gethostname(buf,256) == 0) + @(return) = make_simple_base_string(buf); + else + @(return) = Cnil; + }" :one-liner nil :side-effects nil)) + + #+clasp + (defun get-host-name () + (sockets-internal:get-host-name)) + + #-clasp + (defun read-select (wl to-secs &optional (to-musecs 0)) + (let* ((sockets (wait-list-waiters wl)) + (rfds (wait-list-%wait wl)) + (max-fd (reduce #'(lambda (x y) + (let ((sy (sb-bsd-sockets:socket-file-descriptor + (socket y)))) + (if (< x sy) sy x))) + (cdr sockets) + :initial-value (sb-bsd-sockets:socket-file-descriptor + (socket (car sockets)))))) + (fdset-zero rfds) + (dolist (sock sockets) + (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor + (socket sock)))) + (let ((count + (ffi:c-inline (to-secs to-musecs rfds max-fd) + (t :unsigned-int :pointer-void :int) + :int + " + int count; + struct timeval tv; + + if (#0 != Cnil) { + tv.tv_sec = fixnnint(#0); + tv.tv_usec = #1; + } + @(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL, + (#0 != Cnil) ? &tv : NULL); +" :one-liner nil))) + (cond + ((= 0 count) + (values nil nil)) + ((< count 0) + ;; check for EINTR and EAGAIN; these should not err + (values nil (cerrno))) + (t + (dolist (sock sockets) + (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor + (socket sock))) + (setf (state sock) :READ)))))))) + + #+clasp + (defun read-select (wl to-secs &optional (to-musecs 0)) + (let* ((sockets (wait-list-waiters wl)) + (rfds (wait-list-%wait wl)) + (max-fd (reduce #'(lambda (x y) + (let ((sy (sb-bsd-sockets:socket-file-descriptor + (socket y)))) + (if (< x sy) sy x))) + (cdr sockets) + :initial-value (sb-bsd-sockets:socket-file-descriptor + (socket (car sockets)))))) + (fdset-zero rfds) + (dolist (sock sockets) + (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor + (socket sock)))) + (let ((count (sockets-internal:do-select to-secs to-musecs rfds max-fd))) + (cond + ((= 0 count) + (values nil nil)) + ((< count 0) + ;; check for EINTR and EAGAIN; these should not err + (values nil (cerrno))) + (t + (dolist (sock sockets) + (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor + (socket sock))) + (setf (state sock) :READ)))))))) + ) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clisp.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clisp.lisp new file mode 100644 index 0000000..62970c9 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clisp.lisp @@ -0,0 +1,715 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + #-ffi + (warn "This image doesn't contain FFI package, GET-HOST-NAME won't work.") + #-(or ffi rawsock) + (warn "This image doesn't contain either FFI or RAWSOCK package, no UDP support.")) + +;; utility routine for looking up the current host name +#+ffi +(ffi:def-call-out get-host-name-internal + (:name "gethostname") + (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256)) + :OUT :ALLOCA) + (len ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + +(defun get-host-name () + #+ffi + (multiple-value-bind (retcode name) + (get-host-name-internal 256) + (when (= retcode 0) + name)) + #-ffi + "localhost") + +(defun get-host-by-address (address) + (with-mapped-conditions (nil address) + (let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address)))) + (posix:hostent-name hostent)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions (nil name) + (let ((hostent (posix:resolve-host-ipaddr name))) + (mapcar #'host-to-vector-quad + (posix:hostent-addr-list hostent))))) + +;; Format: ((UNIX Windows) . CONDITION) +(defparameter +clisp-error-map+ + #-win32 + `((:EADDRINUSE . address-in-use-error) + (:EADDRNOTAVAIL . address-not-available-error) + (:EBADF . bad-file-descriptor-error) + (:ECONNREFUSED . connection-refused-error) + (:ECONNRESET . connection-reset-error) + (:ECONNABORTED . connection-aborted-error) + (:EINVAL . invalid-argument-error) + (:ENOBUFS . no-buffers-error) + (:ENOMEM . out-of-memory-error) + (:ENOTSUP . operation-not-supported-error) + (:EPERM . operation-not-permitted-error) + (:EPROTONOSUPPORT . protocol-not-supported-error) + (:ESOCKTNOSUPPORT . socket-type-not-supported-error) + (:ENETUNREACH . network-unreachable-error) + (:ENETDOWN . network-down-error) + (:ENETRESET . network-reset-error) + (:ESHUTDOWN . already-shutdown-error) + (:ETIMEDOUT . timeout-error) + (:EHOSTDOWN . host-down-error) + (:EHOSTUNREACH . host-unreachable-error) + ;; when blocked reading, and we close our socket due to a timeout. + ;; POSIX.1 says that EAGAIN and EWOULDBLOCK may have the same values. + (:EAGAIN . timeout-error) + (:EWOULDBLOCK . timeout-error)) ;linux + #+win32 + `((:WSAEADDRINUSE . address-in-use-error) + (:WSAEADDRNOTAVAIL . address-not-available-error) + (:WSAEBADF . bad-file-descriptor-error) + (:WSAECONNREFUSED . connection-refused-error) + (:WSAECONNRESET . connection-reset-error) + (:WSAECONNABORTED . connection-aborted-error) + (:WSAEINVAL . invalid-argument-error) + (:WSAENOBUFS . no-buffers-error) + (:WSAENOMEM . out-of-memory-error) + (:WSAENOTSUP . operation-not-supported-error) + (:WSAEPERM . operation-not-permitted-error) + (:WSAEPROTONOSUPPORT . protocol-not-supported-error) + (:WSAESOCKTNOSUPPORT . socket-type-not-supported-error) + (:WSAENETUNREACH . network-unreachable-error) + (:WSAENETDOWN . network-down-error) + (:WSAENETRESET . network-reset-error) + (:WSAESHUTDOWN . already-shutdown-error) + (:WSAETIMEDOUT . timeout-error) + (:WSAEHOSTDOWN . host-down-error) + (:WSAEHOSTUNREACH . host-unreachable-error))) + +(defun parse-errno (condition) + "Returns a number or keyword if it can parse what is within parens, else NIL" + (let ((s (princ-to-string condition))) + (let ((pos1 (position #\( s)) + (pos2 (position #\) s))) + ;mac: number, linux: keyword + (ignore-errors + (if (digit-char-p (char s (1+ pos1))) + (parse-integer s :start (1+ pos1) :end pos2) + (let ((*package* (find-package "KEYWORD"))) + (car (read-from-string s t nil :start pos1 :end (1+ pos2))))))))) + +(defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) + "Dispatch a usocket condition instead of a CLISP specific one, if we can." + (let ((errno + (cond + ;clisp 2.49+ + ((typep condition (find-symbol "OS-STREAM-ERROR" "EXT")) + (parse-errno condition)) + ;clisp 2.49 + ((typep condition (find-symbol "SIMPLE-STREAM-ERROR" "SYSTEM")) + (car (simple-condition-format-arguments condition)))))) + (when errno + (let ((error-keyword (if (keywordp errno) errno #+ffi(os:errno errno)))) + (let ((usock-error (cdr (assoc error-keyword +clisp-error-map+)))) + (when usock-error + (if (subtypep usock-error 'error) + (cond ((subtypep usock-error 'ns-error) + (error usock-error :socket socket :host-or-ip host-or-ip)) + (t + (error usock-error :socket socket))) + (cond ((subtypep usock-error 'ns-condition) + (signal usock-error :socket socket :host-or-ip host-or-ip)) + (t + (signal usock-error :socket socket)))))))))) + +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) + timeout deadline (nodelay t nodelay-specified) + local-host local-port) + (declare (ignorable timeout local-host local-port)) + (when deadline (unsupported 'deadline 'socket-connect)) + (when (and nodelay-specified + (not (eq nodelay :if-supported))) + (unsupported 'nodelay 'socket-connect)) + (case protocol + (:stream + (let ((socket) + (hostname (host-to-hostname host))) + (with-mapped-conditions (socket host) + (setf socket + (if timeout + (socket:socket-connect port hostname + :element-type element-type + :buffered t + :timeout timeout) + (socket:socket-connect port hostname + :element-type element-type + :buffered t)))) + (make-stream-socket :socket socket + :stream socket))) ;; the socket is a stream too + (:datagram + #+(or rawsock ffi) + (with-mapped-conditions (nil (or host local-host)) + (socket-create-datagram (or local-port *auto-port*) + :local-host (or local-host *wildcard-host*) + :remote-host (and host (host-to-vector-quad host)) + :remote-port port)) + #-(or rawsock ffi) + (unsupported '(protocol :datagram) 'socket-connect)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + ;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to + ;; to explicitly turn it on; unfortunately, there's no way to turn it off... + (declare (ignore reuseaddress reuse-address reuse-address-supplied-p)) + (let ((sock (apply #'socket:socket-server + (append (list port + :backlog backlog) + (when (ip/= host *wildcard-host*) + (list :interface host)))))) + (with-mapped-conditions (nil host) + (make-stream-server-socket sock :element-type element-type)))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (let ((stream + (with-mapped-conditions (socket) + (socket:socket-accept (socket socket) + :element-type (or element-type + (element-type socket)))))) + (make-stream-socket :socket stream + :stream stream))) + +;; Only one close method required: +;; sockets and their associated streams +;; are the same object +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defmethod socket-close ((usocket stream-server-usocket)) + (socket:socket-server-close (socket usocket))) + +(defmethod socket-shutdown ((usocket stream-usocket) direction) + (with-mapped-conditions (usocket) + (socket:socket-stream-shutdown (socket usocket) direction))) + +(defmethod get-local-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (socket:socket-stream-local (socket usocket) t) + (values (dotted-quad-to-vector-quad address) port))) + +(defmethod get-local-name ((usocket stream-server-usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (socket:socket-stream-peer (socket usocket) t) + (values (dotted-quad-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-local-address ((usocket stream-server-usocket)) + (dotted-quad-to-vector-quad + (socket:socket-server-host (socket usocket)))) + +(defmethod get-peer-address ((usocket usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-local-port ((usocket stream-server-usocket)) + (socket:socket-server-port (socket usocket))) + +(defmethod get-peer-port ((usocket usocket)) + (nth-value 1 (get-peer-name usocket))) + +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + ;; clisp's #'socket-status takes a list whose elts look either like, + ;; (socket-stream direction . x) or like, + ;; (socket-server . x) + ;; and it replaces the x's. + (push (cons (socket waiter) + (cond ((stream-usocket-p waiter) (cons NIL NIL)) + (t NIL))) + (wait-list-%wait wait-list))) + +(defun %remove-waiter (wait-list waiter) + (setf (wait-list-%wait wait-list) + (remove (socket waiter) (wait-list-%wait wait-list) :key #'car))) + +(defmethod wait-for-input-internal (wait-list &key timeout) + (with-mapped-conditions () + (multiple-value-bind + (secs musecs) + (split-timeout (or timeout 1)) + (dolist (x (wait-list-%wait wait-list)) + (when (consp (cdr x)) ;it's a socket-stream not socket-server + (setf (cadr x) :INPUT))) + (let* ((request-list (wait-list-%wait wait-list)) + (status-list (if timeout + (socket:socket-status request-list secs musecs) + (socket:socket-status request-list))) + (sockets (wait-list-waiters wait-list))) + (do* ((x (pop sockets) (pop sockets)) + (y (cdr (last (pop status-list))) (cdr (last (pop status-list))))) + ((null x)) + (when (member y '(T :INPUT :EOF)) + (setf (state x) :READ))) + wait-list)))) + +;;; +;;; UDP/Datagram sockets (RAWSOCK version) +;;; + +#+rawsock +(progn + (defun make-sockaddr_in () + (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)) + + (declaim (inline fill-sockaddr_in)) + (defun fill-sockaddr_in (sockaddr_in ip port) + (port-to-octet-buffer port sockaddr_in) + (ip-to-octet-buffer ip sockaddr_in :start 2) + sockaddr_in) + + (defun socket-create-datagram (local-port + &key (local-host *wildcard-host*) + remote-host + remote-port) + (let ((sock (rawsock:socket :inet :dgram 0)) + (lsock_addr (fill-sockaddr_in (make-sockaddr_in) + local-host local-port)) + (rsock_addr (when remote-host + (fill-sockaddr_in (make-sockaddr_in) + remote-host (or remote-port + local-port))))) + (rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr)) + (when rsock_addr + (rawsock:connect sock (rawsock:make-sockaddr :inet rsock_addr))) + (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) + + (defmethod socket-receive ((socket datagram-usocket) buffer length &key) + "Returns the buffer, the number of octets copied into the buffer (received) +and the address of the sender as values." + (let* ((sock (socket socket)) + (sockaddr (rawsock:make-sockaddr :inet)) + (real-length (or length +max-datagram-packet-size+)) + (real-buffer (or buffer + (make-array real-length + :element-type '(unsigned-byte 8))))) + (let ((rv (rawsock:recvfrom sock real-buffer sockaddr + :start 0 :end real-length)) + (host 0) (port 0)) + (unless (connected-p socket) + (let ((data (rawsock:sockaddr-data sockaddr))) + (setq host (ip-from-octet-buffer data :start 4) + port (port-from-octet-buffer data :start 2)))) + (values (if buffer real-buffer (subseq real-buffer 0 rv)) + rv + host + port)))) + + (defmethod socket-send ((socket datagram-usocket) buffer size &key host port (offset 0)) + "Returns the number of octets sent." + (let* ((sock (socket socket)) + (sockaddr (when (and host port) + (rawsock:make-sockaddr :inet + (fill-sockaddr_in + (make-sockaddr_in) + (host-byte-order host) + port)))) + (real-size (min size +max-datagram-packet-size+)) + (real-buffer (if (typep buffer '(simple-array (unsigned-byte 8) (*))) + buffer + (make-array real-size + :element-type '(unsigned-byte 8) + :initial-contents (subseq buffer 0 real-size)))) + (rv (if (and host port) + (rawsock:sendto sock real-buffer sockaddr + :start offset + :end (+ offset real-size)) + (rawsock:send sock real-buffer + :start offset + :end (+ offset real-size))))) + rv)) + + (defmethod socket-close ((usocket datagram-usocket)) + (rawsock:sock-close (socket usocket))) + + (declaim (inline get-socket-name)) + (defun get-socket-name (socket function) + (let ((sockaddr (rawsock:make-sockaddr :inet (make-sockaddr_in)))) + (funcall function socket sockaddr) + (let ((data (rawsock:sockaddr-data sockaddr))) + (values (hbo-to-vector-quad (ip-from-octet-buffer data :start 2)) + (port-from-octet-buffer data :start 0))))) + + (defmethod get-local-name ((usocket datagram-usocket)) + (get-socket-name (socket usocket) 'rawsock:getsockname)) + + (defmethod get-peer-name ((usocket datagram-usocket)) + (get-socket-name (socket usocket) 'rawsock:getpeername)) + +) ; progn + +;;; +;;; UDP/Datagram sockets (FFI version) +;;; + +#+(and ffi (not rawsock)) +(progn + ;; C primitive types + (ffi:def-c-type socklen_t ffi:uint32) + + ;; C structures + (ffi:def-c-struct sockaddr + #+macos (sa_len ffi:uint8) + (sa_family #-macos ffi:ushort + #+macos ffi:uint8) + (sa_data (ffi:c-array ffi:char 14))) + + (ffi:def-c-struct sockaddr_in + #+macos (sin_len ffi:uint8) + (sin_family #-macos ffi:short + #+macos ffi:uint8) + (sin_port #-macos ffi:ushort + #+macos ffi:uint16) + (sin_addr ffi:uint32) + (sin_zero (ffi:c-array ffi:char 8))) + + (ffi:def-c-struct timeval + (tv_sec ffi:long) + (tv_usec ffi:long)) + + ;; foreign functions + (ffi:def-call-out %sendto (:name "sendto") + (:arguments (socket ffi:int) + (buffer ffi:c-pointer) + (length ffi:int) + (flags ffi:int) + (address (ffi:c-ptr sockaddr)) + (address-len ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %send (:name "send") + (:arguments (socket ffi:int) + (buffer ffi:c-pointer) + (length ffi:int) + (flags ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %recvfrom (:name "recvfrom") + (:arguments (socket ffi:int) + (buffer ffi:c-pointer) + (length ffi:int) + (flags ffi:int) + (address (ffi:c-ptr sockaddr) :in-out) + (address-len (ffi:c-ptr ffi:int) :in-out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %socket (:name "socket") + (:arguments (family ffi:int) + (type ffi:int) + (protocol ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %connect (:name "connect") + (:arguments (socket ffi:int) + (address (ffi:c-ptr sockaddr) :in) + (address_len socklen_t)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %bind (:name "bind") + (:arguments (socket ffi:int) + (address (ffi:c-ptr sockaddr) :in) + (address_len socklen_t)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %close (:name #-win32 "close" #+win32 "closesocket") + (:arguments (socket ffi:int)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %getsockopt (:name "getsockopt") + (:arguments (sockfd ffi:int) + (level ffi:int) + (optname ffi:int) + (optval ffi:c-pointer) + (optlen (ffi:c-ptr socklen_t) :out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %setsockopt (:name "setsockopt") + (:arguments (sockfd ffi:int) + (level ffi:int) + (optname ffi:int) + (optval ffi:c-pointer) + (optlen socklen_t)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %htonl (:name "htonl") + (:arguments (hostlong ffi:uint32)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:uint32)) + + (ffi:def-call-out %htons (:name "htons") + (:arguments (hostshort ffi:uint16)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:uint16)) + + (ffi:def-call-out %ntohl (:name "ntohl") + (:arguments (netlong ffi:uint32)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:uint32)) + + (ffi:def-call-out %ntohs (:name "ntohs") + (:arguments (netshort ffi:uint16)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:uint16)) + + (ffi:def-call-out %getsockname (:name "getsockname") + (:arguments (sockfd ffi:int) + (localaddr (ffi:c-ptr sockaddr) :in-out) + (addrlen (ffi:c-ptr socklen_t) :in-out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + (ffi:def-call-out %getpeername (:name "getpeername") + (:arguments (sockfd ffi:int) + (peeraddr (ffi:c-ptr sockaddr) :in-out) + (addrlen (ffi:c-ptr socklen_t) :in-out)) + #+win32 (:library "WS2_32") + #-win32 (:library :default) + (:language #-win32 :stdc + #+win32 :stdc-stdcall) + (:return-type ffi:int)) + + ;; socket constants + (defconstant +socket-af-inet+ 2) + (defconstant +socket-sock-dgram+ 2) + (defconstant +socket-ip-proto-udp+ 17) + + (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout") + + (defparameter *length-of-sockaddr_in* (ffi:sizeof 'sockaddr_in)) + + (declaim (inline fill-sockaddr_in)) + (defun fill-sockaddr_in (sockaddr host port) + (let ((hbo (host-to-hbo host))) + (ffi:with-c-place (place sockaddr) + #+macos + (setf (ffi:slot place 'sin_len) *length-of-sockaddr_in*) + (setf (ffi:slot place 'sin_family) +socket-af-inet+ + (ffi:slot place 'sin_port) (%htons port) + (ffi:slot place 'sin_addr) (%htonl hbo))) + sockaddr)) + + (defun socket-create-datagram (local-port + &key (local-host *wildcard-host*) + remote-host + remote-port) + (let ((sock (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-ip-proto-udp+)) + (lsock_addr (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) + local-host local-port)) + (rsock_addr (when remote-host + (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) + remote-host (or remote-port local-port))))) + (unless (plusp sock) + (error "SOCKET-CREATE-DATAGRAM ERROR (socket): ~A" (os:errno))) + (unwind-protect + (let ((rv (%bind sock (ffi:cast (ffi:foreign-value lsock_addr) 'sockaddr) + *length-of-sockaddr_in*))) + (unless (zerop rv) + (error "SOCKET-CREATE-DATAGRAM ERROR (bind): ~A" (os:errno))) + (when rsock_addr + (let ((rv (%connect sock + (ffi:cast (ffi:foreign-value rsock_addr) 'sockaddr) + *length-of-sockaddr_in*))) + (unless (zerop rv) + (error "SOCKET-CREATE-DATAGRAM ERROR (connect): ~A" (os:errno)))))) + (ffi:foreign-free lsock_addr) + (when remote-host + (ffi:foreign-free rsock_addr))) + (make-datagram-socket sock :connected-p (if rsock_addr t nil)))) + + (defun finalize-datagram-usocket (object) + (when (datagram-usocket-p object) + (socket-close object))) + + (defmethod initialize-instance :after ((usocket datagram-usocket) &key) + (setf (slot-value usocket 'recv-buffer) + (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+)) + ;; finalize the object + (ext:finalize usocket 'finalize-datagram-usocket)) + + (defmethod socket-close ((usocket datagram-usocket)) + (with-slots (recv-buffer socket) usocket + (ffi:foreign-free recv-buffer) + (zerop (%close socket)))) + + (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) + (let ((remote-address (ffi:allocate-shallow 'sockaddr_in)) + (remote-address-length (ffi:allocate-shallow 'ffi:int)) + nbytes (host 0) (port 0)) + (setf (ffi:foreign-value remote-address-length) + *length-of-sockaddr_in*) + (unwind-protect + (multiple-value-bind (n address address-length) + (%recvfrom (socket usocket) + (ffi:foreign-address (slot-value usocket 'recv-buffer)) + +max-datagram-packet-size+ + 0 ; flags + (ffi:cast (ffi:foreign-value remote-address) 'sockaddr) + (ffi:foreign-value remote-address-length)) + (when (minusp n) + (error "SOCKET-RECEIVE ERROR: ~A" (os:errno))) + (setq nbytes n) + (when (= address-length *length-of-sockaddr_in*) + (let ((data (sockaddr-sa_data address))) + (setq host (ip-from-octet-buffer data :start 2) + port (port-from-octet-buffer data)))) + (cond ((plusp n) + (let ((return-buffer (ffi:foreign-value (slot-value usocket 'recv-buffer)))) + (if buffer ; replace exist buffer of create new return buffer + (let ((end-1 (min (or length (length buffer)) +max-datagram-packet-size+)) + (end-2 (min n +max-datagram-packet-size+))) + (replace buffer return-buffer :end1 end-1 :end2 end-2)) + (setq buffer (subseq return-buffer 0 (min n +max-datagram-packet-size+)))))) + ((zerop n)))) + (ffi:foreign-free remote-address) + (ffi:foreign-free remote-address-length)) + (values buffer nbytes host port))) + + ;; implementation note: different from socket-receive, we know how many bytes we want to send everytime, + ;; so, a send buffer will not needed, and if there is a buffer, it's hard to fill its content like those + ;; in LispWorks. So, we allocate new foreign buffer for holding data (unknown sequence subtype) every time. + ;; + ;; I don't know if anyone is watching my coding work, but I think this design is reasonable for CLISP. + (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) + (declare (type sequence buffer) + (type (integer 0 *) size offset)) + (let ((remote-address + (when (and host port) + (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) host port))) + (send-buffer + (ffi:allocate-deep 'ffi:uint8 + (if (zerop offset) + buffer + (subseq buffer offset (+ offset size))) + :count size :read-only t)) + (real-size (min size +max-datagram-packet-size+)) + (nbytes 0)) + (unwind-protect + (let ((n (if remote-address + (%sendto (socket usocket) + (ffi:foreign-address send-buffer) + real-size + 0 ; flags + (ffi:cast (ffi:foreign-value remote-address) 'sockaddr) + *length-of-sockaddr_in*) + (%send (socket usocket) + (ffi:foreign-address send-buffer) + real-size + 0)))) + (cond ((plusp n) + (setq nbytes n)) + ((zerop n) + (setq nbytes n)) + (t (error "SOCKET-SEND ERROR: ~A" (os:errno))))) + (ffi:foreign-free send-buffer) + (when remote-address + (ffi:foreign-free remote-address)) + nbytes))) + + (declaim (inline get-socket-name)) + (defun get-socket-name (socket function) + (let ((address (ffi:allocate-shallow 'sockaddr_in)) + (address-length (ffi:allocate-shallow 'ffi:int)) + (host 0) (port 0)) + (setf (ffi:foreign-value address-length) *length-of-sockaddr_in*) + (unwind-protect + (multiple-value-bind (rv return-address return-address-length) + (funcall function socket + (ffi:cast (ffi:foreign-value address) 'sockaddr) + (ffi:foreign-value address-length)) + (declare (ignore return-address-length)) + (if (zerop rv) + (let ((data (sockaddr-sa_data return-address))) + (setq host (ip-from-octet-buffer data :start 2) + port (port-from-octet-buffer data))) + (error "GET-SOCKET-NAME ERROR: ~A" (os:errno)))) + (ffi:foreign-free address) + (ffi:foreign-free address-length)) + (values (hbo-to-vector-quad host) port))) + + (defmethod get-local-name ((usocket datagram-usocket)) + (get-socket-name (socket usocket) '%getsockname)) + + (defmethod get-peer-name ((usocket datagram-usocket)) + (get-socket-name (socket usocket) '%getpeername)) + +) ; progn diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clozure.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clozure.lisp new file mode 100644 index 0000000..7a1d620 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clozure.lisp @@ -0,0 +1,73 @@ +;;;; See LICENSE for licensing information. + +;;;; Functions for CCL 1.11 (IPv6) only, see openmcl.lisp for rest of functions. + +(in-package :usocket) + +#+ipv6 +(defun socket-connect (host port &key (protocol :stream) element-type + timeout deadline nodelay + local-host local-port) + (when (eq nodelay :if-supported) + (setf nodelay t)) + (with-mapped-conditions (nil host) + (let* ((remote (when (and host port) + (openmcl-socket:resolve-address :host (host-to-hostname host) + :port port + :socket-type protocol))) + (local (when (and local-host local-port) + (openmcl-socket:resolve-address :host (host-to-hostname local-host) + :port local-port + :socket-type protocol))) + (mcl-sock (apply #'openmcl-socket:make-socket + `(:type ,protocol + ,@(when (or remote local) + `(:address-family ,(openmcl-socket:socket-address-family (or remote local)))) + ,@(when remote + `(:remote-address ,remote)) + ,@(when local + `(:local-address ,local)) + :format ,(to-format element-type protocol) + :external-format ,ccl:*default-external-format* + :deadline ,deadline + :nodelay ,nodelay + :connect-timeout ,timeout + :input-timeout ,timeout)))) + (ecase protocol + (:stream + (make-stream-socket :stream mcl-sock :socket mcl-sock)) + (:datagram + (make-datagram-socket mcl-sock :connected-p (and remote t))))))) + +#+ipv6 +(defun socket-listen (host port + &key + (reuse-address nil reuse-address-supplied-p) + (reuseaddress (when reuse-address-supplied-p reuse-address)) + (backlog 5) + (element-type 'character)) + (let ((local-address (openmcl-socket:resolve-address :host (host-to-hostname host) + :port port :connect :passive))) + (with-mapped-conditions (nil host) + (make-stream-server-socket + (openmcl-socket:make-socket :connect :passive + :address-family (openmcl-socket:socket-address-family local-address) + :local-address local-address + :reuse-address reuseaddress + :backlog backlog + :format (to-format element-type :stream)) + :element-type element-type)))) + +#+ipv6 +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) + (let* ((ccl-socket (socket usocket)) + (socket-keys (ccl::socket-keys ccl-socket))) + (with-mapped-conditions (usocket host) + (if (and host port) + (openmcl-socket:send-to ccl-socket buffer size + :remote-host (host-to-hostname host) + :remote-port port + :offset offset) + (openmcl-socket:send-to ccl-socket buffer size + :remote-address (getf socket-keys :remote-address) + :offset offset))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/cmucl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/cmucl.lisp new file mode 100644 index 0000000..89627de --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/cmucl.lisp @@ -0,0 +1,298 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +#+win32 +(defun remap-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) + (+ 10000 y)) + (car x)) + (cdr x))) + z)) + +(defparameter +cmucl-error-map+ + #+win32 + (append (remap-for-win32 +unix-errno-condition-map+) + (remap-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun cmucl-map-socket-error (err &key condition socket host-or-ip) + (let ((usock-error + (cdr (assoc err +cmucl-error-map+ :test #'member)))) + (if usock-error + (if (subtypep usock-error 'error) + (cond ((subtypep usock-error 'ns-error) + (error usock-error :socket socket :host-or-ip host-or-ip)) + (t + (error usock-error :socket socket))) + (cond ((subtypep usock-error 'ns-condition) + (signal usock-error :socket socket :host-or-ip host-or-ip)) + (t + (signal usock-error :socket socket)))) + (error 'unknown-error + :socket socket + :real-error condition)))) + +;; CMUCL error handling is brain-dead: it doesn't preserve any +;; information other than the OS error string from which the +;; error can be determined. The OS error string isn't good enough +;; given that it may have been localized (l10n). +;; +;; The above applies to versions pre 19b; 19d and newer are expected to +;; contain even better error reporting. +;; +;; +;; Just catch the errors and encapsulate them in an unknown-error +(defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) + "Dispatch correct usocket condition." + (typecase condition + (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition) + :socket socket + :condition condition + :host-or-ip host-or-ip)))) + +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) + timeout deadline (nodelay t nodelay-specified) + (local-host nil local-host-p) + (local-port nil local-port-p) + &aux + (local-bind-p (fboundp 'ext::bind-inet-socket))) + (when timeout (unsupported 'timeout 'socket-connect)) + (when deadline (unsupported 'deadline 'socket-connect)) + (when (and nodelay-specified + (not (eq nodelay :if-supported))) + (unsupported 'nodelay 'socket-connect)) + (when (and local-host-p (not local-bind-p)) + (unsupported 'local-host 'socket-connect :minimum "Snapshot 2008-08 (19E)")) + (when (and local-port-p (not local-bind-p)) + (unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08 (19E)")) + + (let ((socket)) + (ecase protocol + (:stream + (setf socket + (let ((args (list (host-to-hbo host) port protocol))) + (when (and local-bind-p (or local-host-p local-port-p)) + (nconc args (list :local-host (when local-host + (host-to-hbo local-host)) + :local-port local-port))) + (with-mapped-conditions (socket host) + (apply #'ext:connect-to-inet-socket args)))) + (if socket + (let* ((stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full)) + ;;###FIXME the above line probably needs an :external-format + (usocket (make-stream-socket :socket socket + :stream stream))) + usocket) + (let ((err (unix:unix-errno))) + (when err (cmucl-map-socket-error err))))) + (:datagram + (setf socket + (if (and host port) + (let ((args (list (host-to-hbo host) port protocol))) + (when (and local-bind-p (or local-host-p local-port-p)) + (nconc args (list :local-host (when local-host + (host-to-hbo local-host)) + :local-port local-port))) + (with-mapped-conditions (socket (or host local-host)) + (apply #'ext:connect-to-inet-socket args))) + (if (or local-host-p local-port-p) + (with-mapped-conditions (socket (or host local-host)) + (apply #'ext:create-inet-listener + (nconc (list (or local-port 0) protocol) + (when (and local-host-p + (ip/= local-host *wildcard-host*)) + (list :host (host-to-hbo local-host)))))) + (with-mapped-conditions (socket (or host local-host)) + (ext:create-inet-socket protocol))))) + (if socket + (let ((usocket (make-datagram-socket socket :connected-p (and host port t)))) + (ext:finalize usocket #'(lambda () (when (%open-p usocket) + (ext:close-socket socket)))) + usocket) + (let ((err (unix:unix-errno))) + (when err (cmucl-map-socket-error err)))))))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (server-sock + (with-mapped-conditions (nil host) + (apply #'ext:create-inet-listener + (nconc (list port :stream + :backlog backlog + :reuse-address reuseaddress) + (when (ip/= host *wildcard-host*) + (list :host + (host-to-hbo host)))))))) + (make-stream-server-socket server-sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (with-mapped-conditions (usocket) + (let* ((sock (ext:accept-tcp-connection (socket usocket))) + (stream (sys:make-fd-stream sock :input t :output t + :element-type (or element-type + (element-type usocket)) + :buffering :full))) + (make-stream-socket :socket sock :stream stream)))) + +;; Sockets and socket streams are represented +;; by different objects. Be sure to close the +;; socket stream when closing a stream socket. +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (ext:close-socket (socket usocket)))) + +(defmethod socket-close :after ((socket datagram-usocket)) + (setf (%open-p socket) nil)) + +#+unicode +(defun %unix-send (fd buffer length flags) + (alien:alien-funcall + (alien:extern-alien "send" + (function c-call:int + c-call:int + system:system-area-pointer + c-call:int + c-call:int)) + fd + (system:vector-sap buffer) + length + flags)) + +(defmethod socket-shutdown ((usocket usocket) direction) + (with-mapped-conditions (usocket) + (ext:inet-shutdown (socket usocket) (ecase direction + (:input ext:shut-rd) + (:output ext:shut-wr))))) + +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0) + &aux (real-buffer (if (zerop offset) + buffer + (subseq buffer offset (+ offset size))))) + (with-mapped-conditions (usocket host) + (if (and host port) + (ext:inet-sendto (socket usocket) real-buffer size (host-to-hbo host) port) + #-unicode + (unix:unix-send (socket usocket) real-buffer size 0) + #+unicode + (%unix-send (socket usocket) real-buffer size 0)))) + +(defmethod socket-receive ((usocket datagram-usocket) buffer length &key) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port + (let ((real-buffer (or buffer + (make-array length :element-type '(unsigned-byte 8)))) + (real-length (or length + (length buffer)))) + (multiple-value-bind (nbytes remote-host remote-port) + (with-mapped-conditions (usocket) + (ext:inet-recvfrom (socket usocket) real-buffer real-length)) + (values real-buffer nbytes remote-host remote-port)))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (ext:get-socket-host-and-port (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (ext:get-peer-host-and-port (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun lookup-host-entry (host) + (multiple-value-bind + (entry errno) + (ext:lookup-host-entry host) + (if entry + entry + ;;###The constants below work on *most* OSes, but are defined as the + ;; constants mentioned in C + (let ((exception + (second (assoc errno + '((1 ns-host-not-found-error) ;; HOST_NOT_FOUND + (2 ns-no-recovery-error) ;; NO_DATA + (3 ns-no-recovery-error) ;; NO_RECOVERY + (4 ns-try-again-condition)))))) ;; TRY_AGAIN + (when exception + (error exception)))))) + + +(defun get-host-by-address (address) + (handler-case (ext:host-entry-name + (lookup-host-entry (host-byte-order address))) + (condition (condition) (handle-condition condition address)))) + +(defun get-hosts-by-name (name) + (handler-case (mapcar #'hbo-to-vector-quad + (ext:host-entry-addr-list + (lookup-host-entry name))) + (condition (condition) (handle-condition condition name)))) + +(defun get-host-name () + (unix:unix-gethostname)) + +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (push (socket waiter) (wait-list-%wait wait-list))) + +(defun %remove-waiter (wait-list waiter) + (setf (wait-list-%wait wait-list) + (remove (socket waiter) (wait-list-%wait wait-list)))) + +(defun wait-for-input-internal (wait-list &key timeout) + (with-mapped-conditions () + (alien:with-alien ((rfds (alien:struct unix:fd-set))) + (unix:fd-zero rfds) + (dolist (socket (wait-list-%wait wait-list)) + (unix:fd-set socket rfds)) + (multiple-value-bind + (secs musecs) + (split-timeout (or timeout 1)) + (multiple-value-bind (count err) + (unix:unix-fast-select (1+ (reduce #'max + (wait-list-%wait wait-list))) + (alien:addr rfds) nil nil + (when timeout secs) musecs) + (declare (ignore err)) + (if (<= 0 count) + ;; process the result... + (dolist (x (wait-list-waiters wait-list)) + (when (unix:fd-isset (socket x) rfds) + (setf (state x) :READ))) + (progn + ;;###FIXME generate an error, except for EINTR + ))))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/ecl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/ecl.lisp new file mode 100644 index 0000000..28ddd5a --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/ecl.lisp @@ -0,0 +1,152 @@ +;;;; -*- Mode: Lisp -*- + +;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only. +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +#+(and ecl-bytecmp windows) +(eval-when (:load-toplevel :execute) + (ffi:load-foreign-library "ws2_32.dll" :module "ws2_32")) + +#+(and ecl-bytecmp windows) +(progn + (ffi:def-function ("gethostname" c-gethostname) + ((name (* :unsigned-char)) + (len :int)) + :returning :int + :module "ws2_32") + + (defun get-host-name () + "Returns the hostname" + (ffi:with-foreign-object (name '(:array :unsigned-char 256)) + (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256)) + (ffi:convert-from-foreign-string name)))) + + (ffi:def-foreign-type ws-socket :unsigned-int) + (ffi:def-foreign-type ws-dword :unsigned-long) + (ffi:def-foreign-type ws-event :unsigned-int) + + (ffi:def-struct wsa-network-events + (network-events :long) + (error-code (:array :int 10))) + + (ffi:def-function ("WSACreateEvent" wsa-event-create) + () + :returning ws-event + :module "ws2_32") + + (ffi:def-function ("WSACloseEvent" c-wsa-event-close) + ((event-object ws-event)) + :returning :int + :module "ws2_32") + + (defun wsa-event-close (ws-event) + (not (zerop (c-wsa-event-close ws-event)))) + + (ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events) + ((socket ws-socket) + (event-object ws-event) + (network-events (* wsa-network-events))) + :returning :int + :module "ws2_32") + + (ffi:def-function ("WSAEventSelect" wsa-event-select) + ((socket ws-socket) + (event-object ws-event) + (network-events :long)) + :returning :int + :module "ws2_32") + + (ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events) + ((number-of-events ws-dword) + (events (* ws-event)) + (wait-all-p :int) + (timeout ws-dword) + (alertable-p :int)) + :returning ws-dword + :module "ws2_32") + + (defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p) + (c-wsa-wait-for-multiple-events number-of-events + events + (if wait-all-p -1 0) + timeout + (if alertable-p -1 0))) + + (ffi:def-function ("ioctlsocket" wsa-ioctlsocket) + ((socket ws-socket) + (cmd :long) + (argp (* :unsigned-long))) + :returning :int + :module "ws2_32") + + (ffi:def-function ("WSAGetLastError" wsa-get-last-error) + () + :returning :int + :module "ws2_32") + + (defun maybe-wsa-error (rv &optional socket) + (unless (zerop rv) + (raise-usock-err (wsa-get-last-error) socket))) + + (defun bytes-available-for-read (socket) + (ffi:with-foreign-object (int-ptr :unsigned-long) + (maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr) + socket) + (let ((int (ffi:deref-pointer int-ptr :unsigned-long))) + (prog1 int + (when (plusp int) + (setf (state socket) :read)))))) + + (defun map-network-events (func network-events) + (let ((event-map (ffi:get-slot-value network-events 'wsa-network-events 'network-events)) + (error-array (ffi:get-slot-pointer network-events 'wsa-network-events 'error-code))) + (unless (zerop event-map) + (dotimes (i fd-max-events) + (unless (zerop (ldb (byte 1 i) event-map)) + (funcall func (ffi:deref-array error-array '(:array :int 10) i))))))) + + (defun update-ready-and-state-slots (sockets) + (dolist (socket sockets) + (if (%ready-p socket) + (progn + (setf (state socket) :READ)) + (ffi:with-foreign-object (network-events 'wsa-network-events) + (let ((rv (wsa-enum-network-events (socket-handle socket) 0 network-events))) + (if (zerop rv) + (map-network-events + #'(lambda (err-code) + (if (zerop err-code) + (progn + (setf (state socket) :READ) + (when (stream-server-usocket-p socket) + (setf (%ready-p socket) t))) + (raise-usock-err err-code socket))) + network-events) + (maybe-wsa-error rv socket))))))) + + (defun os-wait-list-%wait (wait-list) + (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event)) + + (defun (setf os-wait-list-%wait) (value wait-list) + (setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value)) + + (defun free-wait-list (wl) + (when (wait-list-p wl) + (unless (null (wait-list-%wait wl)) + (wsa-event-close (os-wait-list-%wait wl)) + (ffi:free-foreign-object (wait-list-%wait wl)) + (setf (wait-list-%wait wl) nil)))) + + (defun %setup-wait-list (wait-list) + (setf (wait-list-%wait wait-list) + (ffi:allocate-foreign-object 'ws-event)) + (setf (os-wait-list-%wait wait-list) + (wsa-event-create)) + (ext:set-finalizer wait-list #'free-wait-list)) + + (defun os-socket-handle (usocket) + (socket-handle usocket)) + +) ; #+(and ecl-bytecmp windows) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/genera.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/genera.lisp new file mode 100644 index 0000000..0a12e8b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/genera.lisp @@ -0,0 +1,264 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: USOCKET; Base: 10 -*- + + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defclass genera-socket () + ((foreign-address :initform 0 :initarg :foreign-address :accessor gs-foreign-address) + (foreign-port :initform 0 :initarg :foreign-port :accessor gs-foreign-port) + (local-address :initform 0 :initarg :local-address :accessor gs-local-address) + (local-port :initform 0 :initarg :local-port :accessor gs-local-port)) + ) + +(defclass genera-stream-socket (genera-socket) + ((stream :initform nil :initarg :stream :accessor gs-stream)) + ) + +(defclass genera-stream-server-socket (genera-socket) + ((backlog :initform nil :initarg :backlog :accessor gs-backlog) + (element-type :initform nil :initarg :element-type :accessor gs-element-type) + (pending-connections :initform nil :accessor gs-pending-connections)) + ) + +(defclass genera-datagram-socket (genera-socket) + ((connection :initform nil :initarg :connection :accessor gs-connection)) + ) + +(defun host-to-host-object (host) + (let ((host (host-to-hostname host))) + (cond ((string-equal host "localhost") + net:*local-host*) + ((ip-address-string-p host) + (let ((quad (dotted-quad-to-vector-quad host))) + ;;---*** NOTE: This test is temporary until we have a loopback interface + (if (= (aref quad 0) 127) + net:*local-host* + (net:parse-host (format nil "INTERNET|~A" host))))) + (t + (net:parse-host host))))) + +(defun element-type-to-format (element-type protocol) + (cond ((null element-type) + (ecase protocol + (:stream :text) + (:datagram :binary))) + ((subtypep element-type 'character) + :text) + (t :binary))) + +(defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) + (typecase condition + ;;---*** TODO: Add additional conditions as appropriate + (sys:connection-refused + (error 'connection-refused-error :socket socket)) + ((or tcp::tcp-destination-unreachable-during-connection tcp::udp-destination-unreachable) + (error 'host-unreachable-error :socket socket)) + (sys:host-not-responding-during-connection + (error 'timeout-error :socket socket)) + (sys:unknown-host-name + (error 'ns-host-not-found-error :host-or-ip host-or-ip)) + (sys:network-error + (error 'unknown-error :socket socket :real-error condition :errno -1)))) + +(defun socket-connect (host port &key (protocol :stream) element-type + timeout deadline (nodelay nil nodelay-p) + local-host local-port) + (declare (ignore local-host)) + (when deadline + (unsupported 'deadline 'socket-connect)) + (when (and nodelay-p (not (eq nodelay :if-supported))) + (unsupported 'nodelay 'socket-connect)) + (with-mapped-conditions (nil host) + (ecase protocol + (:stream + (let* ((host-object (host-to-host-object host)) + (format (element-type-to-format element-type protocol)) + (characters (eq format :text)) + (timeout (if timeout + (* 60 timeout) + tcp:*tcp-connect-timeout*)) + (stream (tcp:open-tcp-stream host-object port local-port + :characters characters + :ascii-translation characters + :timeout timeout)) + (gs (make-instance 'genera-stream-socket + :stream stream))) + (setf (gs-foreign-address gs) (scl:send stream :foreign-address)) + (setf (gs-foreign-port gs) (scl:send stream :foreign-port)) + (setf (gs-local-address gs) (scl:send stream :local-address)) + (setf (gs-local-port gs) (scl:send stream :local-port)) + (make-stream-socket :socket gs :stream stream))) + (:datagram + ;;---*** TODO + (unsupported 'datagram 'socket-connect))))) + +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (socket-close (socket usocket)))) + +(defmethod socket-close ((socket genera-stream-socket)) + (with-slots (stream) socket + (when stream + (scl:send (shiftf stream nil) :close nil)))) + +(defmethod socket-close ((socket genera-stream-server-socket)) + (with-slots (local-port pending-connections) socket + (when local-port + (tcp:remove-tcp-port-listener local-port)) + (dolist (tcb pending-connections) + (tcp::reject-tcb tcb)))) + +(defmethod socket-close ((socket genera-datagram-socket)) + (with-slots (connection) socket + (when connection + (scl:send (shiftf connection nil) :close nil)) + ;;---*** TODO: listening? + )) + +;;; Cribbed from TCP::MAKE-TCB +(defun gensym-tcp-port () + (loop as number = (incf tcp::*last-gensym-port-number*) then tcp::*last-gensym-port-number* + do (cond ((loop for existing-tcb in tcp::*tcb-list* + thereis (= number (tcp::tcb-local-port existing-tcb)))) + ((and (<= #.(expt 2 10) number) (< number #.(expt 2 16))) + (return number)) + (t + (setq tcp::*last-gensym-port-number* #.(expt 2 10)))))) + +(defun socket-listen (host port &key (reuse-address nil reuse-address-p) + (reuseaddress nil reuseaddress-p) + (backlog 5) (element-type 'character)) + (let ((host-object (host-to-host-object host)) + (port (if (zerop port) (gensym-tcp-port) port)) + (reuse-address (cond (reuse-address-p reuse-address) + (reuseaddress-p reuseaddress) + (t nil)))) + (when (<= port 1024) + ;; Don't allow listening on "privileged" ports to mimic Unix/Linux semantics + (error 'operation-not-permitted-error :socket nil)) + (when (tcp:tcp-port-protocol-name port) + ;; Can't replace a Genera server + (error 'address-in-use-error :socket nil)) + (when (tcp:tcp-port-listener port) + (unless reuse-address + (error 'address-in-use-error :socket nil))) + (let ((gs (make-instance 'genera-stream-server-socket + :backlog backlog + :element-type element-type))) + (setf (gs-local-address gs) + (loop for (network address) in (scl:send host-object :network-addresses) + when (typep network 'tcp:internet-network) + return address)) + (setf (gs-local-port gs) port) + (flet ((add-to-queue (tcb) + (cond ((and (not (zerop (gs-local-address gs))) + (not (= (gs-local-address gs) (tcp::tcb-local-address tcb)))) + ;; Reject if not destined for the proper address + (tcp::reject-tcb tcb)) + ((<= (length (gs-pending-connections gs)) (gs-backlog gs)) + (tcp::accept-tcb tcb) + (tcp::tcb-travel-through-states tcb "Accept" nil :listen :syn-received) + (setf (gs-pending-connections gs) + (append (gs-pending-connections gs) (list tcb)))) + (t + ;; Reject if backlog is full + (tcp::reject-tcb tcb))))) + (tcp:add-tcp-port-listener port #'add-to-queue)) + (make-stream-server-socket gs :element-type element-type)))) + +(defmethod socket-accept ((socket stream-server-usocket) &key element-type) + (with-slots (pending-connections) (socket socket) + (loop + (process:process-block "Wait for connection" #'(lambda () + (not (null pending-connections)))) + (let ((tcb (pop pending-connections))) + (when tcb + (let* ((format (element-type-to-format (or element-type (element-type socket)) + :stream)) + (characters (eq format :text)) + (stream (tcp::make-tcp-stream tcb + :characters characters + :ascii-translation characters)) + (gs (make-instance 'genera-stream-socket + :stream stream))) + (setf (gs-foreign-address gs) (scl:send stream :foreign-address)) + (setf (gs-foreign-port gs) (scl:send stream :foreign-port)) + (setf (gs-local-address gs) (scl:send stream :local-address)) + (setf (gs-local-port gs) (scl:send stream :local-port)) + (return (make-stream-socket :socket gs :stream stream)))))))) + +(defmethod get-local-address ((usocket usocket)) + (hbo-to-vector-quad (gs-local-address (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (hbo-to-vector-quad (gs-foreign-address (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (gs-local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (gs-foreign-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) + ;;---*** TODO + (unsupported 'datagram 'socket-send)) + +(defmethod socket-receive ((socket datagram-usocket) buffer length &key) + ;;---*** TODO + (unsupported 'datagram 'socket-receive)) + +(defun get-host-by-address (address) + ) ;; TODO + +(defun get-hosts-by-name (name) + (with-mapped-conditions (nil name) + (let ((host-object (host-to-host-object name))) + (loop for (network address) in (scl:send host-object :network-addresses) + when (typep network 'tcp:internet-network) + collect (hbo-to-vector-quad address))))) + +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + +(defun %remove-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + +(defun wait-for-input-internal (wait-list &key timeout) + (with-mapped-conditions () + (process:process-block-with-timeout timeout "Wait for input" + #'(lambda (wait-list) + (let ((ready-sockets nil)) + (dolist (waiter (wait-list-waiters wait-list) ready-sockets) + (setf (state waiter) + (cond ((stream-usocket-p waiter) + (if (listen (socket-stream waiter)) + :read + nil)) + ((datagram-usocket-p waiter) + (let ((connection (gs-connection (socket waiter)))) + (if (and connection + (not (scl:send connection :connection-pending-p))) + :read + nil))) + ((stream-server-usocket-p waiter) + (if (gs-pending-connections (socket waiter)) + :read + nil)))) + (when (not (null (state waiter))) + (setf ready-sockets t))))) + wait-list) + wait-list)) + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/iolib.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/iolib.lisp new file mode 100644 index 0000000..53e72c5 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/iolib.lisp @@ -0,0 +1,290 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defparameter *backend* :iolib) + +(eval-when (:load-toplevel :execute) + (shadowing-import 'iolib/sockets:socket-option) + (export 'socket-option)) + +(defparameter +iolib-error-map+ + `((iolib/sockets:socket-address-in-use-error . address-in-use-error) + (iolib/sockets:socket-address-family-not-supported-error . socket-type-not-supported-error) + (iolib/sockets:socket-address-not-available-error . address-not-available-error) + (iolib/sockets:socket-network-down-error . network-down-error) + (iolib/sockets:socket-network-reset-error . network-reset-error) + (iolib/sockets:socket-network-unreachable-error . network-unreachable-error) + ;; (iolib/sockets:socket-no-network-error . ?) + (iolib/sockets:socket-connection-aborted-error . connection-aborted-error) + (iolib/sockets:socket-connection-reset-error . connection-reset-error) + (iolib/sockets:socket-connection-refused-error . connection-refused-error) + (iolib/sockets:socket-connection-timeout-error . timeout-error) + ;; (iolib/sockets:socket-connection-in-progress-error . ?) + (iolib/sockets:socket-endpoint-shutdown-error . network-down-error) + (iolib/sockets:socket-no-buffer-space-error . no-buffers-error) + (iolib/sockets:socket-host-down-error . host-down-error) + (iolib/sockets:socket-host-unreachable-error . host-unreachable-error) + ;; (iolib/sockets:socket-already-connected-error . ?) + (iolib/sockets:socket-not-connected-error . connection-refused-error) + (iolib/sockets:socket-option-not-supported-error . operation-not-permitted-error) + (iolib/syscalls:eacces . operation-not-permitted-error) + (iolib/sockets:socket-operation-not-supported-error . operation-not-supported-error) + (iolib/sockets:unknown-protocol . protocol-not-supported-error) + ;; (iolib/sockets:unknown-interface . ?) + (iolib/sockets:unknown-service . protocol-not-supported-error) + (iolib/sockets:socket-error . socket-error) + + ;; Nameservice errors (src/sockets/dns/conditions.lisp) + (iolib/sockets:resolver-error . ns-error) + (iolib/sockets:resolver-fail-error . ns-host-not-found-error) + (iolib/sockets:resolver-again-error . ns-try-again-condition) + (iolib/sockets:resolver-no-name-error . ns-no-recovery-error) + (iolib/sockets:resolver-unknown-error . ns-unknown-error) + )) + +;; IOlib uses (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (8)) to represent IPv6 addresses, +;; while USOCKET shared code uses (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (16)). Here we do the +;; conversion. +(defun iolib-vector-to-vector-quad (host) + (etypecase host + ((or (vector t 4) ; IPv4 + (array (unsigned-byte 8) (4))) + host) + ((or (vector t 8) ; IPv6 + (array (unsigned-byte 16) (8))) + (loop with vector = (make-array 16 :element-type '(unsigned-byte 8)) + for i below 16 by 2 + for word = (aref host (/ i 2)) + do (setf (aref vector i) (ldb (byte 8 8) word) + (aref vector (1+ i)) (ldb (byte 8 0) word)) + finally (return vector))))) + +(defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) + "Dispatch correct usocket condition." + (let* ((usock-error (cdr (assoc (type-of condition) +iolib-error-map+))) + (usock-error (if (functionp usock-error) + (funcall usock-error condition) + usock-error))) + (if usock-error + (if (typep usock-error 'socket-error) + (cond ((subtypep usock-error 'ns-error) + (error usock-error :socket socket :host-or-ip host-or-ip)) + (t + (error usock-error :socket socket))) + (cond ((subtypep usock-error 'ns-condition) + (signal usock-error :socket socket :host-or-ip host-or-ip)) + (t + (signal usock-error :socket socket)))) + (error 'unknown-error + :real-error condition + :socket socket)))) + +(defun ipv6-address-p (host) + (iolib/sockets:ipv6-address-p (iolib/sockets:ensure-hostname host))) + +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) + timeout deadline + (nodelay t) ;; nodelay == t is the ACL default + local-host local-port) + (declare (ignore element-type deadline nodelay)) + (with-mapped-conditions (nil host) + (let* ((remote (when (and host port) (iolib/sockets:ensure-hostname host))) + (local (when (and local-host local-port) + (iolib/sockets:ensure-hostname local-host))) + (ipv6-p (or (and remote (ipv6-address-p remote) + (and local (ipv6-address-p local))))) + (socket (apply #'iolib/sockets:make-socket + `(:type ,protocol + :address-family :internet + :ipv6 ,ipv6-p + :connect ,(cond ((eq protocol :stream) :active) + ((and host port) :active) + (t :passive)) + ,@(when local + `(:local-host ,local :local-port ,local-port)) + :nodelay nodelay)))) + (when remote + (apply #'iolib/sockets:connect + `(,socket ,remote :port ,port ,@(when timeout `(:wait ,timeout)))) + (unless (iolib/sockets:socket-connected-p socket) + (close socket) + (error 'iolib/sockets:socket-error))) + (ecase protocol + (:stream + (make-stream-socket :stream socket :socket socket)) + (:datagram + (make-datagram-socket socket :connected-p (and remote t))))))) + +(defmethod socket-close ((usocket usocket)) + (close (socket usocket))) + +(defmethod socket-shutdown ((usocket stream-usocket) direction) + (with-mapped-conditions () + (case direction + (:input + (iolib/sockets:shutdown (socket usocket) :read t)) + (:output + (iolib/sockets:shutdown (socket usocket) :write t)) + (t ; :io by default + (iolib/sockets:shutdown (socket usocket) :read t :write t))))) + +(defun socket-listen (host port + &key reuseaddress reuse-address + (backlog 5) + (element-type 'character)) + (declare (ignore element-type)) + (with-mapped-conditions (nil host) + (make-stream-server-socket + (iolib/sockets:make-socket :connect :passive + :address-family :internet + :local-host (iolib/sockets:ensure-hostname host) + :local-port port + :backlog backlog + :reuse-address (or reuse-address reuseaddress))))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (declare (ignore element-type)) + (with-mapped-conditions (usocket) + (let ((socket (iolib/sockets:accept-connection (socket usocket)))) + (make-stream-socket :socket socket :stream socket)))) + +(defmethod get-local-address ((usocket usocket)) + (iolib-vector-to-vector-quad + (iolib/sockets:address-to-vector (iolib/sockets:local-host (socket usocket))))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (iolib-vector-to-vector-quad + (iolib/sockets:address-to-vector (iolib/sockets:remote-host (socket usocket))))) + +(defmethod get-local-port ((usocket usocket)) + (iolib/sockets:local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (iolib/sockets:remote-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) + (apply #'iolib/sockets:send-to + `(,(socket usocket) ,buffer :start ,offset :end ,(+ offset size) + ,@(when (and host port) + `(:remote-host ,(iolib/sockets:ensure-hostname host) + :remote-port ,port))))) + +(defmethod socket-receive ((usocket datagram-usocket) buffer length &key start end) + (multiple-value-bind (buffer size host port) + (iolib/sockets:receive-from (socket usocket) + :buffer buffer :size length :start start :end end) + (values buffer size (iolib-vector-to-vector-quad host) port))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions (nil name) + (multiple-value-bind (address more-addresses) + (iolib/sockets:lookup-hostname name :ipv6 iolib/sockets:*ipv6*) + (mapcar #'(lambda (x) (iolib-vector-to-vector-quad + (iolib/sockets:address-name x))) + (cons address more-addresses))))) + +(defun get-host-by-address (address) + (with-mapped-conditions (nil address) + nil)) ;; TODO + +(defvar *event-base* + (make-instance 'iolib/multiplex:event-base)) + +(defun %setup-wait-list (wait-list) + (setf (wait-list-%wait wait-list) + (or *event-base* + ;; iolib/multiplex:*default-multiplexer* is used here + (make-instance 'iolib/multiplex:event-base)))) + +(defun make-usocket-read-handler (usocket disconnector) + (lambda (fd event exception) + (declare (ignore fd event exception)) + (handler-case + (if (eq (state usocket) :write) + (setf (state usocket) :read-write) + (setf (state usocket) :read)) + (end-of-file () + (funcall disconnector :close))))) + +(defun make-usocket-write-handler (usocket disconnector) + (lambda (fd event exception) + (declare (ignore fd event exception)) + (handler-case + (if (eq (state usocket) :read) + (setf (state usocket) :read-write) + (setf (state usocket) :write)) + (end-of-file () + (funcall disconnector :close)) + (iolib/streams:hangup () + (funcall disconnector :close))))) + +(defun make-usocket-error-handler (usocket disconnector) + (lambda (fd event exception) + (declare (ignore fd event exception)) + (handler-case + (setf (state usocket) nil) + (end-of-file () + (funcall disconnector :close)) + (iolib/streams:hangup () + (funcall disconnector :close))))) + +(defun make-usocket-disconnector (event-base usocket) + (declare (ignore event-base)) + (lambda (&rest events) + (let ((socket (socket usocket))) + ;; if were asked to close the socket, we do so here + (when (member :close events) + (close socket :abort t))))) + +(defun %add-waiter (wait-list waiter) + (let ((event-base (wait-list-%wait wait-list)) + (fd (iolib/sockets:socket-os-fd (socket waiter)))) + ;; reset socket state + (setf (state waiter) nil) + ;; set read handler + (unless (iolib/multiplex::fd-monitored-p event-base fd :read) + (iolib/multiplex:set-io-handler + event-base fd :read + (make-usocket-read-handler waiter + (make-usocket-disconnector event-base waiter)))) + ;; set write handler + #+ignore + (unless (iolib/multiplex::fd-monitored-p event-base fd :write) + (iolib/multiplex:set-io-handler + event-base fd :write + (make-usocket-write-handler waiter + (make-usocket-disconnector event-base waiter)))) + ;; set error handler + (unless (iolib/multiplex::fd-has-error-handler-p event-base fd) + (iolib/multiplex:set-error-handler + event-base fd + (make-usocket-error-handler waiter + (make-usocket-disconnector event-base waiter)))))) + +(defun %remove-waiter (wait-list waiter) + (let ((event-base (wait-list-%wait wait-list))) + (iolib/multiplex:remove-fd-handlers event-base + (iolib/sockets:socket-os-fd (socket waiter)) + :read t + :write nil + :error t))) + +;; NOTE: `wait-list-waiters` returns all usockets +(defun wait-for-input-internal (wait-list &key timeout) + (let ((event-base (wait-list-%wait wait-list))) + (handler-case + (iolib/multiplex:event-dispatch event-base :timeout timeout) + (iolib/streams:hangup ()) + (end-of-file ())) + ;; close the event-base after use + (unless (eq event-base *event-base*) + (close event-base)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/lispworks.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/lispworks.lisp new file mode 100644 index 0000000..9dfc757 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/lispworks.lisp @@ -0,0 +1,1001 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm") + + #+lispworks3 + (error "LispWorks 3 is not supported")) + +;;; --------------------------------------------------------------------------- +;;; Warn if multiprocessing is not running on Lispworks + +(defun check-for-multiprocessing-started (&optional errorp) + (unless mp:*current-process* + (funcall (if errorp 'error 'warn) + "You must start multiprocessing on Lispworks by calling~ + ~%~3t(~s)~ + ~%for ~s function properly." + 'mp:initialize-multiprocessing + 'wait-for-input))) + +(eval-when (:load-toplevel :execute) + (check-for-multiprocessing-started)) + +#+win32 +(eval-when (:load-toplevel :execute) + (fli:register-module "ws2_32")) + +(fli:define-foreign-function (get-host-name-internal "gethostname" :source) + ((return-string (:reference-return (:ef-mb-string :limit 257))) + (namelen :int)) + :lambda-list (&aux (namelen 256) return-string) + :result-type :int + #+win32 :module + #+win32 "ws2_32") + +(defun get-host-name () + (multiple-value-bind (return-code name) + (get-host-name-internal) + (when (zerop return-code) + name))) + +#+win32 +(defun remap-maybe-for-win32 (z) + (mapcar #'(lambda (x) + (cons (mapcar #'(lambda (y) (+ 10000 y)) (car x)) + (cdr x))) + z)) + +(defparameter +lispworks-error-map+ + #+win32 + (append (remap-maybe-for-win32 +unix-errno-condition-map+) + (remap-maybe-for-win32 +unix-errno-error-map+)) + #-win32 + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun raise-usock-err (errno socket &optional condition (host-or-ip nil)) + (let ((usock-error + (cdr (assoc errno +lispworks-error-map+ :test #'member)))) + (if usock-error + (if (subtypep usock-error 'error) + (cond ((subtypep usock-error 'ns-error) + (error usock-error :socket socket :host-or-ip host-or-ip)) + (t + (error usock-error :socket socket))) + (cond ((subtypep usock-error 'ns-condition) + (signal usock-error :socket socket :host-or-ip host-or-ip)) + (t + (signal usock-error :socket socket)))) + (error 'unknown-error + :socket socket + :real-error condition + :errno errno)))) + +(defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) + "Dispatch correct usocket condition." + (typecase condition + (condition (let ((errno #-win32 (lw:errno-value) + #+win32 (wsa-get-last-error))) + (unless (zerop errno) + (raise-usock-err errno socket condition host-or-ip)))))) + +(defconstant *socket_sock_dgram* 2 + "Connectionless, unreliable datagrams of fixed maximum length.") + +(defconstant *socket_ip_proto_udp* 17) + +(defconstant *sockopt_so_rcvtimeo* + #-linux #x1006 + #+linux 20 + "Socket receive timeout") + +(defconstant *sockopt_so_sndtimeo* + #-linux #x1007 + #+linux 21 + "Socket send timeout") + +(fli:define-c-struct timeval + (tv-sec :long) + (tv-usec :long)) + +;;; ssize_t +;;; recvfrom(int socket, void *restrict buffer, size_t length, int flags, +;;; struct sockaddr *restrict address, socklen_t *restrict address_len); +(fli:define-foreign-function (%recvfrom "recvfrom" :source) + ((socket :int) + (buffer (:pointer (:unsigned :byte))) + (length :int) + (flags :int) + (address (:pointer (:struct comm::sockaddr))) + (address-len (:pointer :int))) + :result-type :int + #+win32 :module + #+win32 "ws2_32") + +;;; ssize_t +;;; sendto(int socket, const void *buffer, size_t length, int flags, +;;; const struct sockaddr *dest_addr, socklen_t dest_len); +(fli:define-foreign-function (%sendto "sendto" :source) + ((socket :int) + (buffer (:pointer (:unsigned :byte))) + (length :int) + (flags :int) + (address (:pointer (:struct comm::sockaddr))) + (address-len :int)) + :result-type :int + #+win32 :module + #+win32 "ws2_32") + +#-win32 +(defun set-socket-receive-timeout (socket-fd seconds) + "Set socket option: RCVTIMEO, argument seconds can be a float number" + (declare (type integer socket-fd) + (type number seconds)) + (multiple-value-bind (sec usec) (truncate seconds) + (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))) + (fli:with-foreign-slots (tv-sec tv-usec) timeout + (setf tv-sec sec + tv-usec (truncate (* 1000000 usec))) + (if (zerop (comm::setsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_rcvtimeo* + (fli:copy-pointer timeout + :type '(:pointer :void)) + (fli:size-of '(:struct timeval)))) + seconds))))) + +#-win32 +(defun set-socket-send-timeout (socket-fd seconds) + "Set socket option: SNDTIMEO, argument seconds can be a float number" + (declare (type integer socket-fd) + (type number seconds)) + (multiple-value-bind (sec usec) (truncate seconds) + (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))) + (fli:with-foreign-slots (tv-sec tv-usec) timeout + (setf tv-sec sec + tv-usec (truncate (* 1000000 usec))) + (if (zerop (comm::setsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_sndtimeo* + (fli:copy-pointer timeout + :type '(:pointer :void)) + (fli:size-of '(:struct timeval)))) + seconds))))) + +#+win32 +(defun set-socket-receive-timeout (socket-fd seconds) + "Set socket option: RCVTIMEO, argument seconds can be a float number. + On win32, you must bind the socket before use this function." + (declare (type integer socket-fd) + (type number seconds)) + (fli:with-dynamic-foreign-objects ((timeout :int)) + (setf (fli:dereference timeout) + (truncate (* 1000 seconds))) + (if (zerop (comm::setsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_rcvtimeo* + (fli:copy-pointer timeout + :type '(:pointer :char)) + (fli:size-of :int))) + seconds))) + +#+win32 +(defun set-socket-send-timeout (socket-fd seconds) + "Set socket option: SNDTIMEO, argument seconds can be a float number. + On win32, you must bind the socket before use this function." + (declare (type integer socket-fd) + (type number seconds)) + (fli:with-dynamic-foreign-objects ((timeout :int)) + (setf (fli:dereference timeout) + (truncate (* 1000 seconds))) + (if (zerop (comm::setsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_sndtimeo* + (fli:copy-pointer timeout + :type '(:pointer :char)) + (fli:size-of :int))) + seconds))) + +#-win32 +(defun get-socket-receive-timeout (socket-fd) + "Get socket option: RCVTIMEO, return value is a float number" + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)) + (len :int)) + (comm::getsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_rcvtimeo* + (fli:copy-pointer timeout + :type '(:pointer :void)) + len) + (fli:with-foreign-slots (tv-sec tv-usec) timeout + (float (+ tv-sec (/ tv-usec 1000000)))))) + +#-win32 +(defun get-socket-send-timeout (socket-fd) + "Get socket option: SNDTIMEO, return value is a float number" + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)) + (len :int)) + (comm::getsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_sndtimeo* + (fli:copy-pointer timeout + :type '(:pointer :void)) + len) + (fli:with-foreign-slots (tv-sec tv-usec) timeout + (float (+ tv-sec (/ tv-usec 1000000)))))) + +#+win32 +(defun get-socket-receive-timeout (socket-fd) + "Get socket option: RCVTIMEO, return value is a float number" + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((timeout :int) + (len :int)) + (comm::getsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_rcvtimeo* + (fli:copy-pointer timeout + :type '(:pointer :void)) + len) + (float (/ (fli:dereference timeout) 1000)))) + +#+win32 +(defun get-socket-send-timeout (socket-fd) + "Get socket option: SNDTIMEO, return value is a float number" + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((timeout :int) + (len :int)) + (comm::getsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_sndtimeo* + (fli:copy-pointer timeout + :type '(:pointer :void)) + len) + (float (/ (fli:dereference timeout) 1000)))) + +#+(or lispworks4 lispworks5.0) +(defun set-socket-tcp-nodelay (socket-fd new-value) + "Set socket option: TCP_NODELAY, argument is a fixnum (0 or 1)" + (declare (type integer socket-fd) + (type (integer 0 1) new-value)) + (fli:with-dynamic-foreign-objects ((zero-or-one :int)) + (setf (fli:dereference zero-or-one) new-value) + (when (zerop (comm::setsockopt socket-fd + comm::*sockopt_sol_socket* + comm::*sockopt_tcp_nodelay* + (fli:copy-pointer zero-or-one + :type '(:pointer #+win32 :char #-win32 :void)) + (fli:size-of :int))) + new-value))) + +(defun get-socket-tcp-nodelay (socket-fd) + "Get socket option: TCP_NODELAY, return value is a fixnum (0 or 1)" + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((zero-or-one :int) + (len :int)) + (if (zerop (comm::getsockopt socket-fd + comm::*sockopt_sol_socket* + comm::*sockopt_tcp_nodelay* + (fli:copy-pointer zero-or-one + :type '(:pointer #+win32 :char #-win32 :void)) + len)) + zero-or-one 0))) ; on error, return 0 + +(defun initialize-dynamic-sockaddr (hostname service protocol &aux (original-hostname hostname)) + (declare (ignorable original-hostname)) + #+(or lispworks4 lispworks5 lispworks6.0) + (let ((server-addr (fli:allocate-dynamic-foreign-object + :type '(:struct comm::sockaddr_in)))) + (values (comm::initialize-sockaddr_in + server-addr + comm::*socket_af_inet* + hostname + service protocol) + comm::*socket_af_inet* + server-addr + (fli:pointer-element-size server-addr))) + #-(or lispworks4 lispworks5 lispworks6.0) ; version>=6.1 + (progn + (when (stringp hostname) + (setq hostname (comm:string-ip-address hostname)) + (unless hostname + (let ((resolved-hostname (comm:get-host-entry original-hostname :fields '(:address)))) + (unless resolved-hostname + (return-from initialize-dynamic-sockaddr :unknown-host)) + (setq hostname resolved-hostname)))) + (if (or (null hostname) + (integerp hostname) + (comm:ipv6-address-p hostname)) + (let ((server-addr (fli:allocate-dynamic-foreign-object + :type '(:struct comm::lw-sockaddr)))) + (multiple-value-bind (error family) + (comm::initialize-sockaddr_in + server-addr + hostname + service protocol) + (values error family + server-addr + (if (eql family comm::*socket_af_inet*) + (fli:size-of '(:struct comm::sockaddr_in)) + (fli:size-of '(:struct comm::sockaddr_in6)))))) + :bad-host))) + +(defun open-udp-socket (&key local-address local-port read-timeout + (address-family comm::*socket_af_inet*)) + "Open a unconnected UDP socket. + For binding on address ANY(*), just not set LOCAL-ADDRESS (NIL), + for binding on random free unused port, set LOCAL-PORT to 0." + + ;; Note: move (ensure-sockets) here to make sure delivered applications + ;; correctly have networking support initialized. + ;; + ;; Following words was from Martin Simmons, forwarded by Camille Troillard: + + ;; Calling comm::ensure-sockets at load time looks like a bug in Lispworks-udp + ;; (it is too early and also unnecessary). + + ;; The LispWorks comm package calls comm::ensure-sockets when it is needed, so I + ;; think open-udp-socket should probably do it too. Calling it more than once is + ;; safe and it will be very fast after the first time. + #+win32 (comm::ensure-sockets) + + (let ((socket-fd (comm::socket address-family *socket_sock_dgram* *socket_ip_proto_udp*))) + (if socket-fd + (progn + (when read-timeout (set-socket-receive-timeout socket-fd read-timeout)) + (if local-port + (fli:with-dynamic-foreign-objects () + (multiple-value-bind (error local-address-family + client-addr client-addr-length) + (initialize-dynamic-sockaddr local-address local-port "udp") + (if (or error (not (eql address-family local-address-family))) + (progn + (comm::close-socket socket-fd) + (error "cannot resolve hostname ~S, service ~S: ~A" + local-address local-port (or error "address family mismatch"))) + (if (comm::bind socket-fd client-addr client-addr-length) + ;; success, return socket fd + socket-fd + (progn + (comm::close-socket socket-fd) + (error "cannot bind")))))) + socket-fd)) + (error "cannot create socket")))) + +(defun connect-to-udp-server (hostname service + &key local-address local-port read-timeout) + "Something like CONNECT-TO-TCP-SERVER" + (fli:with-dynamic-foreign-objects () + (multiple-value-bind (error address-family server-addr server-addr-length) + (initialize-dynamic-sockaddr hostname service "udp") + (when error + (error "cannot resolve hostname ~S, service ~S: ~A" + hostname service error)) + (let ((socket-fd (open-udp-socket :local-address local-address + :local-port local-port + :read-timeout read-timeout + :address-family address-family))) + (if socket-fd + (if (comm::connect socket-fd server-addr server-addr-length) + ;; success, return socket fd + socket-fd + ;; fail, close socket and return nil + (progn + (comm::close-socket socket-fd) + (error "cannot connect"))) + (error "cannot create socket")))))) + +(defun socket-connect (host port &key (protocol :stream) (element-type 'base-char) + timeout deadline (nodelay t) + local-host local-port) + ;; What's the meaning of this keyword? + (when deadline + (unimplemented 'deadline 'socket-connect)) + + #+(and lispworks4 (not lispworks4.4)) ; < 4.4.5 + (when timeout + (unsupported 'timeout 'socket-connect :minimum "LispWorks 4.4.5")) + + #+lispworks4 + (when local-host + (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0")) + #+lispworks4 + (when local-port + (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0")) + + (ecase protocol + (:stream + (let ((hostname (host-to-hostname host)) + (stream)) + (setq stream + (with-mapped-conditions (nil host) + (comm:open-tcp-stream hostname port + :element-type element-type + #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5 + #-(and lispworks4 (not lispworks4.4)) + :timeout timeout + #-lispworks4 #-lispworks4 + #-lispworks4 #-lispworks4 + :local-address (when local-host (host-to-hostname local-host)) + :local-port local-port + #-(or lispworks4 lispworks5.0) ; >= 5.1 + #-(or lispworks4 lispworks5.0) + :nodelay nodelay))) + + ;; Then handle `nodelay' separately for older versions <= 5.0 + #+(or lispworks4 lispworks5.0) + (when (and stream nodelay) + (set-socket-tcp-nodelay + (comm:socket-stream-socket stream) + (bool->int nodelay))) ; ":if-supported" maps to 1 too. + + (if stream + (make-stream-socket :socket (comm:socket-stream-socket stream) + :stream stream) + ;; if no other error catched by above with-mapped-conditions and still fails, then it's a timeout + (error 'timeout-error)))) + (:datagram + (let ((usocket (make-datagram-socket + (if (and host port) + (with-mapped-conditions (nil host) + (connect-to-udp-server (host-to-hostname host) port + :local-address (and local-host (host-to-hostname local-host)) + :local-port local-port + :read-timeout timeout)) + (with-mapped-conditions (nil local-host) + (open-udp-socket :local-address (and local-host (host-to-hostname local-host)) + :local-port local-port + :read-timeout timeout))) + :connected-p (and host port t)))) + usocket)))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'base-char)) + #+lispworks4.1 + (unsupported 'host 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1") + #+lispworks4.1 + (unsupported 'backlog 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1") + + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (comm::*use_so_reuseaddr* reuseaddress) + (hostname (host-to-hostname host)) + (socket-res-list (with-mapped-conditions (nil host) + (multiple-value-list + #-lispworks4.1 (comm::create-tcp-socket-for-service + port :address hostname :backlog backlog) + #+lispworks4.1 (comm::create-tcp-socket-for-service port)))) + (sock (if (not (or (second socket-res-list) (third socket-res-list))) + (first socket-res-list) + (when (eq (second socket-res-list) :bind) + (error 'address-in-use-error))))) + (make-stream-server-socket sock :element-type element-type))) + +;; Note: COMM::GET-FD-FROM-SOCKET contains addition socket wait operations, which +;; should NOT be applied on socket FDs who have already been called on W-F-I, +;; so we have to check the %READY-P slot to decide if this waiting is necessary, +;; or SOCKET-ACCEPT will just hang. -- Chun Tian (binghe), May 1, 2011 + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (let* ((socket (with-mapped-conditions (usocket) + #+win32 + (if (%ready-p usocket) + (comm::accept-connection-to-socket (socket usocket)) + (comm::get-fd-from-socket (socket usocket))) + #-win32 + (comm::get-fd-from-socket (socket usocket)))) + (stream (make-instance 'comm:socket-stream + :socket socket + :direction :io + :element-type (or element-type + (element-type usocket))))) + #+win32 + (when socket + (setf (%ready-p usocket) nil)) + (make-stream-socket :socket socket :stream stream))) + +;; Sockets and their streams are different objects +;; close the stream in order to make sure buffers +;; are correctly flushed and the socket closed. +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (close (socket-stream usocket))) + +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (comm::close-socket (socket usocket)))) + +(defmethod socket-close :after ((socket datagram-usocket)) + "Additional socket-close method for datagram-usocket" + (setf (%open-p socket) nil)) + +(defconstant +shutdown-read+ 0) +(defconstant +shutdown-write+ 1) +(defconstant +shutdown-read-write+ 2) + +;;; int +;;; shutdown(int socket, int what); +(fli:define-foreign-function (%shutdown "shutdown" :source) + ((socket :int) + (what :int)) + :result-type :int + #+win32 :module + #+win32 "ws2_32") + +(defmethod socket-shutdown ((usocket datagram-usocket) direction) + (unless (member direction '(:input :output :io)) + (error 'invalid-argument-error)) + (let ((what (case direction + (:input +shutdown-read+) + (:output +shutdown-write+) + (:io +shutdown-read-write+)))) + (with-mapped-conditions (usocket) + #-(or lispworks4 lispworks5 lispworks6) ; lispworks 7.0+ + (comm::shutdown (socket usocket) what) + #+(or lispworks4 lispworks5 lispworks6) + (= 0 (%shutdown (socket usocket) what))))) + +(defmethod socket-shutdown ((usocket stream-usocket) direction) + (unless (member direction '(:input :output :io)) + (error 'invalid-argument-error)) + (with-mapped-conditions (usocket) + #-(or lispworks4 lispworks5 lispworks6) + (comm:socket-stream-shutdown (socket usocket) direction) + #+(or lispworks4 lispworks5 lispworks6) + (let ((what (case direction + (:input +shutdown-read+) + (:output +shutdown-write+) + (:io +shutdown-read-write+)))) + (= 0 (%shutdown (comm:socket-stream-socket (socket usocket)) what))))) + +(defmethod initialize-instance :after ((socket datagram-usocket) &key) + (setf (slot-value socket 'send-buffer) + (make-array +max-datagram-packet-size+ + :element-type '(unsigned-byte 8) + :allocation :static)) + (setf (slot-value socket 'recv-buffer) + (make-array +max-datagram-packet-size+ + :element-type '(unsigned-byte 8) + :allocation :static))) + +(defvar *length-of-sockaddr_in* + (fli:size-of '(:struct comm::sockaddr_in))) + +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0) + &aux (socket-fd (socket usocket)) + (message (slot-value usocket 'send-buffer))) ; TODO: multiple threads send together? + "Send message to a socket, using sendto()/send()" + (declare (type integer socket-fd) + (type sequence buffer)) + (when host (setq host (host-to-hostname host))) + (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte)) + (replace message buffer :start2 offset :end2 (+ offset size)) + (let ((n (if (and host port) + (fli:with-dynamic-foreign-objects () + (multiple-value-bind (error family client-addr client-addr-length) + (initialize-dynamic-sockaddr host port "udp") + (declare (ignore family)) + (when error + (error "cannot resolve hostname ~S, port ~S: ~A" + host port error)) + (%sendto socket-fd ptr (min size +max-datagram-packet-size+) 0 + (fli:copy-pointer client-addr :type '(:struct comm::sockaddr)) + client-addr-length))) + (comm::%send socket-fd ptr (min size +max-datagram-packet-size+) 0)))) + (declare (type fixnum n)) + (if (plusp n) + n + (let ((errno #-win32 (lw:errno-value) + #+win32 (wsa-get-last-error))) + (if (zerop errno) + n + (raise-usock-err errno socket-fd host))))))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length &key timeout (max-buffer-size +max-datagram-packet-size+)) + "Receive message from socket, read-timeout is a float number in seconds. + + This function will return 4 values: + 1. receive buffer + 2. number of receive bytes + 3. remote address + 4. remote port" + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16)) ; port + (type sequence buffer)) + (let ((socket-fd (socket socket)) + (message (slot-value socket 'recv-buffer)) ; TODO: how multiple threads do this in parallel? + (read-timeout timeout) + old-timeout) + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in)) + (len :int + #-(or lispworks4 lispworks5.0) ; <= 5.0 + :initial-element *length-of-sockaddr_in*)) + #+(or lispworks4 lispworks5.0) ; <= 5.0 + (setf (fli:dereference len) *length-of-sockaddr_in*) + (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte)) + ;; setup new read timeout + (when read-timeout + (setf old-timeout (get-socket-receive-timeout socket-fd)) + (set-socket-receive-timeout socket-fd read-timeout)) + (let ((n (%recvfrom socket-fd ptr max-buffer-size 0 + (fli:copy-pointer client-addr :type '(:struct comm::sockaddr)) + len))) + (declare (type fixnum n)) + ;; restore old read timeout + (when (and read-timeout (/= old-timeout read-timeout)) + (set-socket-receive-timeout socket-fd old-timeout)) + ;; Frank James' patch: reset the %read-p for WAIT-FOR-INPUT + #+win32 (setf (%ready-p socket) nil) + (if (plusp n) + (values (if buffer + (replace buffer message + :end1 (min length max-buffer-size) + :end2 (min n max-buffer-size)) + (subseq message 0 (min n max-buffer-size))) + (min n max-buffer-size) + (comm::ntohl (fli:foreign-slot-value + (fli:foreign-slot-value client-addr + 'comm::sin_addr + :object-type '(:struct comm::sockaddr_in) + :type '(:struct comm::in_addr) + :copy-foreign-object nil) + 'comm::s_addr + :object-type '(:struct comm::in_addr))) + (comm::ntohs (fli:foreign-slot-value client-addr + 'comm::sin_port + :object-type '(:struct comm::sockaddr_in) + :type '(:unsigned :short) + :copy-foreign-object nil))) + (let ((errno #-win32 (lw:errno-value) + #+win32 (wsa-get-last-error))) + (if (zerop errno) + (values nil n 0 0) + (raise-usock-err errno socket-fd))))))))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind + (address port) + (comm:get-socket-address (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind + (address port) + (comm:get-socket-peer-address (socket usocket)) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + +#-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1 +(defun ipv6-address-p (hostname) + (when (stringp hostname) + (setq hostname (comm:string-ip-address hostname)) + (unless hostname + (let ((resolved-hostname (comm:get-host-entry hostname :fields '(:address)))) + (unless resolved-hostname + (return-from ipv6-address-p nil)) + (setq hostname resolved-hostname)))) + (comm:ipv6-address-p hostname)) + +(defun lw-hbo-to-vector-quad (hbo) + #+(or lispworks4 lispworks5 lispworks6.0) + (hbo-to-vector-quad hbo) + #-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1 + (if (comm:ipv6-address-p hbo) + (ipv6-host-to-vector (comm:ipv6-address-string hbo)) + (hbo-to-vector-quad hbo))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions (nil name) + (mapcar #'lw-hbo-to-vector-quad + (comm:get-host-entry name :fields '(:addresses))))) + +(defun get-host-by-address (address) + (with-mapped-conditions (nil address) + nil)) ;; TODO + +(defun os-socket-handle (usocket) + (socket usocket)) + +(defun usocket-listen (usocket) + (if (stream-usocket-p usocket) + (when (listen (socket-stream usocket)) + usocket) + (when (comm::socket-listen (socket usocket)) + usocket))) + +;;; +;;; Non Windows implementation +;;; The Windows implementation needs to resort to the Windows API in order +;;; to achieve what we want (what we want is waiting without busy-looping) +;;; + +#-win32 +(progn + + (defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + + (defun %add-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + + (defun %remove-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + + (defun wait-for-input-internal (wait-list &key timeout) + (with-mapped-conditions () + ;; unfortunately, it's impossible to share code between + ;; non-win32 and win32 platforms... + ;; Can we have a sane -pref. complete [UDP!?]- API next time, please? + (dolist (x (wait-list-waiters wait-list)) + (mp:notice-fd (os-socket-handle x))) + (labels ((wait-function (socks) + (let (rv) + (dolist (x socks rv) + (when (usocket-listen x) + (setf (state x) :READ + rv t)))))) + (if timeout + (mp:process-wait-with-timeout "Waiting for a socket to become active" + (truncate timeout) + #'wait-function + (wait-list-waiters wait-list)) + (mp:process-wait "Waiting for a socket to become active" + #'wait-function + (wait-list-waiters wait-list)))) + (dolist (x (wait-list-waiters wait-list)) + (mp:unnotice-fd (os-socket-handle x))) + wait-list)) + +) ; end of block + + +;;; +;;; The Windows side of the story +;;; We want to wait without busy looping +;;; This code only works in threads which don't have (hidden) +;;; windows which need to receive messages. There are workarounds in the Windows API +;;; but are those available to 'us'. +;;; + + +#+win32 +(progn + + ;; LispWorks doesn't provide an interface to wait for a socket + ;; to become ready (under Win32, that is) meaning that we need + ;; to resort to system calls to achieve the same thing. + ;; Luckily, it provides us access to the raw socket handles (as we + ;; wrote the code above. + + (defconstant fd-read 1) + (defconstant fd-read-bit 0) + (defconstant fd-write 2) + (defconstant fd-write-bit 1) + (defconstant fd-oob 4) + (defconstant fd-oob-bit 2) + (defconstant fd-accept 8) + (defconstant fd-accept-bit 3) + (defconstant fd-connect 16) + (defconstant fd-connect-bit 4) + (defconstant fd-close 32) + (defconstant fd-close-bit 5) + (defconstant fd-qos 64) + (defconstant fd-qos-bit 6) + (defconstant fd-group-qos 128) + (defconstant fd-group-qos-bit 7) + (defconstant fd-routing-interface 256) + (defconstant fd-routing-interface-bit 8) + (defconstant fd-address-list-change 512) + (defconstant fd-address-list-change-bit 9) + + (defconstant fd-max-events 10) + + (defconstant fionread 1074030207) + + + ;; Note: + ;; + ;; If special finalization has to occur for a given + ;; system resource (handle), an associated object should + ;; be created. A special cleanup action should be added + ;; to the system and a special cleanup action should + ;; be flagged on all objects created for resources like it + ;; + ;; We have 2 functions to do so: + ;; * hcl:add-special-free-action (function-symbol) + ;; * hcl:flag-special-free-action (object) + ;; + ;; Note that the special free action will be called on all + ;; objects which have been flagged for special free, so be + ;; sure to check for the right argument type! + + (fli:define-foreign-type ws-socket () '(:unsigned :int)) + (fli:define-foreign-type win32-handle () '(:unsigned :int)) + (fli:define-c-struct wsa-network-events + (network-events :long) + (error-code (:c-array :int 10))) + + (fli:define-foreign-function (wsa-event-create "WSACreateEvent" :source) + () + :lambda-list nil + :result-type :int + :module "ws2_32") + + (fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source) + ((event-object win32-handle)) + :result-type :int + :module "ws2_32") + + ;; not used + (fli:define-foreign-function (wsa-reset-event "WSAResetEvent" :source) + ((event-object win32-handle)) + :result-type :int + :module "ws2_32") + + (fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source) + ((socket ws-socket) + (event-object win32-handle) + (network-events (:reference-return wsa-network-events))) + :result-type :int + :module "ws2_32") + + (fli:define-foreign-function (wsa-event-select "WSAEventSelect" :source) + ((socket ws-socket) + (event-object win32-handle) + (network-events :long)) + :result-type :int + :module "ws2_32") + + (fli:define-foreign-function (wsa-get-last-error "WSAGetLastError" :source) + () + :result-type :int + :module "ws2_32") + + (fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source) + ((socket :long) (cmd :long) (argp (:ptr :long))) + :result-type :int + :module "ws2_32") + + + ;; The Windows system + + + ;; Now that we have access to the system calls, this is the plan: + + ;; 1. Receive a wait-list with associated sockets to wait for + ;; 2. Add all those sockets to an event handle + ;; 3. Listen for an event on that handle (we have a LispWorks system:: internal for that) + ;; 4. After listening, detect if there are errors + ;; (this step is different from Unix, where we can have only one error) + ;; 5. If so, raise one of them + ;; 6. If not so, return the sockets which have input waiting for them + + + (defun maybe-wsa-error (rv &optional socket) + (unless (zerop rv) + (raise-usock-err (wsa-get-last-error) socket))) + + (defun bytes-available-for-read (socket) + (fli:with-dynamic-foreign-objects ((int-ptr :long)) + (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr))) + (if (= 0 rv) + (fli:dereference int-ptr) + 0)))) + + (defun socket-ready-p (socket) + (if (typep socket 'stream-usocket) + (< 0 (bytes-available-for-read socket)) + (%ready-p socket))) + + (defun waiting-required (sockets) + (notany #'socket-ready-p sockets)) + + (defun wait-for-input-internal (wait-list &key timeout) + (when (waiting-required (wait-list-waiters wait-list)) + (system:wait-for-single-object (wait-list-%wait wait-list) + "Waiting for socket activity" timeout)) + (update-ready-and-state-slots wait-list)) + + (defun map-network-events (func network-events) + (let ((event-map (fli:foreign-slot-value network-events 'network-events)) + (error-array (fli:foreign-slot-pointer network-events 'error-code))) + (unless (zerop event-map) + (dotimes (i fd-max-events) + (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand? + (funcall func (fli:foreign-aref error-array i))))))) + + (defun update-ready-and-state-slots (wait-list) + (loop with sockets = (wait-list-waiters wait-list) + for socket in sockets do + (if (or (and (stream-usocket-p socket) + (listen (socket-stream socket))) + (%ready-p socket)) + (setf (state socket) :READ) + (multiple-value-bind + (rv network-events) + (wsa-enum-network-events (os-socket-handle socket) + (wait-list-%wait wait-list) + t) + (if (zerop rv) + (map-network-events #'(lambda (err-code) + (if (zerop err-code) + (setf (%ready-p socket) t + (state socket) :READ) + (raise-usock-err err-code socket))) + network-events) + (maybe-wsa-error rv socket)))))) + + ;; The wait-list part + + (defun free-wait-list (wl) + (when (wait-list-p wl) + (unless (null (wait-list-%wait wl)) + (wsa-event-close (wait-list-%wait wl)) + (setf (wait-list-%wait wl) nil)))) + + (eval-when (:load-toplevel :execute) + (hcl:add-special-free-action 'free-wait-list)) + + (defun %setup-wait-list (wait-list) + (hcl:flag-special-free-action wait-list) + (setf (wait-list-%wait wait-list) (wsa-event-create))) + + (defun %add-waiter (wait-list waiter) + (let ((events (etypecase waiter + (stream-server-usocket (logior fd-connect fd-accept fd-close)) + (stream-usocket (logior fd-connect fd-read fd-oob fd-close)) + (datagram-usocket (logior fd-read))))) + (maybe-wsa-error + (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events) + waiter))) + + (defun %remove-waiter (wait-list waiter) + (maybe-wsa-error + (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) 0) + waiter)) + +) ; end of WIN32-block + +(defun set-socket-reuse-address (socket-fd reuse-address-p) + (declare (type integer socket-fd) + (type boolean reuse-address-p)) + (fli:with-dynamic-foreign-objects ((value :int)) + (setf (fli:dereference value) (if reuse-address-p 1 0)) + (if (zerop (comm::setsockopt socket-fd + comm::*sockopt_sol_socket* + comm::*sockopt_so_reuseaddr* + (fli:copy-pointer value + :type '(:pointer :void)) + (fli:size-of :int))) + reuse-address-p))) + +(defun get-socket-reuse-address (socket-fd) + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((value :int) (len :int)) + (if (zerop (comm::getsockopt socket-fd + comm::*sockopt_sol_socket* + comm::*sockopt_so_reuseaddr* + (fli:copy-pointer value + :type '(:pointer :void)) + len)) + (= 1 (fli:dereference value))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mcl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mcl.lisp new file mode 100644 index 0000000..e62103c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mcl.lisp @@ -0,0 +1,271 @@ +;; MCL backend for USOCKET 0.4.1 +;; Terje Norderhaug , January 1, 2009 + +(in-package :usocket) + +(defun handle-condition (condition &optional socket (host-or-ip nil)) + ; incomplete, needs to handle additional conditions + (flet ((raise-error (&optional socket-condition host-or-ip) + (if socket-condition + (cond ((typep socket-condition ns-error) + (error socket-condition :socket socket :host-or-ip host-or-ip)) + (t + (error socket-condition :socket socket))) + (error 'unknown-error :socket socket :real-error condition)))) + (typecase condition + (ccl:host-stopped-responding + (raise-error 'host-down-error host-or-ip)) + (ccl:host-not-responding + (raise-error 'host-unreachable-error host-or-ip)) + (ccl:connection-reset + (raise-error 'connection-reset-error)) + (ccl:connection-timed-out + (raise-error 'timeout-error)) + (ccl:opentransport-protocol-error + (raise-error 'protocol-not-supported-error)) + (otherwise + (raise-error condition host-or-ip))))) + +(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay + local-host local-port (protocol :stream)) + (when (eq nodelay :if-supported) + (setf nodelay t)) + (ecase protocol + (:stream + (with-mapped-conditions (nil host) + (let* ((socket + (make-instance 'active-socket + :remote-host (when host (host-to-hostname host)) + :remote-port port + :local-host (when local-host (host-to-hostname local-host)) + :local-port local-port + :deadline deadline + :nodelay nodelay + :connect-timeout (and timeout (round (* timeout 60))) + :element-type element-type)) + (stream (socket-open-stream socket))) + (make-stream-socket :socket socket :stream stream)))) + (:datagram + (with-mapped-conditions (nil (or host local-host)) + (make-datagram-socket + (ccl::open-udp-socket :local-address (and local-host (host-to-hbo local-host)) + :local-port local-port)))))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (socket (with-mapped-conditions () + (make-instance 'passive-socket + :local-port port + :local-host (host-to-hbo host) + :reuse-address reuseaddress + :backlog backlog)))) + (make-stream-server-socket socket :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (let* ((socket (socket usocket)) + (stream (with-mapped-conditions (usocket) + (socket-accept socket :element-type element-type)))) + (make-stream-socket :socket socket :stream stream))) + +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (socket-close (socket usocket)))) + +(defmethod socket-shutdown ((usocket usocket) direction) + (declare (ignore usocket direction)) + ;; As far as I can tell there isn't a way to shutdown a socket in mcl. + (unsupported "shutdown" 'socket-shutdown)) + +(defmethod ccl::stream-close ((usocket usocket)) + (socket-close usocket)) + +(defun get-hosts-by-name (name) + (with-mapped-conditions (nil name) + (list (hbo-to-vector-quad (ccl::get-host-address + (host-to-hostname name)))))) + +(defun get-host-by-address (address) + (with-mapped-conditions (nil address) + (ccl::inet-host-name (host-to-hbo address)))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defmethod get-local-address ((usocket usocket)) + (hbo-to-vector-quad (ccl::get-host-address (or (local-host (socket usocket)) "")))) + +(defmethod get-local-port ((usocket usocket)) + (local-port (socket usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (hbo-to-vector-quad (ccl::get-host-address (remote-host (socket usocket))))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (remote-port (socket usocket))) + +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + +(defun %remove-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASIC MCL SOCKET IMPLEMENTATION + +(defclass socket () + ((local-port :reader local-port :initarg :local-port) + (local-host :reader local-host :initarg :local-host) + (element-type :reader element-type :initform 'ccl::base-character :initarg :element-type))) + +(defclass active-socket (socket) + ((remote-host :reader remote-host :initarg :remote-host) + (remote-port :reader remote-port :initarg :remote-port) + (deadline :initarg :deadline) + (nodelay :initarg :nodelay) + (connect-timeout :reader connect-timeout :initform NIL :initarg :connect-timeout + :type (or null fixnum) :documentation "ticks (60th of a second)"))) + +(defmethod socket-open-stream ((socket active-socket)) + (ccl::open-tcp-stream (or (remote-host socket)(ccl::local-interface-ip-address)) (remote-port socket) + :element-type (if (subtypep (element-type socket) 'character) 'ccl::base-character 'unsigned-byte) + :connect-timeout (connect-timeout socket))) + +(defmethod socket-close ((socket active-socket)) + NIL) + +(defclass passive-socket (socket) + ((streams :accessor socket-streams :type list :initform NIL + :documentation "Circular list of streams with first element the next to open") + (reuse-address :reader reuse-address :initarg :reuse-address) + (lock :reader socket-lock :initform (ccl:make-lock "Socket")))) + +(defmethod initialize-instance :after ((socket passive-socket) &key backlog) + (loop repeat backlog + collect (socket-open-listener socket) into streams + finally (setf (socket-streams socket) + (cdr (rplacd (last streams) streams)))) + (when (zerop (local-port socket)) + (setf (slot-value socket 'local-port) + (or (ccl::process-wait-with-timeout "binding port" (* 10 60) + #'ccl::stream-local-port (car (socket-streams socket))) + (error "timeout"))))) + +(defmethod socket-accept ((socket passive-socket) &key element-type &aux (lock (socket-lock socket))) + (flet ((connection-established-p (stream) + (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil)) + (let ((state (ccl::opentransport-stream-connection-state stream))) + (not (eq :unbnd state)))))) + (with-mapped-conditions () + (ccl:with-lock-grabbed (lock nil "Socket Lock") + (let ((connection (shiftf (car (socket-streams socket)) + (socket-open-listener socket element-type)))) + (pop (socket-streams socket)) + (ccl:process-wait "Accepting" #'connection-established-p connection) + connection))))) + +(defmethod socket-close ((socket passive-socket)) + (loop + with streams = (socket-streams socket) + for (stream tail) on streams + do (close stream :abort T) + until (eq tail streams) + finally (setf (socket-streams socket) NIL))) + +(defmethod socket-open-listener (socket &optional element-type) + ; see http://code.google.com/p/mcl/issues/detail?id=28 + (let* ((ccl::*passive-interface-address* (local-host socket)) + (new (ccl::open-tcp-stream NIL (or (local-port socket) #$kOTAnyInetAddress) + :reuse-local-port-p (reuse-address socket) + :element-type (if (subtypep (or element-type (element-type socket)) + 'character) + 'ccl::base-character + 'unsigned-byte)))) + (declare (special ccl::*passive-interface-address*)) + new)) + +(defmethod input-available-p ((stream ccl::opentransport-stream)) + (macrolet ((when-io-buffer-lock-grabbed ((lock &optional multiple-value-p) &body body) + "Evaluates the body if and only if the lock is successfully grabbed" + ;; like with-io-buffer-lock-grabbed but returns immediately instead of polling the lock + (let ((needs-unlocking-p (gensym)) + (lock-var (gensym))) + `(let* ((,lock-var ,lock) + (ccl::*grabbed-io-buffer-locks* (cons ,lock-var ccl::*grabbed-io-buffer-locks*)) + (,needs-unlocking-p (needs-unlocking-p ,lock-var))) + (declare (dynamic-extent ccl::*grabbed-io-buffer-locks*)) + (when ,needs-unlocking-p + (,(if multiple-value-p 'multiple-value-prog1 'prog1) + (progn ,@body) + (ccl::%release-io-buffer-lock ,lock-var))))))) + (labels ((needs-unlocking-p (lock) + (declare (type ccl::lock lock)) + ;; crucial - clears bogus lock.value as in grab-io-buffer-lock-out-of-line: + (ccl::%io-buffer-lock-really-grabbed-p lock) + (ccl:store-conditional lock nil ccl:*current-process*))) + "similar to stream-listen on buffered-input-stream-mixin but without waiting for lock" + (let ((io-buffer (ccl::stream-io-buffer stream))) + (or (not (eql 0 (ccl::io-buffer-incount io-buffer))) + (ccl::io-buffer-untyi-char io-buffer) + (locally (declare (optimize (speed 3) (safety 0))) + (when-io-buffer-lock-grabbed ((ccl::io-buffer-lock io-buffer)) + (funcall (ccl::io-buffer-listen-function io-buffer) stream io-buffer)))))))) + +(defmethod connection-established-p ((stream ccl::opentransport-stream)) + (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil)) + (let ((state (ccl::opentransport-stream-connection-state stream))) + (not (eq :unbnd state))))) + +(defun wait-for-input-internal (wait-list &key timeout &aux result) + (labels ((ready-sockets (sockets) + (dolist (sock sockets result) + (when (cond ((stream-usocket-p sock) + (input-available-p (socket-stream sock))) + ((stream-server-usocket-p sock) + (let ((ot-stream (first (socket-streams (socket sock))))) + (or (input-available-p ot-stream) + (connection-established-p ot-stream))))) + (push sock result))))) + (with-mapped-conditions () + (ccl:process-wait-with-timeout + "socket input" + (when timeout (truncate (* timeout 60))) + #'ready-sockets + (wait-list-waiters wait-list))) + (nreverse result))) + +;;; datagram socket methods + +(defmethod initialize-instance :after ((usocket datagram-usocket) &key) + (with-slots (socket send-buffer recv-buffer) usocket + (setq send-buffer + (ccl::make-TUnitData (ccl::ot-conn-endpoint socket))) + (setq recv-buffer + (ccl::make-TUnitData (ccl::ot-conn-endpoint socket))))) + +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) + (with-mapped-conditions (usocket host) + (with-slots (socket send-buffer) usocket + (unless (and host port) + (unsupported 'host 'socket-send)) + (ccl::send-message socket send-buffer buffer size host port offset)))) + +(defmethod socket-receive ((usocket datagram-usocket) buffer length &key) + (with-mapped-conditions (usocket) + (with-slots (socket recv-buffer) usocket + (ccl::receive-message socket recv-buffer buffer length)))) + +(defmethod socket-close ((socket datagram-usocket)) + nil) ; TODO diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mezzano.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mezzano.lisp new file mode 100644 index 0000000..225c77d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mezzano.lisp @@ -0,0 +1,99 @@ +;;;; -*- Mode: Common-Lisp -*- + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defun handle-condition (condition &optional (socket nil)) + (typecase condition + ;; TODO: Add additional conditions as appropriate + (mezzano.network.tcp:connection-timed-out + (error 'timeout-error :socket socket)))) + +(defun socket-connect (host port &key (protocol :stream) element-type + timeout deadline (nodelay nil nodelay-p) + local-host local-port) + (declare (ignore local-host local-port)) + (when deadline + (unsupported 'deadline 'socket-connect)) + (when (and nodelay-p (not (eq nodelay :if-supported))) + (unsupported 'nodelay 'socket-connect)) + (when timeout + (unsupported 'timeout 'socket-connect)) + (with-mapped-conditions () + (ecase protocol + (:stream + (let ((s (mezzano.network.tcp:tcp-stream-connect host port :element-type element-type))) + (make-stream-socket :socket s + :stream s))) + (:datagram + ;; TODO: + (unsupported 'datagram 'socket-connect))))) + +(defun socket-listen (host port &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (declare (ignore reuseaddress reuse-address reuse-address-supplied-p)) + (let ((ip (mezzano.network.ip:make-ipv4-address host))) + (make-stream-server-socket (mezzano.network.tcp:tcp-listen ip port :backlog backlog) + :element-type element-type))) + +(defun get-hosts-by-name (name) + (declare (ignore name))) + +(defun get-host-by-address (address) + (declare (ignore address))) + +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + +(defun %remove-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + +(defun wait-for-input-internal (wait-list &key timeout) + (declare (ignore wait-list timeout))) + +(defmethod socket-close ((usocket stream-usocket)) + (with-mapped-conditions () + (close (socket-stream usocket)))) + +(defmethod socket-close ((usocket stream-server-usocket)) + (with-mapped-conditions () + (mezzano.network.tcp:close-tcp-listener (socket usocket)))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (declare (ignore element-type)) + (with-mapped-conditions (usocket) + (let ((s (mezzano.network.tcp:tcp-accept (socket usocket)))) + (make-stream-socket :socket s + :stream s)))) + +(defmethod get-local-name ((usocket stream-usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defmethod get-local-address ((usocket stream-usocket)) + (mezzano.network.ip:ipv4-address-to-string + (mezzano.network.tcp:tcp-connection-local-ip + (mezzano.network.tcp:tcp-stream-connection (socket usocket))))) + +(defmethod get-local-port ((usocket stream-usocket)) + (mezzano.network.tcp:tcp-connection-local-port + (mezzano.network.tcp:tcp-stream-connection (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (mezzano.network.ip:ipv4-address-to-string + (mezzano.network.tcp:tcp-connection-remote-ip + (mezzano.network.tcp:tcp-stream-connection (socket usocket))))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (mezzano.network.tcp:tcp-connection-remote-port + (mezzano.network.tcp:tcp-stream-connection (socket usocket)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mocl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mocl.lisp new file mode 100644 index 0000000..1157b0d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mocl.lisp @@ -0,0 +1,155 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) + "Dispatch correct usocket condition." + (declare (ignore socket)) + (signal condition)) + +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) + timeout deadline (nodelay t nodelay-specified) + (local-host nil local-host-p) + (local-port nil local-port-p)) + (when (and nodelay-specified + (not (eq nodelay :if-supported))) + (unsupported 'nodelay 'socket-connect)) + (when deadline (unsupported 'deadline 'socket-connect)) + (when timeout (unimplemented 'timeout 'socket-connect)) + (when local-host-p + (unimplemented 'local-host 'socket-connect)) + (when local-port-p + (unimplemented 'local-port 'socket-connect)) + + (let (socket) + (ecase protocol + (:stream + (setf socket (rt::socket-connect host port)) + (let ((stream (rt::make-socket-stream socket :binaryp (not (eq element-type 'character))))) + (make-stream-socket :socket socket :stream stream))) + (:datagram + (error 'unsupported + :feature '(protocol :datagram) + :context 'socket-connect))))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (unimplemented 'socket-listen 'mocl)) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (unimplemented 'socket-accept 'mocl)) + +;; Sockets and their associated streams are modelled as +;; different objects. Be sure to close the socket stream +;; when closing stream-sockets; it makes sure buffers +;; are flushed and the socket is closed correctly afterwards. +(defmethod socket-close ((usocket usocket)) + "Close socket." + (rt::socket-shutdown usocket) + (rt::c-fclose usocket)) + +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (close (socket-stream usocket))) + +;; (defmethod socket-close :after ((socket datagram-usocket)) +;; (setf (%open-p socket) nil)) + +(defmethod socket-shutdown ((usocket stream-usocket) direction) + (declare (ignore usocket direction)) + ;; sure would be nice if there was some documentation for mocl... + (unimplemented "shutdown" 'socket-shutdown)) + +;; (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port) +;; (let ((s (socket usocket)) +;; (host (if host (host-to-hbo host))) +;; (real-buffer (if (zerop offset) +;; buffer +;; (subseq buffer offset (+ offset size))))) +;; (multiple-value-bind (result errno) +;; (ext:inet-socket-send-to s real-buffer size +;; :remote-host host :remote-port port) +;; (or result +;; (mocl-map-socket-error errno :socket usocket))))) + +;; (defmethod socket-receive ((socket datagram-usocket) buffer length &key) +;; (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer +;; (integer 0) ; size +;; (unsigned-byte 32) ; host +;; (unsigned-byte 16))) ; port +;; (let ((s (socket socket))) +;; (let ((real-buffer (or buffer +;; (make-array length :element-type '(unsigned-byte 8)))) +;; (real-length (or length +;; (length buffer)))) +;; (multiple-value-bind (result errno remote-host remote-port) +;; (ext:inet-socket-receive-from s real-buffer real-length) +;; (if result +;; (values real-buffer result remote-host remote-port) +;; (mocl-map-socket-error errno :socket socket)))))) + +;; (defmethod get-local-name ((usocket usocket)) +;; (multiple-value-bind (address port) +;; (with-mapped-conditions (usocket) +;; (ext:get-socket-host-and-port (socket usocket))) +;; (values (hbo-to-vector-quad address) port))) + +;; (defmethod get-peer-name ((usocket stream-usocket)) +;; (multiple-value-bind (address port) +;; (with-mapped-conditions (usocket) +;; (ext:get-peer-host-and-port (socket usocket))) +;; (values (hbo-to-vector-quad address) port))) + +;; (defmethod get-local-address ((usocket usocket)) +;; (nth-value 0 (get-local-name usocket))) + +;; (defmethod get-peer-address ((usocket stream-usocket)) +;; (nth-value 0 (get-peer-name usocket))) + +;; (defmethod get-local-port ((usocket usocket)) +;; (nth-value 1 (get-local-name usocket))) + +;; (defmethod get-peer-port ((usocket stream-usocket)) +;; (nth-value 1 (get-peer-name usocket))) + + +;; (defun get-host-by-address (address) +;; (multiple-value-bind (host errno) +;; (ext:lookup-host-entry (host-byte-order address)) +;; (cond (host +;; (ext:host-entry-name host)) +;; (t +;; (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) +;; (cond (condition +;; (error condition :host-or-ip address)) +;; (t +;; (error 'ns-unknown-error :host-or-ip address +;; :real-error errno)))))))) + +(defun get-hosts-by-name (name) + (rt::lookup-host name)) + +;; (defun get-host-name () +;; (unix:unix-gethostname)) + + +;; +;; +;; WAIT-LIST part +;; + + +(defun %add-waiter (wl waiter) + (declare (ignore wl waiter))) + +(defun %remove-waiter (wl waiter) + (declare (ignore wl waiter))) + +(defun %setup-wait-list (wl) + (declare (ignore wl))) + +(defun wait-for-input-internal (wait-list &key timeout) + (unimplemented 'wait-for-input-internal 'mocl)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/openmcl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/openmcl.lisp new file mode 100644 index 0000000..113692d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/openmcl.lisp @@ -0,0 +1,268 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defun get-host-name () + (ccl::%stack-block ((resultbuf 256)) + (when (zerop (#_gethostname resultbuf 256)) + (ccl::%get-cstring resultbuf)))) + +(defparameter +openmcl-error-map+ + '((:address-in-use . address-in-use-error) + (:connection-aborted . connection-aborted-error) + (:no-buffer-space . no-buffers-error) + (:connection-timed-out . timeout-error) + (:connection-refused . connection-refused-error) + (:host-unreachable . host-unreachable-error) + (:host-down . host-down-error) + (:network-down . network-down-error) + (:address-not-available . address-not-available-error) + (:network-reset . network-reset-error) + (:connection-reset . connection-reset-error) + (:shutdown . shutdown-error) + (:access-denied . operation-not-permitted-error))) + +(defparameter +openmcl-nameserver-error-map+ + '((:no-recovery . ns-no-recovery-error) + (:try-again . ns-try-again-condition) + (:host-not-found . ns-host-not-found-error))) + +;; we need something which the openmcl implementors 'forgot' to do: +;; wait for more than one socket-or-fd + +(defun input-available-p (sockets &optional ticks-to-wait) + (ccl::rletz ((tv :timeval)) + (ccl::ticks-to-timeval ticks-to-wait tv) + ;;### The trickery below can be moved to the wait-list now... + (ccl::%stack-block ((infds ccl::*fd-set-size*)) + (ccl::fd-zero infds) + (let ((max-fd -1)) + (dolist (sock sockets) + (let ((fd (openmcl-socket:socket-os-fd (socket sock)))) + (when fd ;; may be NIL if closed + (setf max-fd (max max-fd fd)) + (ccl::fd-set fd infds)))) + (let ((res (#_select (1+ max-fd) + infds (ccl::%null-ptr) (ccl::%null-ptr) + (if ticks-to-wait tv (ccl::%null-ptr))))) + (when (> res 0) + (dolist (sock sockets) + (let ((fd (openmcl-socket:socket-os-fd (socket sock)))) + (when (and fd (ccl::fd-is-set fd infds)) + (setf (state sock) :READ))))) + sockets))))) + +(defun raise-error-from-id (condition-id socket real-condition) + (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+)))) + (if usock-err + (error usock-err :socket socket) + (error 'unknown-error :socket socket :real-error real-condition)))) + +(defun handle-condition (condition &optional socket (host-or-ip nil)) + (typecase condition + (openmcl-socket:socket-error + (raise-error-from-id (openmcl-socket:socket-error-identifier condition) + socket condition)) + (ccl:input-timeout + (error 'timeout-error :socket socket)) + (ccl:communication-deadline-expired + (error 'deadline-timeout-error :socket socket)) + (ccl::socket-creation-error #| ugh! |# + (let* ((condition-id (ccl::socket-creation-error-identifier condition)) + (nameserver-error (cdr (assoc condition-id + +openmcl-nameserver-error-map+)))) + (if nameserver-error + (if (typep nameserver-error 'serious-condition) + (error nameserver-error :host-or-ip host-or-ip) + (signal nameserver-error :host-or-ip host-or-ip)) + (raise-error-from-id condition-id socket condition)))))) + +(defun to-format (element-type protocol) + (cond ((null element-type) + (ecase protocol ; default value of different protocol + (:stream :text) + (:datagram :binary))) + ((subtypep element-type 'character) + :text) + (t :binary))) + +#-ipv6 +(defun socket-connect (host port &key (protocol :stream) element-type + timeout deadline nodelay + local-host local-port) + (when (eq nodelay :if-supported) + (setf nodelay t)) + (with-mapped-conditions (nil host) + (ecase protocol + (:stream + (let ((mcl-sock + (openmcl-socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :local-host local-host + :local-port local-port + :format (to-format element-type protocol) + :external-format ccl:*default-external-format* + :deadline deadline + :nodelay nodelay + :connect-timeout timeout))) + (make-stream-socket :stream mcl-sock :socket mcl-sock))) + (:datagram + (let* ((mcl-sock + (openmcl-socket:make-socket :address-family :internet + :type :datagram + :local-host local-host + :local-port local-port + :input-timeout timeout + :format (to-format element-type protocol) + :external-format ccl:*default-external-format*)) + (usocket (make-datagram-socket mcl-sock))) + (when (and host port) + (ccl::inet-connect (ccl::socket-device mcl-sock) + (ccl::host-as-inet-host host) + (ccl::port-as-inet-port port "udp"))) + (setf (connected-p usocket) t) + usocket))))) + +#-ipv6 +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (real-host (host-to-hostname host)) + (sock (with-mapped-conditions (nil host) + (apply #'openmcl-socket:make-socket + (append (list :connect :passive + :reuse-address reuseaddress + :local-port port + :backlog backlog + :format (to-format element-type :stream)) + (unless (eq host *wildcard-host*) + (list :local-host real-host))))))) + (make-stream-server-socket sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (declare (ignore element-type)) ;; openmcl streams are bi/multivalent + (let ((sock (with-mapped-conditions (usocket) + (openmcl-socket:accept-connection (socket usocket))))) + (make-stream-socket :socket sock :stream sock))) + +;; One close method is sufficient because sockets +;; and their associated objects are represented +;; by the same object. +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (close (socket usocket)))) + +(defmethod socket-shutdown ((usocket usocket) direction) + (with-mapped-conditions (usocket) + (openmcl-socket:shutdown (socket usocket) :direction direction))) + +#-ipv6 +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) + (with-mapped-conditions (usocket host) + (if (and host port) + (openmcl-socket:send-to (socket usocket) buffer size + :remote-host (host-to-hbo host) + :remote-port port + :offset offset) + ;; Clozure CL's socket function SEND-TO doesn't support operations on connected UDP sockets, + ;; so we have to define our own. + (let* ((socket (socket usocket)) + (fd (ccl::socket-device socket))) + (multiple-value-setq (buffer offset) + (ccl::verify-socket-buffer buffer offset size)) + (ccl::%stack-block ((bufptr size)) + (ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size) + (ccl::socket-call socket "send" + (ccl::with-eagain fd :output + (ccl::ignoring-eintr + (ccl::check-socket-error (#_send fd bufptr size 0)))))))))) + +(defmethod socket-receive ((usocket datagram-usocket) buffer length &key) + (with-mapped-conditions (usocket) + (openmcl-socket:receive-from (socket usocket) length :buffer buffer))) + +(defun usocket-host-address (address) + (cond + ((integerp address) + (hbo-to-vector-quad address)) + ((and (arrayp address) + (= (length address) 16) + (every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff))) + (make-array 4 :displaced-to address :displaced-index-offset 12)) + (t + address))) + +(defmethod get-local-address ((usocket usocket)) + (usocket-host-address (openmcl-socket:local-host (socket usocket)))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (usocket-host-address (openmcl-socket:remote-host (socket usocket)))) + +(defmethod get-local-port ((usocket usocket)) + (openmcl-socket:local-port (socket usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (openmcl-socket:remote-port (socket usocket))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defun get-host-by-address (address) + (with-mapped-conditions (nil address) + (openmcl-socket:ipaddr-to-hostname (host-to-hbo address)))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions (nil name) + (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname + (host-to-hostname name)))))) + +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + +(defun %remove-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + +(defun wait-for-input-internal (wait-list &key timeout) + (with-mapped-conditions () + (let* ((ticks-timeout (truncate (* (or timeout 1) + ccl::*ticks-per-second*)))) + (input-available-p (wait-list-waiters wait-list) + (when timeout ticks-timeout)) + wait-list))) + +;;; Helper functions for option.lisp + +(defun get-socket-option-reuseaddr (socket) + (ccl::int-getsockopt (ccl::socket-device socket) + #$SOL_SOCKET #$SO_REUSEADDR)) + +(defun set-socket-option-reuseaddr (socket value) + (ccl::int-setsockopt (ccl::socket-device socket) + #$SOL_SOCKET #$SO_REUSEADDR value)) + +(defun get-socket-option-broadcast (socket) + (ccl::int-getsockopt (ccl::socket-device socket) + #$SOL_SOCKET #$SO_BROADCAST)) + +(defun set-socket-option-broadcast (socket value) + (ccl::int-setsockopt (ccl::socket-device socket) + #$SOL_SOCKET #$SO_BROADCAST value)) + +(defun get-socket-option-tcp-nodelay (socket) + (ccl::int-getsockopt (ccl::socket-device socket) + #$IPPROTO_TCP #$TCP_NODELAY)) + +(defun set-socket-option-tcp-nodelay (socket value) + (ccl::int-setsockopt (ccl::socket-device socket) + #$IPPROTO_TCP #$TCP_NODELAY value)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/sbcl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/sbcl.lisp new file mode 100644 index 0000000..5684430 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/sbcl.lisp @@ -0,0 +1,935 @@ +;;;; -*- Mode: Common-Lisp -*- + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +#+sbcl +(progn + #-win32 + (defun get-host-name () + (sb-unix:unix-gethostname)) + + ;; we assume winsock has already been loaded, after all, + ;; we already loaded sb-bsd-sockets and sb-alien + #+win32 + (defun get-host-name () + (sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256))) + (let ((result (sb-alien:alien-funcall + (sb-alien:extern-alien "gethostname" + (sb-alien:function sb-alien:int + (* sb-alien:char) + sb-alien:int)) + (sb-alien:cast buf (* sb-alien:char)) + 256))) + (when (= result 0) + (sb-alien:cast buf sb-alien:c-string)))))) + +#+(and ecl (not ecl-bytecmp)) +(progn + #-:wsock + (ffi:clines + "#include " + "#include " + "#include ") + #+:wsock + (ffi:clines + "#ifndef FD_SETSIZE" + "#define FD_SETSIZE 1024" + "#endif" + "#include ") + + (ffi:clines + #+:msvc "#include " + #-:msvc "#include " + "#include ") +#| + #+:prefixed-api + (ffi:clines + "#define CONS(x, y) ecl_cons((x), (y))" + "#define MAKE_INTEGER(x) ecl_make_integer((x))") + #-:prefixed-api + (ffi:clines + "#define CONS(x, y) make_cons((x), (y))" + "#define MAKE_INTEGER(x) make_integer((x))") +|# + + (defun cerrno () + (ffi:c-inline () () :int + "errno" :one-liner t)) + + (defun fd-setsize () + (ffi:c-inline () () :fixnum + "FD_SETSIZE" :one-liner t)) + + (defun fdset-alloc () + (ffi:c-inline () () :pointer-void + "ecl_alloc_atomic(sizeof(fd_set))" :one-liner t)) + + (defun fdset-zero (fdset) + (ffi:c-inline (fdset) (:pointer-void) :void + "FD_ZERO((fd_set*)#0)" :one-liner t)) + + (defun fdset-set (fdset fd) + (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void + "FD_SET(#1,(fd_set*)#0)" :one-liner t)) + + (defun fdset-clr (fdset fd) + (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void + "FD_CLR(#1,(fd_set*)#0)" :one-liner t)) + + (defun fdset-fd-isset (fdset fd) + (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool + "FD_ISSET(#1,(fd_set*)#0)" :one-liner t)) + + (declaim (inline cerrno + fd-setsize + fdset-alloc + fdset-zero + fdset-set + fdset-clr + fdset-fd-isset)) + + (defun get-host-name () + (ffi:c-inline + () () :object + "{ char *buf = (char *) ecl_alloc_atomic(257); + + if (gethostname(buf,256) == 0) + @(return) = make_simple_base_string(buf); + else + @(return) = Cnil; + }" :one-liner nil :side-effects nil)) + + (defun read-select (wl to-secs &optional (to-musecs 0)) + (let* ((sockets (wait-list-waiters wl)) + (rfds (wait-list-%wait wl)) + (max-fd (reduce #'(lambda (x y) + (let ((sy (sb-bsd-sockets:socket-file-descriptor + (socket y)))) + (if (< x sy) sy x))) + (cdr sockets) + :initial-value (sb-bsd-sockets:socket-file-descriptor + (socket (car sockets)))))) + (fdset-zero rfds) + (dolist (sock sockets) + (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor + (socket sock)))) + (let ((count + (ffi:c-inline (to-secs to-musecs rfds max-fd) + (t :unsigned-int :pointer-void :int) + :int + " + int count; + struct timeval tv; + struct timeval tvs; + struct timeval tve; + unsigned long elapsed; + unsigned long remaining; + int retval = -1; + + if (#0 != Cnil) { + tv.tv_sec = fixnnint(#0); + tv.tv_usec = #1; + } + remaining = ((tv.tv_sec*1000000) + tv.tv_usec); + + do { + (void)gettimeofday(&tvs, NULL); // start time + + retval = select(#3 + 1, (fd_set*)#2, NULL, NULL, + (#0 != Cnil) ? &tv : NULL); + + if ( (retval < 0) && (errno == EINTR) && (#0 != Cnil) ) { + (void)gettimeofday(&tve, NULL); // end time + elapsed = (tve.tv_sec - tvs.tv_sec)*1000000 + (tve.tv_usec - tvs.tv_usec); + remaining = remaining - elapsed; + if ( remaining < 0 ) { // already past timeout, just exit + retval = 0; + break; + } + + tv.tv_sec = remaining / 1000000; + tv.tv_usec = remaining - (tv.tv_sec * 1000000); + } + + } while ((retval < 0) && (errno == EINTR)); + + @(return) = retval; +" :one-liner nil))) + (cond + ((= 0 count) + (values nil nil)) + ((< count 0) + ;; check for EAGAIN; these should not err + (values nil (cerrno))) + (t + (dolist (sock sockets) + (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor + (socket sock))) + (setf (state sock) :READ)))))))) +) ; progn + +(defun map-socket-error (sock-err) + (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err))) + +(defparameter +sbcl-condition-map+ + '((interrupted-error . interrupted-condition))) + +(defparameter +sbcl-error-map+ + `((sb-bsd-sockets:address-in-use-error . address-in-use-error) + (sb-bsd-sockets::no-address-error . address-not-available-error) + (sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error) + (sb-bsd-sockets:connection-refused-error . connection-refused-error) + (sb-bsd-sockets:invalid-argument-error . invalid-argument-error) + (sb-bsd-sockets:no-buffers-error . no-buffers-error) + (sb-bsd-sockets:operation-not-supported-error + . operation-not-supported-error) + (sb-bsd-sockets:operation-not-permitted-error + . operation-not-permitted-error) + (sb-bsd-sockets:protocol-not-supported-error + . protocol-not-supported-error) + #-(or ecl clasp) + (sb-bsd-sockets:unknown-protocol + . protocol-not-supported-error) + (sb-bsd-sockets:socket-type-not-supported-error + . socket-type-not-supported-error) + (sb-bsd-sockets:network-unreachable-error . network-unreachable-error) + (sb-bsd-sockets:operation-timeout-error . timeout-error) + #-(or ecl clasp) + (sb-sys:io-timeout . timeout-error) + #+sbcl + (sb-ext:timeout . timeout-error) + (sb-bsd-sockets:socket-error . ,#'map-socket-error) + + ;; Nameservice errors: mapped to unknown-error + #-(or ecl clasp) + (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error) + #-(or ecl clasp) + (sb-bsd-sockets:try-again-error . ns-try-again-condition) + #-(or ecl clasp) + (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error))) + +;; this function servers as a general template for other backends +(defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) + "Dispatch correct usocket condition." + (typecase condition + (serious-condition + (let* ((usock-error (cdr (assoc (type-of condition) +sbcl-error-map+))) + (usock-error (if (functionp usock-error) + (funcall usock-error condition) + usock-error))) + (declare (type symbol usock-error)) + (if usock-error + (cond ((subtypep usock-error 'ns-error) + (error usock-error :socket socket :host-or-ip host-or-ip)) + (t + (error usock-error :socket socket))) + (error 'unknown-error + :real-error condition + :socket socket)))) + (condition + (let* ((usock-cond (cdr (assoc (type-of condition) +sbcl-condition-map+))) + (usock-cond (if (functionp usock-cond) + (funcall usock-cond condition) + usock-cond))) + (if usock-cond + (cond ((subtypep usock-cond 'ns-condition) + (signal usock-cond :socket socket :host-or-ip host-or-ip)) + (t + (signal usock-cond :socket socket))) + (signal 'unknown-condition + :real-condition condition + :socket socket)))))) + +;;; "The socket stream ends up with a bogus name as it is created before +;;; the socket is connected, making things harder to debug than they need +;;; to be." -- Nikodemus Siivola + +(defvar *dummy-stream* + (let ((stream (make-broadcast-stream))) + (close stream) + stream)) + +;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch +;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS +;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than +;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola + +#+(and sbcl (not win32)) +(defmacro %with-timeout ((seconds timeout-form) &body body) + "Runs BODY as an implicit PROGN with timeout of SECONDS. If +timeout occurs before BODY has finished, BODY is unwound and +TIMEOUT-FORM is executed with its values returned instead. + +Note that BODY is unwound asynchronously when a timeout occurs, +so unless all code executed during it -- including anything +down the call chain -- is asynch unwind safe, bad things will +happen. Use with care." + (let ((exec (gensym)) (unwind (gensym)) (timer (gensym)) + (timeout (gensym)) (block (gensym))) + `(block ,block + (tagbody + (flet ((,unwind () + (go ,timeout)) + (,exec () + ,@body)) + (declare (dynamic-extent #',exec #',unwind)) + (let ((,timer (sb-ext:make-timer #',unwind))) + (declare (dynamic-extent ,timer)) + (sb-sys:without-interrupts + (unwind-protect + (progn + (sb-ext:schedule-timer ,timer ,seconds) + (return-from ,block + (sb-sys:with-local-interrupts + (,exec)))) + (sb-ext:unschedule-timer ,timer))))) + ,timeout + (return-from ,block ,timeout-form))))) + +(defun get-hosts-by-name (name) + (with-mapped-conditions (nil name) + (multiple-value-bind (host4 host6) + (sb-bsd-sockets:get-host-by-name name) + (let ((addr4 (when host4 + (sb-bsd-sockets::host-ent-addresses host4))) + (addr6 (when host6 + (sb-bsd-sockets::host-ent-addresses host6)))) + (append addr4 addr6))))) + +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) + timeout deadline (nodelay t nodelay-specified) + local-host local-port + &aux + (sockopt-tcp-nodelay-p + (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay))) + (when deadline (unsupported 'deadline 'socket-connect)) + #+(or ecl clasp) + (when timeout (unsupported 'timeout 'socket-connect)) + (when (and nodelay-specified + ;; 20080802: ECL added this function to its sockets + ;; package today. There's no guarantee the functions + ;; we need are available, but we can make sure not to + ;; call them if they aren't + (not (eq nodelay :if-supported)) + (not sockopt-tcp-nodelay-p)) + (unsupported 'nodelay 'socket-connect)) + (when (eq nodelay :if-supported) + (setf nodelay t)) + + (let* ((remote (when host + (car (get-hosts-by-name (host-to-hostname host))))) + (local (when local-host + (car (get-hosts-by-name (host-to-hostname local-host))))) + (ipv6 (or (and remote (= 16 (length remote))) + (and local (= 16 (length local))))) + (socket (make-instance #+sbcl (if ipv6 + 'sb-bsd-sockets::inet6-socket + 'sb-bsd-sockets:inet-socket) + #+(or ecl clasp) 'sb-bsd-sockets:inet-socket + :type protocol + :protocol (case protocol + (:stream :tcp) + (:datagram :udp)))) + usocket + ok) + + (unwind-protect + (progn + (ecase protocol + (:stream + ;; If make a real socket stream before the socket is + ;; connected, it gets a misleading name so supply a + ;; dummy value to start with. + (setf usocket (make-stream-socket :socket socket :stream *dummy-stream*)) + ;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol + ;; to pass compilation on ECL without it. + (when (and nodelay-specified sockopt-tcp-nodelay-p) + (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay)) + (when (or local-host local-port) + (sb-bsd-sockets:socket-bind socket + (if ipv6 + (or local (ipv6-host-to-vector "::0")) + (or local (host-to-vector-quad *wildcard-host*))) + (or local-port *auto-port*))) + + (with-mapped-conditions (usocket host) + #+(and sbcl (not win32)) + (labels ((connect () + (sb-bsd-sockets:socket-connect socket remote port))) + (if timeout + (%with-timeout (timeout (error 'sb-ext:timeout)) (connect)) + (connect))) + #+(or ecl clasp (and sbcl win32)) + (sb-bsd-sockets:socket-connect socket remote port) + ;; Now that we're connected make the stream. + (setf (socket-stream usocket) + (sb-bsd-sockets:socket-make-stream socket + :input t :output t :buffering :full + :element-type element-type + ;; Robert Brown said on Aug 4, 2011: + ;; ... This means that SBCL streams created by usocket have a true + ;; serve-events property. When writing large amounts of data to several + ;; streams, the kernel will eventually stop accepting data from SBCL. + ;; When this happens, SBCL either waits for I/O to be possible on + ;; the file descriptor it's writing to or queues the data to be flushed later. + ;; Because usocket streams specify serve-events as true, SBCL + ;; always queues. Instead, it should wait for I/O to be available and + ;; write the remaining data to the socket. That's what serve-events + ;; equal to NIL gets you. + ;; + ;; Nikodemus Siivola said on Aug 8, 2011: + ;; It's set to T for purely historical reasons, and will soon change to + ;; NIL in SBCL. (The docstring has warned of T being a temporary default + ;; for as long as the :SERVE-EVENTS keyword argument has existed.) + :serve-events nil)))) + (:datagram + (when (or local-host local-port) + (sb-bsd-sockets:socket-bind socket + (if ipv6 + (or local (ipv6-host-to-vector "::0")) + (or local (host-to-vector-quad *wildcard-host*))) + (or local-port *auto-port*))) + (setf usocket (make-datagram-socket socket)) + (when (and host port) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-connect socket remote port) + (setf (connected-p usocket) t))))) + (setf ok t)) + ;; Clean up in case of an error. + (unless ok + (sb-bsd-sockets:socket-close socket :abort t))) + usocket)) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* (#+sbcl + (local (when host + (car (get-hosts-by-name (host-to-hostname host))))) + #+sbcl + (ipv6 (and local (= 16 (length local)))) + (reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (ip #+sbcl (if (and local (not (eq host *wildcard-host*))) + local + (hbo-to-vector-quad sb-bsd-sockets-internal::inaddr-any)) + #+(or ecl clasp) (host-to-vector-quad host)) + (sock (make-instance #+sbcl (if ipv6 + 'sb-bsd-sockets::inet6-socket + 'sb-bsd-sockets:inet-socket) + #+(or ecl clasp) 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (handler-case + (with-mapped-conditions (nil host) + (setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress) + (sb-bsd-sockets:socket-bind sock ip port) + (sb-bsd-sockets:socket-listen sock backlog) + (make-stream-server-socket sock :element-type element-type)) + (t (c) + ;; Make sure we don't leak filedescriptors + (sb-bsd-sockets:socket-close sock) + (error c))))) + +;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR, +;;; instead of raising a condition. It's always possible for +;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket +;;; was detected to be ready: connection might be reset, for example. +;;; +;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to +;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (with-mapped-conditions (usocket) + (let ((socket (sb-bsd-sockets:socket-accept (socket usocket)))) + (when socket + (prog1 + (make-stream-socket + :socket socket + :stream (sb-bsd-sockets:socket-make-stream + socket + :input t :output t :buffering :full + :element-type (or element-type + (element-type usocket)))) + + ;; next time wait for event again if we had EAGAIN/EINTR + ;; or else we'd enter a tight loop of failed accepts + #+win32 + (setf (%ready-p usocket) nil)))))) + +;; Sockets and their associated streams are modelled as +;; different objects. Be sure to close the stream (which +;; closes the socket too) when closing a stream-socket. +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-close (socket usocket)))) + +(defmethod socket-close ((usocket stream-usocket)) + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +#+sbcl +(defmethod socket-shutdown ((usocket stream-usocket) direction) + (with-mapped-conditions (usocket) + (sb-bsd-sockets::socket-shutdown (socket usocket) :direction direction))) + +#+ecl +(defmethod socket-shutdown ((usocket stream-usocket) direction) + (let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket))) + (direction-flag (ecase direction + (:input 0) + (:output 1)))) + (unless (zerop (ffi:c-inline (sock-fd direction-flag) (:int :int) :int + "shutdown(#0, #1)" :one-liner t)) + (error (map-errno-error (cerrno)))))) + +#+clasp +(defmethod socket-shutdown ((usocket stream-usocket) direction) + (let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket))) + (direction-flag (ecase direction + (:input 0) + (:output 1)))) + (unless (zerop (sockets-internal:shutdown sock-fd direction-flag)) + (error (map-errno-error (cerrno)))))) + +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) + (let ((remote (when host + (car (get-hosts-by-name (host-to-hostname host)))))) + (with-mapped-conditions (usocket host) + (let* ((s (socket usocket)) + (dest (if (and host port) (list remote port) nil)) + (real-buffer (if (zerop offset) + buffer + (subseq buffer offset (+ offset size))))) + (sb-bsd-sockets:socket-send s real-buffer size :address dest))))) + +(defmethod socket-receive ((usocket datagram-usocket) buffer length + &key (element-type '(unsigned-byte 8))) + #+sbcl + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (simple-array (unsigned-byte 8) (*)) ; host + (unsigned-byte 16))) ; port + (with-mapped-conditions (usocket) + (let ((s (socket usocket))) + (sb-bsd-sockets:socket-receive s buffer length :element-type element-type)))) + +(defmethod get-local-name ((usocket usocket)) + (sb-bsd-sockets:socket-name (socket usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (sb-bsd-sockets:socket-peername (socket usocket))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + +(defun get-host-by-address (address) + (with-mapped-conditions (nil address) + (sb-bsd-sockets::host-ent-name + (sb-bsd-sockets:get-host-by-address address)))) + +#+(and sbcl (not win32)) +(progn + (defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + + (defun %add-waiter (wait-list waiter) + (push (socket waiter) (wait-list-%wait wait-list))) + + (defun %remove-waiter (wait-list waiter) + (setf (wait-list-%wait wait-list) + (remove (socket waiter) (wait-list-%wait wait-list)))) + + (defun wait-for-input-internal (sockets &key timeout) + (with-mapped-conditions () + (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set))) + (sb-unix:fd-zero rfds) + (dolist (socket (wait-list-%wait sockets)) + (sb-unix:fd-set + (sb-bsd-sockets:socket-file-descriptor socket) + rfds)) + (multiple-value-bind + (secs musecs) + (split-timeout (or timeout 1)) + (let* ((wait-list (wait-list-%wait sockets)) + count err) + (if (null wait-list) + (setq count 0) ;; no need to call + (multiple-value-setq (count err) + (sb-unix:unix-fast-select + ;; "invalid number of arguments: 0" if wait-list is null. + (1+ (reduce #'max wait-list + :key #'sb-bsd-sockets:socket-file-descriptor)) + (sb-alien:addr rfds) nil nil + (when timeout secs) (when timeout musecs)))) + (if (null count) ; something wrong in #'sb-unix:unix-fast-select + (unless (= err sb-unix:eintr) + (error (map-errno-error err))) + (when (< 0 count) ; do nothing if count = 0 + ;; process the result... + (dolist (x (wait-list-waiters sockets)) + (when (sb-unix:fd-isset + (sb-bsd-sockets:socket-file-descriptor + (socket x)) + rfds) + (setf (state x) :READ)))))))))) +) ; progn + +;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe)) +;;; Based on LispWorks version written by Erik Huelsmann. + +#+win32 ; shared by ECL and SBCL +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +wsa-wait-failed+ #xffffffff) + (defconstant +wsa-infinite+ #xffffffff) + (defconstant +wsa-wait-event-0+ 0) + (defconstant +wsa-wait-timeout+ 258)) + +#+win32 ; shared by ECL and SBCL +(progn + (defconstant fd-read 1) + (defconstant fd-read-bit 0) + (defconstant fd-write 2) + (defconstant fd-write-bit 1) + (defconstant fd-oob 4) + (defconstant fd-oob-bit 2) + (defconstant fd-accept 8) + (defconstant fd-accept-bit 3) + (defconstant fd-connect 16) + (defconstant fd-connect-bit 4) + (defconstant fd-close 32) + (defconstant fd-close-bit 5) + (defconstant fd-qos 64) + (defconstant fd-qos-bit 6) + (defconstant fd-group-qos 128) + (defconstant fd-group-qos-bit 7) + (defconstant fd-routing-interface 256) + (defconstant fd-routing-interface-bit 8) + (defconstant fd-address-list-change 512) + (defconstant fd-address-list-change-bit 9) + (defconstant fd-max-events 10) + (defconstant fionread 1074030207) + + ;; Note: for ECL, socket-handle will return raw Windows Handle, + ;; while SBCL returns OSF Handle instead. + (defun socket-handle (usocket) + (sb-bsd-sockets:socket-file-descriptor (socket usocket))) + + (defun socket-ready-p (socket) + (if (typep socket 'stream-usocket) + (plusp (bytes-available-for-read socket)) + (%ready-p socket))) + + (defun waiting-required (sockets) + (notany #'socket-ready-p sockets)) + + (defun raise-usock-err (errno &optional socket) + (error 'unknown-error + :socket socket + :real-error errno)) + + (defun wait-for-input-internal (wait-list &key timeout) + (when (waiting-required (wait-list-waiters wait-list)) + (let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list) + nil + (if timeout + (truncate (* 1000 timeout)) + +wsa-infinite+) + nil))) + (ecase rv + ((#.+wsa-wait-event-0+) + (update-ready-and-state-slots wait-list)) + ((#.+wsa-wait-timeout+)) ; do nothing here + ((#.+wsa-wait-failed+) + (maybe-wsa-error rv)))))) + + (defun %add-waiter (wait-list waiter) + (let ((events (etypecase waiter + (stream-server-usocket (logior fd-connect fd-accept fd-close)) + (stream-usocket (logior fd-read)) + (datagram-usocket (logior fd-read))))) + (maybe-wsa-error + (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events) + waiter))) + + (defun %remove-waiter (wait-list waiter) + (maybe-wsa-error + (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0) + waiter)) +) ; progn + +#+(and sbcl win32) +(progn + ;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET + ;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform. It + ;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED, + ;; which is always machine word-sized (exactly as intptr_t; + ;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not + ;; enough -- potentially)." + ;; -- Anton Kovalenko , Mar 22, 2011 + (sb-alien:define-alien-type ws-socket sb-alien:signed) + + (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long) + (sb-alien:define-alien-type ws-event sb-alien::hinstance) + + (sb-alien:define-alien-type nil + (sb-alien:struct wsa-network-events + (network-events sb-alien:long) + (error-code (array sb-alien:int 10)))) ; 10 = fd-max-events + + (sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create) + ws-event) ; return type only + + (sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close) + (boolean #.sb-vm::n-machine-word-bits) + (event-object ws-event)) + + ;; not used + (sb-alien:define-alien-routine ("WSAResetEvent" wsa-reset-event) + (boolean #.sb-vm::n-machine-word-bits) + (event-object ws-event)) + + (sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events) + sb-alien:int + (socket ws-socket) + (event-object ws-event) + (network-events (* (sb-alien:struct wsa-network-events)))) + + (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) + sb-alien:int + (socket ws-socket) + (event-object ws-event) + (network-events sb-alien:long)) + + (sb-alien:define-alien-routine ("WSAWaitForMultipleEvents" wsa-wait-for-multiple-events) + ws-dword + (number-of-events ws-dword) + (events (* ws-event)) + (wait-all-p (boolean #.sb-vm::n-machine-word-bits)) + (timeout ws-dword) + (alertable-p (boolean #.sb-vm::n-machine-word-bits))) + + (sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket) + sb-alien:int + (socket ws-socket) + (cmd sb-alien:long) + (argp (* sb-alien:unsigned-long))) + + (defun maybe-wsa-error (rv &optional socket) + (unless (zerop rv) + (raise-usock-err (sockint::wsa-get-last-error) socket))) + + (defun os-socket-handle (usocket) + (sb-bsd-sockets:socket-file-descriptor (socket usocket))) + + (defun bytes-available-for-read (socket) + (sb-alien:with-alien ((int-ptr sb-alien:unsigned-long)) + (maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr)) + socket) + (prog1 int-ptr + (when (plusp int-ptr) + (setf (state socket) :read))))) + + (defun map-network-events (func network-events) + (let ((event-map (sb-alien:slot network-events 'network-events)) + (error-array (sb-alien:slot network-events 'error-code))) + (unless (zerop event-map) + (dotimes (i fd-max-events) + (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand? + (funcall func (sb-alien:deref error-array i))))))) + + (defun update-ready-and-state-slots (wait-list) + (loop with sockets = (wait-list-waiters wait-list) + for socket in sockets do + (if (%ready-p socket) + (progn + (setf (state socket) :READ)) + (sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events))) + (let ((rv (wsa-enum-network-events (os-socket-handle socket) + (os-wait-list-%wait wait-list) + (sb-alien:addr network-events)))) + (if (zerop rv) + (map-network-events + #'(lambda (err-code) + (if (zerop err-code) + (progn + (setf (state socket) :READ) + (when (stream-server-usocket-p socket) + (setf (%ready-p socket) t))) + (raise-usock-err err-code socket))) + network-events) + (maybe-wsa-error rv socket))))))) + + (defun os-wait-list-%wait (wait-list) + (sb-alien:deref (wait-list-%wait wait-list))) + + (defun (setf os-wait-list-%wait) (value wait-list) + (setf (sb-alien:deref (wait-list-%wait wait-list)) value)) + + ;; "Event handles are leaking in current SBCL backend implementation, + ;; because of SBCL-unfriendly usage of finalizers. + ;; + ;; "SBCL never calls a finalizer that closes over a finalized object: a + ;; reference from that closure prevents its collection forever. That's + ;; the case with USOCKET in %SETUP-WAIT-LIST. + ;; + ;; "I use the following redefinition of %SETUP-WAIT-LIST: + ;; + ;; "Of course it may be rewritten with more clarity, but you can see the + ;; core idea: I'm closing over those components of WAIT-LIST that I need + ;; for finalization, not the wait-list itself. With the original + ;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted + ;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST." + ;; + ;; -- Anton Kovalenko , Mar 22, 2011 + + (defun %setup-wait-list (wait-list) + (setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event)) + (setf (os-wait-list-%wait wait-list) (wsa-event-create)) + (sb-ext:finalize wait-list + (let ((event-handle (os-wait-list-%wait wait-list)) + (alien (wait-list-%wait wait-list))) + #'(lambda () + (wsa-event-close event-handle) + (unless (null alien) + (sb-alien:free-alien alien)))))) + +) ; progn + +#+(and (or ecl clasp) (not win32)) +(progn + (defun wait-for-input-internal (wl &key timeout) + (with-mapped-conditions () + (multiple-value-bind (secs usecs) + (split-timeout (or timeout 1)) + (multiple-value-bind (result-fds err) + (read-select wl (when timeout secs) usecs) + (declare (ignore result-fds)) + (unless (null err) + (error (map-errno-error err))))))) + + (defun %setup-wait-list (wl) + (setf (wait-list-%wait wl) + (fdset-alloc))) + + (defun %add-waiter (wl w) + (declare (ignore wl w))) + + (defun %remove-waiter (wl w) + (declare (ignore wl w))) +) ; progn + +#+(and (or ecl clasp) win32 (not ecl-bytecmp)) +(progn + (defun maybe-wsa-error (rv &optional syscall) + (unless (zerop rv) + (sb-bsd-sockets::socket-error syscall))) + + (defun %setup-wait-list (wl) + (setf (wait-list-%wait wl) + (ffi:c-inline () () :int + "WSAEVENT event; + event = WSACreateEvent(); + @(return) = event;"))) + + (defun %add-waiter (wait-list waiter) + (let ((events (etypecase waiter + (stream-server-usocket (logior fd-connect fd-accept fd-close)) + (stream-usocket (logior fd-read)) + (datagram-usocket (logior fd-read))))) + (maybe-wsa-error + (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list) events) + (:fixnum :fixnum :fixnum) :fixnum + "int result; + result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, (long)#2); + @(return) = result;") + '%add-waiter))) + + (defun %remove-waiter (wait-list waiter) + (maybe-wsa-error + (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list)) + (:fixnum :fixnum) :fixnum + "int result; + result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, 0L); + @(return) = result;") + '%remove-waiter)) + + ;; TODO: how to handle error (result) in this call? + (declaim (inline %bytes-available-for-read)) + (defun %bytes-available-for-read (socket) + (ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum + "u_long nbytes; + int result; + nbytes = 0L; + result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes); + @(return) = nbytes;")) + + (defun bytes-available-for-read (socket) + (let ((nbytes (%bytes-available-for-read socket))) + (when (plusp nbytes) + (setf (state socket) :read)) + nbytes)) + + (defun update-ready-and-state-slots (wait-list) + (loop with sockets = (wait-list-waiters wait-list) + for socket in sockets do + (if (%ready-p socket) + (setf (state socket) :READ) + (let ((events (etypecase socket + (stream-server-usocket (logior fd-connect fd-accept fd-close)) + (stream-usocket (logior fd-read)) + (datagram-usocket (logior fd-read))))) + ;; TODO: check the iErrorCode array + (multiple-value-bind (valid-p ready-p) + (ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum) + (values :bool :bool) + ;; TODO: replace 0 (2nd arg) with (wait-list-%wait wait-list) + "WSANETWORKEVENTS network_events; + int i, result; + result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events); + if (!result) { + @(return 0) = Ct; + @(return 1) = (#1 & network_events.lNetworkEvents)? Ct : Cnil; + } else { + @(return 0) = Cnil; + @(return 1) = Cnil; + }") + (if valid-p + (when ready-p + (setf (state socket) :READ) + (when (stream-server-usocket-p socket) + (setf (%ready-p socket) t))) + (sb-bsd-sockets::socket-error 'update-ready-and-state-slots))))))) + + (defun wait-for-input-internal (wait-list &key timeout) + (when (waiting-required (wait-list-waiters wait-list)) + (let ((rv (ffi:c-inline ((wait-list-%wait wait-list) + (if timeout + (truncate (* 1000 timeout)) + +wsa-infinite+)) + (:fixnum :fixnum) :fixnum + "DWORD result; + WSAEVENT events[1]; + events[0] = (WSAEVENT)#0; + result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL); + @(return) = result;"))) + (ecase rv + ((#.+wsa-wait-event-0+) + (update-ready-and-state-slots (wait-list-waiters wait-list))) + ((#.+wsa-wait-timeout+)) ; do nothing here + ((#.+wsa-wait-failed+) + (sb-bsd-sockets::socket-error 'wait-for-input-internal)))))) + +) ; progn diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/scl.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/scl.lisp new file mode 100644 index 0000000..d26b7c9 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/scl.lisp @@ -0,0 +1,266 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defparameter +scl-error-map+ + (append +unix-errno-condition-map+ + +unix-errno-error-map+)) + +(defun scl-map-socket-error (err &key condition socket) + (let ((usock-err (cdr (assoc err +scl-error-map+ :test #'member)))) + (cond (usock-err + (if (subtypep usock-err 'error) + (error usock-err :socket socket) + (signal usock-err :socket socket))) + (t + (error 'unknown-error + :socket socket + :real-error condition))))) + +(defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) + "Dispatch correct usocket condition." + (typecase condition + (ext::socket-error + (scl-map-socket-error (ext::socket-errno condition) + :socket socket + :condition condition)))) + +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) + timeout deadline (nodelay t nodelay-specified) + (local-host nil local-host-p) + (local-port nil local-port-p) + &aux + (patch-udp-p (fboundp 'ext::inet-socket-send-to))) + (when (and nodelay-specified + (not (eq nodelay :if-supported))) + (unsupported 'nodelay 'socket-connect)) + (when deadline (unsupported 'deadline 'socket-connect)) + (when timeout (unsupported 'timeout 'socket-connect)) + (when (and local-host-p (not patch-udp-p)) + (unsupported 'local-host 'socket-connect :minimum "1.3.9")) + (when (and local-port-p (not patch-udp-p)) + (unsupported 'local-port 'socket-connect :minimum "1.3.9")) + + (let ((socket)) + (ecase protocol + (:stream + (setf socket (let ((args (list (host-to-hbo host) port :kind protocol))) + (when (and patch-udp-p (or local-host-p local-port-p)) + (nconc args (list :local-host (when local-host + (host-to-hbo local-host)) + :local-port local-port))) + (with-mapped-conditions (socket) + (apply #'ext:connect-to-inet-socket args)))) + (let ((stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full))) + (make-stream-socket :socket socket :stream stream))) + (:datagram + (when (not patch-udp-p) + (error 'unsupported + :feature '(protocol :datagram) + :context 'socket-connect + :minumum "1.3.9")) + (setf socket + (if (and host port) + (let ((args (list (host-to-hbo host) port :kind protocol))) + (when (and patch-udp-p (or local-host-p local-port-p)) + (nconc args (list :local-host (when local-host + (host-to-hbo local-host)) + :local-port local-port))) + (with-mapped-conditions (socket) + (apply #'ext:connect-to-inet-socket args))) + (if (or local-host-p local-port-p) + (with-mapped-conditions () + (ext:create-inet-listener (or local-port 0) + protocol + :host (when local-host + (if (ip= local-host *wildcard-host*) + 0 + (host-to-hbo local-host))))) + (with-mapped-conditions () + (ext:create-inet-socket protocol))))) + (let ((usocket (make-datagram-socket socket :connected-p (and host port t)))) + (ext:finalize usocket #'(lambda () + (when (%open-p usocket) + (ext:close-socket socket)))) + usocket))))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) + (host (if (ip= host *wildcard-host*) + 0 + (host-to-hbo host))) + (server-sock + (with-mapped-conditions () + (ext:create-inet-listener port :stream + :host host + :reuse-address reuseaddress + :backlog backlog)))) + (make-stream-server-socket server-sock :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (with-mapped-conditions (usocket) + (let* ((sock (ext:accept-tcp-connection (socket usocket))) + (stream (sys:make-fd-stream sock :input t :output t + :element-type (or element-type + (element-type usocket)) + :buffering :full))) + (make-stream-socket :socket sock :stream stream)))) + +;; Sockets and their associated streams are modelled as +;; different objects. Be sure to close the socket stream +;; when closing stream-sockets; it makes sure buffers +;; are flushed and the socket is closed correctly afterwards. +(defmethod socket-close ((usocket usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (ext:close-socket (socket usocket)))) + +(defmethod socket-close ((usocket stream-usocket)) + "Close socket." + (with-mapped-conditions (usocket) + (close (socket-stream usocket)))) + +(defmethod socket-close :after ((socket datagram-usocket)) + (setf (%open-p socket) nil)) + +(defmethod socket-shutdown ((usocket usocket) direction) + (declare (ignore usocket direction)) + (unsupported "shutdown" 'socket-shutdown)) + +(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port) + (let ((s (socket usocket)) + (host (if host (host-to-hbo host))) + (real-buffer (if (zerop offset) + buffer + (subseq buffer offset (+ offset size))))) + (multiple-value-bind (result errno) + (ext:inet-socket-send-to s real-buffer size + :remote-host host :remote-port port) + (or result + (scl-map-socket-error errno :socket usocket))))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length &key) + (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer + (integer 0) ; size + (unsigned-byte 32) ; host + (unsigned-byte 16))) ; port + (let ((s (socket socket))) + (let ((real-buffer (or buffer + (make-array length :element-type '(unsigned-byte 8)))) + (real-length (or length + (length buffer)))) + (multiple-value-bind (result errno remote-host remote-port) + (ext:inet-socket-receive-from s real-buffer real-length) + (if result + (values real-buffer result remote-host remote-port) + (scl-map-socket-error errno :socket socket)))))) + +(defmethod get-local-name ((usocket usocket)) + (multiple-value-bind (address port) + (with-mapped-conditions (usocket) + (ext:get-socket-host-and-port (socket usocket))) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (multiple-value-bind (address port) + (with-mapped-conditions (usocket) + (ext:get-peer-host-and-port (socket usocket))) + (values (hbo-to-vector-quad address) port))) + +(defmethod get-local-address ((usocket usocket)) + (nth-value 0 (get-local-name usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (nth-value 0 (get-peer-name usocket))) + +(defmethod get-local-port ((usocket usocket)) + (nth-value 1 (get-local-name usocket))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (nth-value 1 (get-peer-name usocket))) + + +(defun get-host-by-address (address) + (multiple-value-bind (host errno) + (ext:lookup-host-entry (host-byte-order address)) + (cond (host + (ext:host-entry-name host)) + (t + (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) + (cond (condition + (error condition :host-or-ip address)) + (t + (error 'ns-unknown-error :host-or-ip address + :real-error errno)))))))) + +(defun get-hosts-by-name (name) + (multiple-value-bind (host errno) + (ext:lookup-host-entry name) + (cond (host + (mapcar #'hbo-to-vector-quad + (ext:host-entry-addr-list host))) + (t + (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) + (cond (condition + (error condition :host-or-ip name)) + (t + (error 'ns-unknown-error :host-or-ip name + :real-error errno)))))))) + +(defun get-host-name () + (unix:unix-gethostname)) + + +;; +;; +;; WAIT-LIST part +;; + + +(defun %add-waiter (wl waiter) + (declare (ignore wl waiter))) + +(defun %remove-waiter (wl waiter) + (declare (ignore wl waiter))) + +(defun %setup-wait-list (wl) + (declare (ignore wl))) + +(defun wait-for-input-internal (wait-list &key timeout) + (let* ((sockets (wait-list-waiters wait-list)) + (pollfd-size (alien:alien-size (alien:struct unix::pollfd) :bytes)) + (nfds (length sockets)) + (bytes (* nfds pollfd-size))) + (alien:with-bytes (fds-sap bytes) + (do ((sockets sockets (rest sockets)) + (base 0 (+ base 8))) + ((endp sockets)) + (let ((fd (socket (first sockets)))) + (setf (sys:sap-ref-32 fds-sap base) fd) + (setf (sys:sap-ref-16 fds-sap (+ base 4)) unix::pollin))) + (multiple-value-bind (result errno) + (let ((thread:*thread-whostate* "Poll wait") + (timeout (if timeout + (truncate (* timeout 1000)) + -1))) + (declare (inline unix:unix-poll)) + (unix:unix-poll (alien:sap-alien fds-sap + (* (alien:struct unix::pollfd))) + nfds timeout)) + (cond ((not result) + (error "~@" + (unix:get-unix-error-msg errno))) + (t + (do ((sockets sockets (rest sockets)) + (base 0 (+ base 8))) + ((endp sockets)) + (let ((flags (sys:sap-ref-16 fds-sap (+ base 6)))) + (unless (zerop (logand flags unix::pollin)) + (setf (state (first sockets)) :READ)))))))))) + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/condition.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/condition.lisp new file mode 100644 index 0000000..1e1dc44 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/condition.lisp @@ -0,0 +1,237 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*- +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;; Condition signalled by operations with unsupported arguments +;; For trivial-sockets compatibility. + +(define-condition insufficient-implementation (error) + ((feature :initarg :feature :reader feature) + (context :initarg :context :reader context + :documentation "String designator of the public API function which +the feature belongs to.")) + (:documentation "The ancestor of all errors usocket may generate +because of insufficient support from the underlying implementation +with respect to the arguments given to `function'. + +One call may signal several errors, if the caller allows processing +to continue. +")) + +(define-condition unsupported (insufficient-implementation) + ((minimum :initarg :minimum :reader minimum + :documentation "Indicates the minimal version of the +implementation required to support the requested feature.")) + (:report (lambda (c stream) + (format stream "~A in ~A is unsupported." + (feature c) (context c)) + (when (minimum c) + (format stream " Minimum version (~A) is required." + (minimum c))))) + (:documentation "Signalled when the underlying implementation +doesn't allow supporting the requested feature. + +When you see this error, go bug your vendor/implementation developer!")) + +(define-condition unimplemented (insufficient-implementation) + () + (:report (lambda (c stream) + (format stream "~A in ~A is unimplemented." + (feature c) (context c)))) + (:documentation "Signalled if a certain feature might be implemented, +based on the features of the underlying implementation, but hasn't +been implemented yet.")) + +;; Conditions raised by sockets operations + +(define-condition socket-condition (condition) + ((socket :initarg :socket + :accessor usocket-socket)) + ;;###FIXME: no slots (yet); should at least be the affected usocket... + (:documentation "Parent condition for all socket related conditions.")) + +(define-condition socket-error (socket-condition error) + () ;; no slots (yet) + (:documentation "Parent error for all socket related errors")) + +(define-condition ns-condition (condition) + ((host-or-ip :initarg :host-or-ip + :accessor host-or-ip)) + (:documentation "Parent condition for all name resolution conditions.")) + +(define-condition ns-error (ns-condition error) + () + (:documentation "Parent error for all name resolution errors.")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun define-usocket-condition-class (class &rest parents) + `(progn + (define-condition ,class ,parents ()) + (eval-when (:load-toplevel :execute) + (export ',class))))) + +(defmacro define-usocket-condition-classes (class-list parents) + `(progn ,@(mapcar #'(lambda (x) + (apply #'define-usocket-condition-class + x parents)) + class-list))) + +;; Mass define and export our conditions +(define-usocket-condition-classes + (interrupted-condition) + (socket-condition)) + +(define-condition unknown-condition (socket-condition) + ((real-condition :initarg :real-condition + :accessor usocket-real-condition)) + (:documentation "Condition raised when there's no other - more applicable - +condition available.")) + + +;; Mass define and export our errors +(define-usocket-condition-classes + (address-in-use-error + address-not-available-error + bad-file-descriptor-error + connection-refused-error + connection-aborted-error + connection-reset-error + invalid-argument-error + no-buffers-error + operation-not-supported-error + operation-not-permitted-error + protocol-not-supported-error + socket-type-not-supported-error + network-unreachable-error + network-down-error + network-reset-error + host-down-error + host-unreachable-error + shutdown-error + timeout-error + deadline-timeout-error + invalid-socket-error + invalid-socket-stream-error) + (socket-error)) + +(define-condition unknown-error (socket-error) + ((real-error :initarg :real-error + :accessor usocket-real-error + :initform nil) + (errno :initarg :errno + :reader usocket-errno + :initform 0)) + (:report (lambda (c stream) + (typecase c + (simple-condition + (format stream + (simple-condition-format-control (usocket-real-error c)) + (simple-condition-format-arguments (usocket-real-error c)))) + (otherwise + (format stream "The condition ~A occurred with errno: ~D." + (usocket-real-error c) + (usocket-errno c)))))) + (:documentation "Error raised when there's no other - more applicable - +error available.")) + +(define-usocket-condition-classes + (ns-try-again-condition) + (ns-condition)) + +(define-condition ns-unknown-condition (ns-condition) + ((real-condition :initarg :real-condition + :accessor ns-real-condition + :initform nil)) + (:documentation "Condition raised when there's no other - more applicable - +condition available.")) + +(define-usocket-condition-classes + ;; the no-data error code in the Unix 98 api + ;; isn't really an error: there's just no data to return. + ;; with lisp, we just return NIL (indicating no data) instead of + ;; raising an exception... + (ns-host-not-found-error + ns-no-recovery-error) + (ns-error)) + +(define-condition ns-unknown-error (ns-error) + ((real-error :initarg :real-error + :accessor ns-real-error + :initform nil)) + (:report (lambda (c stream) + (typecase c + (simple-condition + (format stream + (simple-condition-format-control (usocket-real-error c)) + (simple-condition-format-arguments (usocket-real-error c)))) + (otherwise + (format stream "The condition ~A occurred." (usocket-real-error c)))))) + (:documentation "Error raised when there's no other - more applicable - +error available.")) + +(defmacro with-mapped-conditions ((&optional socket host-or-ip) &body body) + `(handler-bind ((condition + #'(lambda (c) (handle-condition c ,socket ,host-or-ip)))) + ,@body)) + +(defparameter +unix-errno-condition-map+ + `(((11) . ns-try-again-condition) ;; EAGAIN + ((35) . ns-try-again-condition) ;; EDEADLCK + ((4) . interrupted-condition))) ;; EINTR + +(defparameter +unix-errno-error-map+ + ;;### the first column is for non-(linux or srv4) systems + ;; the second for linux + ;; the third for srv4 + ;;###FIXME: How do I determine on which Unix we're running + ;; (at least in clisp and sbcl; I know about cmucl...) + ;; The table below works under the assumption we'll *only* see + ;; socket associated errors... + `(((48 98) . address-in-use-error) + ((49 99) . address-not-available-error) + ((9) . bad-file-descriptor-error) + ((61 111) . connection-refused-error) + ((54 104) . connection-reset-error) + ((53 103) . connection-aborted-error) + ((22) . invalid-argument-error) + ((55 105) . no-buffers-error) + ((12) . out-of-memory-error) + ((45 95) . operation-not-supported-error) + ((1) . operation-not-permitted-error) + ((43 92) . protocol-not-supported-error) + ((44 93) . socket-type-not-supported-error) + ((51 101) . network-unreachable-error) + ((50 100) . network-down-error) + ((52 102) . network-reset-error) + ((58 108) . already-shutdown-error) + ((60 110) . timeout-error) + ((64 112) . host-down-error) + ((65 113) . host-unreachable-error))) + +(defun map-errno-condition (errno) + (cdr (assoc errno +unix-errno-error-map+ :test #'member))) + +(defun map-errno-error (errno) + (cdr (assoc errno +unix-errno-error-map+ :test #'member))) + +(defparameter +unix-ns-error-map+ + `((1 . ns-host-not-found-error) + (2 . ns-try-again-condition) + (3 . ns-no-recovery-error))) + +(defmacro unsupported (feature context &key minimum) + `(cerror "Ignore it and continue" 'unsupported + :feature ,feature + :context ,context + :minimum ,minimum)) + +(defmacro unimplemented (feature context) + `(signal 'unimplemented :feature ,feature :context ,context)) + +;;; People may want to ignore all unsupported warnings, here it is. +(defmacro ignore-unsupported-warnings (&body body) + `(handler-bind ((unsupported + #'(lambda (c) + (declare (ignore c)) (continue)))) + (progn ,@body))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/intro.dita b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/intro.dita new file mode 100644 index 0000000..174639a --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/intro.dita @@ -0,0 +1,10 @@ + + + + + +Introduction + +Chun Tian +

 diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/reference.dita b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/reference.dita new file mode 100644 index 0000000..d4e3f9f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/reference.dita @@ -0,0 +1,11 @@ + + + + + + +API References +Chun Tian +

 diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/usocket.ditamap b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/usocket.ditamap new file mode 100644 index 0000000..2dfe2b9 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/usocket.ditamap @@ -0,0 +1,11 @@ + + + + + + +USOCKET Manual + + +API References diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/abcl-socket.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/abcl-socket.txt new file mode 100644 index 0000000..531ace9 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/abcl-socket.txt @@ -0,0 +1,18 @@ + +ABCL provides a callback interface to java objects, next to these calls: + + - ext:make-socket + - ext:socket-close + - ext:make-server-socket + - ext:socket-accept + - ext:get-socket-stream (returning an io-stream) + +abcl-swank (see SLIME) shows how to call directly into java. + + +See for the sockets implementation: + + - src/org/armedbear/lisp + * socket.lisp + * socket_stream.java + * SocketStream.java diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/active-sockets-apis.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/active-sockets-apis.txt new file mode 100644 index 0000000..b74ccfe --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/active-sockets-apis.txt @@ -0,0 +1,75 @@ + -*- text -*- + +A document to summarizing which API's of the different implementations +are associated with 'Step 1'. + +Interface to be implemented in step 1: + + - socket-connect + - socket-close + - get-host-by-address + - get-hosts-by-name + +(and something to do with errors; maybe move this to step 1a?) + +SBCL +==== + + sockets: + - socket-bind + - make-instance 'inet-socket + - socket-make-stream + - socket-connect (ip vector-quad) port + - socket-close + + DNS name resolution: + - get-host-by-name + - get-host-by-address + - ::host-ent-addresses + - host-ent-name + + +CMUCL +===== + + sockets: + - ext:connect-to-inet-socket (ip integer) port + - sys:make-fd-stream + - ext:close-socket + + DNS name resolution: + - ext:host-entry-name + - ext::lookup-host-entry + - ext:host-entry-addr-list + - ext:lookup-host-entry + + +ABCL +==== + + sockets + - ext:socket-connect (hostname string) port + - ext:get-socket-stream + - ext:socket-close + + +clisp +===== + + sockets + - socket-connect port (hostname string) + - close (socket) + + +Allegro +======= + + sockets + - make-socket + - socket-connect + - close + + DNS resolution + - lookup-hostname + - ipaddr-to-hostname + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/address-apis.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/address-apis.txt new file mode 100644 index 0000000..2661ac2 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/address-apis.txt @@ -0,0 +1,73 @@ + + -*- text -*- + +Step 2 of the master plan: Implementing (get-local-address sock) and +(get-peer-address sock). + + +Step 2 is about implementing: + + (get-local-address sock) -> ip + (get-peer-address sock) -> ip + (get-local-port sock) -> port + (get-peer-port sock) -> port + (get-local-name sock) -> ip, port + (get-peer-name sock) -> ip, port + + +ABCL +==== + + FFI / J-calls to "getLocalAddress"+"getAddress", "getLocalPort" (local) + FFI / J-calls to "getInetAddress"+"getAddress", "getPort" (peer) + + (see SLIME / swank-abcl.lisp for an example on how to do that) + + +Allegro +======= + + (values (socket:remote-host sock) + (socket:remote-port)) -> 32bit ip, port + + (values (socket:local-host sock) + (socket:local-port sock)) -> 32bit ip, port + +CLISP +===== + + (socket:socket-stream-local sock nil) -> address (as dotted quad), port + (socket:socket-stream-peer sock nil) -> address (as dotted quad), port + + +CMUCL +===== + + (ext:get-peer-host-and-port sock-fd) -> 32-bit-addr, port (peer) + (ext:get-socket-host-and-port sock-fd) -> 32-bit-addr, port (local) + + +LispWorks +========= + + (comm:socket-stream-address sock-stream) -> 32-bit-addr, port + or: (comm:get-socket-address sock) -> 32-bit-addr, port + + (comm:socket-stream-peer-address sock-stream) -> 32-bit-addr, port + or: (comm:get-socket-peer-address sock) -> 32-bit-addr, port + + +OpenMCL +======= + + (values (ccl:local-host sock) (ccl:local-port sock)) -> 32-bit ip, port + (values (ccl:remote-host sock) (ccl:remote-port sock)) -> 32-bit ip, port + + +SBCL +==== + + (sb-bsd-sockets:socket-name sock) -> vector-quad, port + (sb-bsd-sockets:socket-peer-name sock) -> vector-quad, port + + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/allegro-socket.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/allegro-socket.txt new file mode 100644 index 0000000..8f90ca7 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/allegro-socket.txt @@ -0,0 +1,46 @@ + + +(require :sock) + +accept-connection (sock passive-socket) &key wait Generic function. +dotted-to-ipaddr dotted &key errorp Function. +ipaddr-to-dotted ipaddr &key values Function. +ipaddr-to-hostname ipaddr Function. +lookup-hostname hostname +lookup-port portname protocol Function. +make-socket &key type format address-family connect &allow-other-keys Function. +with-pending-connect &body body Macro. +receive-from (sock datagram-socket) size &key buffer extract Generic function. +send-to sock &key +shutdown sock &key direction +socket-control stream &key output-chunking output-chunking-eof input-chunking +socket-os-fd sock Generic function. + +remote-host socket Generic function. +local-host socket Generic function. +local-port socket + +remote-filename socket +local-filename socket +remote-port socket +socket-address-family socket +socket-connect socket +socket-format socket +socket-type socket + +errors + +:address-in-use Local socket address already in use +:address-not-available Local socket address not available +:network-down Network is down +:network-reset Network has been reset +:connection-aborted Connection aborted +:connection-reset Connection reset by peer +:no-buffer-space No buffer space +:shutdown Connection shut down +:connection-timed-out Connection timed out +:connection-refused Connection refused +:host-down Host is down +:host-unreachable Host is unreachable +:unknown Unknown error + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/backends.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/backends.txt new file mode 100644 index 0000000..c2c770f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/backends.txt @@ -0,0 +1,60 @@ + -*- text -*- + +$Id$ + +A document to describe which APIs a backend should implement. + + +Each backend should implement: + +Functions: + + - handle-condition + - socket-connect + - socket-listen + - get-hosts-by-name [ optional ] + - get-host-by-address [ optional ] + + - wait-for-input-internal (new in 0.4.x) + +Methods: + + - socket-close + - socket-accept + - get-local-name + - get-peer-name + + and - for ip sockets - these methods: + + - get-local-address + - get-local-port + - get-peer-address + - get-peer-port + + +An error-handling function, resolving implementation specific errors +to this list of errors: + + - address-in-use-error + - address-not-available-error + - bad-file-descriptor-error + - connection-refused-error + - invalid-argument-error + - no-buffers-error + - operation-not-supported-error + - operation-not-permitted-error + - protocol-not-supported-error + - socket-type-not-supported-error + - network-unreachable-error + - network-down-error + - network-reset-error + - host-down-error + - host-unreachable-error + - shutdown-error + - timeout-error + - unkown-error + +and these conditions: + + - interrupted-condition + - unkown-condition diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/clisp-sockets.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/clisp-sockets.txt new file mode 100644 index 0000000..e680fe8 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/clisp-sockets.txt @@ -0,0 +1,38 @@ +http://clisp.cons.org/impnotes.html#socket + +(SOCKET:SOCKET-SERVER &OPTIONAL [port-or-socket]) +(SOCKET:SOCKET-SERVER-HOST socket-server) +(SOCKET:SOCKET-SERVER-PORT socket-server) +(SOCKET:SOCKET-WAIT socket-server &OPTIONAL [seconds [microseconds]]) +(SOCKET:SOCKET-ACCEPT socket-server &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT) +(SOCKET:SOCKET-CONNECT port &OPTIONAL [host] &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT) +(SOCKET:SOCKET-STATUS socket-stream-or-list &OPTIONAL [seconds [microseconds]]) +(SOCKET:SOCKET-STREAM-HOST socket-stream) +(SOCKET:SOCKET-STREAM-PORT socket-stream) +(SOCKET:SOCKET-SERVICE-PORT &OPTIONAL service-name (protocol "tcp")) +(SOCKET:SOCKET-STREAM-PEER socket-stream [do-not-resolve-p]) +(SOCKET:SOCKET-STREAM-LOCAL socket-stream [do-not-resolve-p]) +(SOCKET:SOCKET-STREAM-SHUTDOWN socket-stream direction) +(SOCKET:SOCKET-OPTIONS socket-server &REST {option}*) + + +(posix:resolve-host-ipaddr &optional host) + +with the host-ent structure: + + name - host name + aliases - LIST of aliases + addr-list - LIST of IPs as dotted quads (IPv4) or coloned octets (IPv6) + addrtype - INTEGER address type IPv4 or IPv6 + + +Errors are of type + +SYSTEM::SIMPLE-OS-ERROR + with a 1 element (integer) SYSTEM::$FORMAT-ARGUMENTS list + +This integer stores the OS error reported; meaning WSA* codes on Win32 +and E* codes on *nix, only: unix.lisp in CMUCL shows +BSD, Linux and SRV4 have different number assignments for the same +E* constant names :-( + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/cmucl-sockets.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/cmucl-sockets.txt new file mode 100644 index 0000000..7b81ca3 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/cmucl-sockets.txt @@ -0,0 +1,69 @@ +http://cvs2.cons.org/ftp-area/cmucl/doc/cmu-user/internet.html + +$Id$ + +extensions:lookup-host-entry host + +[structure] +host-entry + + name aliases addr-type addr-list + +[Function] +extensions:create-inet-listener port &optional kind &key :reuse-address :backlog :interface + => socket fd + +[Function] +extensions:accept-tcp-connection unconnected + => socket fd, address + +[Function] +extensions:connect-to-inet-socket host port &optional kind + => socket fd + +[Function] +extensions:close-socket socket + + + +[Private function] +extensions::get-peer-host-and-port socket-fd + +[Private function] +extentsions::get-socket-host-and-port socket-fd + + + +There's currently only 1 condition to be raised: + + SOCKET-ERROR (derived from SIMPLE-ERROR) + which has a SOCKET-ERRNO slot containing the unix error number. + + + + +[Function] +extensions:add-oob-handler fd char handler + +[Function] +extensions:remove-oob-handler fd char + +[Function] +extensions:remove-all-oob-handlers fd + +[Function] +extensions:send-character-out-of-band fd char + +[Function] +extensions:create-inet-socket &optional type + => socket fd + +[Function] +extensions:get-socket-option socket level optname + +[Function] +extensions:set-socket-option socket level optname optval + +[Function] +extensions:ip-string addr + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/design.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/design.txt new file mode 100644 index 0000000..2f9c487 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/design.txt @@ -0,0 +1,136 @@ + + -*- text -*- + +$Id$ + + + usocket: Universal sockets library + ================================== + +Contents +======== + + * Motivation + * Design goal + * Functional requirements + * Class structure + + + +Motivation +========== + +There are 2 other portability sockets packages [that I know of] +out there: + + 1) trivial-sockets + 2) acl-compat (which is a *lot* broader, but contains sockets too) + +The first misses some functionality which is fundamental when +the requirements stop being 'trivial', such as finding out the +addresses of either side connected to the tcp/ip stream. + +The second, being a complete compatibility library for Allegro, +contains much more than only sockets. Next to that, as the docs +say, is it mainly directed at providing the functionality required +to port portable-allegroserve - meaning it may be (very) incomplete +on some platforms. + +So, that's why I decided to inherit Erik Enge's project to build +a library with the intention to provide portability code in only +1 area of programming, targeted at 'not so trivial' programming. + +Also, I need this library to extend cl-irc with full DCC functionality. + + + +Design goal +=========== + +To provide a portable TCP/IP socket interface for as many +implementations as possible, while keeping the portability layer +as thin as possible. + + + +Functional requirements +======================= + +The interface provided should allow: + - 'client'/active sockets + - 'server'/listening sockets + - provide the usual stream methods to operate on the connection stream + (not necessarily the socket itself; maybe a socket slot too) + +For now, as long as there are no possibilities to have UDP sockets +to write a DNS client library: (which in the end may work better, +because in this respect all implementations are different...) + - retrieve IP addresses/ports for both sides of the connection + +Several relevant support functionalities will have to be provided too: + - long <-> quad-vector operators + - quad-vector <-> string operators + - hostname <-> quad-vector operators (hostname resolution) + + +Minimally, I'd like to support: + - SBCL + - CMUCL + - ABCL (ArmedBear) + - clisp + - Allegro + - LispWorks + - OpenMCL + + +Comments on the design above +============================ + +I don't think it's a good idea to implement name lookup in the +very first of steps: we'll see if this is required to get the +package accepted; not all implementations support it. + +Name resolution errors ... +Since there is no name resolution library (yet), nor standardized +hooks into the standard C library to do it the same way on +all platforms, name resolution errors can manifest themselves +in a lot of different ways. How to marshall these to the +library users? + +Several solutions come to mind: + +1) Map them to 'unknown-error +2) Give them their own errors and map to those + ... which implies that they are actually supported atm. +3) ... + +Given that the library doesn't now, but may in the future, +include name resolution officially, I tend to think (1) is the +right answer: it leaves it all undecided. + +These errors can be raised by the nameresolution service +(netdb.h) as values for 'int h_errno': + +- HOST_NOT_FOUND (1) +- TRY_AGAIN (2) /* Server fail or non-authoritive Host not found */ +- NO_RECOVERY (3) /* Failed permanently */ +- NO_DATA (4) /* Valid address, no data for requested record */ + +int *__h_errno_location(void) points to thread local h_errno on +threaded glibc2 systems. + + +Class structure +=============== + + usocket + | + +- datagram-usocket + +- stream-usocket + \- stream-server-usocket + +The usocket class will have methods to query local properties, such +as: + + - get-local-name: to query to which interface the socket is bound + - diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/errors.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/errors.txt new file mode 100644 index 0000000..148525c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/errors.txt @@ -0,0 +1,20 @@ +EADDRINUSE 48 address-in-use-error +EADDRNOTAVAIL 49 address-not-available-error +EAGAIN interrupted-error ;; not 1 error code: bsd == 11; non-bsd == 35 +EBADF 9 bad-file-descriptor-error +ECONNREFUSED 61 connection-refused-error +EINTR 4 interrupted-error +EINVAL 22 invalid-argument-error +ENOBUFS 55 no-buffers-error +ENOMEM 12 out-of-memory-error +EOPNOTSUPP 45 operation-not-supported-error +EPERM 1 operation-not-permitted-error +EPROTONOSUPPORT 43 protocol-not-supported-error +ESOCKTNOSUPPORT 44 socket-type-not-supported-error +ENETUNREACH 51 network-unreachable-error +ENETDOWN 50 network-down-error +ENETRESET 52 network-reset-error +ESHUTDOWN 58 already-shutdown-error +ETIMEDOUT 60 connection-timeout-error +EHOSTDOWN 64 host-down-error +EHOSTUNREACH 65 host-unreachable-error diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/lw-sockets.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/lw-sockets.txt new file mode 100644 index 0000000..666ede8 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/lw-sockets.txt @@ -0,0 +1,41 @@ + +$Id$ + +http://www.lispworks.com/reference/lwu41/lwref/LWRM_37.HTM + +Package: COMM + +ip-address-string +socket-stream-address +socket-stream-peer-address +start-up-server +start-up-server-and-mp +string-ip-address +with-noticed-socket-stream + +Needed components for usocket: + +comm::get-fd-from-socket socket-fd + => socket-fd + +comm::accept-connection-to-socket socket-fd + => socket-fd + +comm::close-socket +comm::create-tcp-socket-for-service + => socket-fd + +open-tcp-stream peer-host peer-port &key direction element-type + => socket-stream + +get-host-entry (see http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-30.htm#pgfId-897837) +get-socket-address + +get-socket-peer-address + => address, port + +socket-stream socket-fd + => stream + +socket socket-stream (guessed from http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-43.htm) + => socket-fd diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/openmcl-sockets.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/openmcl-sockets.txt new file mode 100644 index 0000000..1a7ee4d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/openmcl-sockets.txt @@ -0,0 +1,27 @@ +http://openmcl.clozure.com/Doc/sockets.html + + make-socket [Function] + accept-connection [Function] + dotted-to-ipaddr [Function] + ipaddr-to-dotted [Function] + ipaddr-to-hostname [Function] + lookup-hostname [Function] + lookup-port [Function] + receive-from [Function] + send-to [Function] + shutdown [Function] + socket-os-fd [Function] + remote-port [Function] + local-host [Function] + local-port [Function] + + socket-address-family [Function] + + socket-connect [Function] + socket-format [Function] + socket-type [Function] + socket-error [Class] + socket-error-code [Function] + socket-error-identifier [Function] + socket-error-situation [Function] + close [method] diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/sb-bsd-sockets.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/sb-bsd-sockets.txt new file mode 100644 index 0000000..e80b583 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/sb-bsd-sockets.txt @@ -0,0 +1,114 @@ +http://www.xach.com/sbcl/sb-bsd-sockets.html + +$Id$ + +package: sb-bsd-sockets + +class: socket + +slots: + + * file-descriptor : + * family : + * protocol : + * type : + * stream : + +operators: + + (socket-bind (s socket) &rest address) Generic Function + (socket-accept (socket socket)) Method + (socket-connect (s socket) &rest address) Generic Function + (socket-peername (socket socket)) Method + (socket-name (socket socket)) Method + (socket-receive (socket socket) buffer length &key oob peek waitall (element-type 'character)) Method + (socket-listen (socket socket) backlog) Method + (socket-close (socket socket)) Method + (socket-make-stream (socket socket) &rest args) Method + + (sockopt-reuse-address (socket socket) argument) Accessor + (sockopt-keep-alive (socket socket) argument) Accessor + (sockopt-oob-inline (socket socket) argument) Accessor + (sockopt-bsd-compatible (socket socket) argument) Accessor + (sockopt-pass-credentials (socket socket) argument) Accessor + (sockopt-debug (socket socket) argument) Accessor + (sockopt-dont-route (socket socket) argument) Accessor + (sockopt-broadcast (socket socket) argument) Accessor + (sockopt-tcp-nodelay (socket socket) argument) Accessor + +inet-domain sockets + +class: inet-socket + +slots: + + * family : + +operators: + + (make-inet-address dotted-quads) Function + (get-protocol-by-name name) Function + (make-inet-socket type protocol) Function + +file-domain sockets + +class: unix-socket + +slots: + + * family : + +class: host-ent + +Slots: + + * name : + * aliases : + * address-type : + * addresses : + + (host-ent-address (host-ent host-ent)) Method + (get-host-by-name host-name) Function + (get-host-by-address address) Function + (name-service-error where) Function + (non-blocking-mode (socket socket)) Method + +(define-socket-condition sockint::EADDRINUSE address-in-use-error) +(define-socket-condition sockint::EAGAIN interrupted-error) +(define-socket-condition sockint::EBADF bad-file-descriptor-error) +(define-socket-condition sockint::ECONNREFUSED connection-refused-error) +(define-socket-condition sockint::EINTR interrupted-error) +(define-socket-condition sockint::EINVAL invalid-argument-error) +(define-socket-condition sockint::ENOBUFS no-buffers-error) +(define-socket-condition sockint::ENOMEM out-of-memory-error) +(define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error) +(define-socket-condition sockint::EPERM operation-not-permitted-error) +(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error) +(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error) +(define-socket-condition sockint::ENETUNREACH network-unreachable-error) + +Exported errors: +* (apropos "ERROR" :sb-bsd-sockets) + +SB-BSD-SOCKETS:INTERRUPTED-ERROR +SB-BSD-SOCKETS:TRY-AGAIN-ERROR +* SB-BSD-SOCKETS:NO-RECOVERY-ERROR (EFAIL?) +SB-BSD-SOCKETS:CONNECTION-REFUSED-ERROR +SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR +* SB-BSD-SOCKETS:HOST-NOT-FOUND-ERROR +SB-BSD-SOCKETS:OPERATION-NOT-PERMITTED-ERROR +SB-BSD-SOCKETS:OPERATION-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:PROTOCOL-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:OPERATION-TIMEOUT-ERROR +SB-BSD-SOCKETS:SOCKET-TYPE-NOT-SUPPORTED-ERROR +SB-BSD-SOCKETS:NO-BUFFERS-ERROR +SB-BSD-SOCKETS:NETWORK-UNREACHABLE-ERROR +SB-BSD-SOCKETS:BAD-FILE-DESCRIPTOR-ERROR +SB-BSD-SOCKETS:ADDRESS-IN-USE-ERROR +SB-BSD-SOCKETS:OUT-OF-MEMORY-ERROR + +And 1 non-exported error: + +SB-BSD-SOCKETS::NO-ADDRESS-ERROR + +*-ed errors aren't yet addressed in the errorlist supported by usocket diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/usock-sockets.txt b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/usock-sockets.txt new file mode 100644 index 0000000..562dc58 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/usock-sockets.txt @@ -0,0 +1,28 @@ +Package: + + clisp : socket + cmucl : extensions + sbcl : sb-bsd-sockets + lw : comm + openmcl: openmcl-socket + allegro: sock + +Connecting (TCP/inet only) + + clisp : socket-connect port &optional [host] &key :element-type :external-format :buffered :timeout = > socket-stream + cmucl : connect-to-inet-socket host port &optional kind => file descriptor + sbcl : sb-socket-connect socket &rest address => socket + lw : open-tcp-stream hostname service &key direction element-type buffered => stream-object + openmcl: socket-connect socket => :active, :passive or nil + allegro: make-socket (&rest args &key type format connect address-family eol) => socket + +Closing + + clisp : close socket + cmucl : close-socket socket + sbcl : socket-close socket + lw : close socket + openmcl: close socket + allegro: close socket + +Errors \ No newline at end of file diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/option.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/option.lisp new file mode 100644 index 0000000..4bc3e1b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/option.lisp @@ -0,0 +1,353 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*- +;;;; SOCKET-OPTION, a high-level socket option get/set framework + +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +;; put here because option.lisp is for native backend only +(defparameter *backend* :native) + +;;; Interface definition + +(defgeneric socket-option (socket option &key) + (:documentation + "Get a socket's internal options")) + +(defgeneric (setf socket-option) (new-value socket option &key) + (:documentation + "Set a socket's internal options")) + +;;; Handling of wrong type of arguments + +(defmethod socket-option ((socket usocket) (option t) &key) + (error 'type-error :datum option :expected-type 'keyword)) + +(defmethod (setf socket-option) (new-value (socket usocket) (option t) &key) + (declare (ignore new-value)) + (socket-option socket option)) + +(defmethod socket-option ((socket usocket) (option symbol) &key) + (if (keywordp option) + (error 'unimplemented :feature option :context 'socket-option) + (error 'type-error :datum option :expected-type 'keyword))) + +(defmethod (setf socket-option) (new-value (socket usocket) (option symbol) &key) + (declare (ignore new-value)) + (socket-option socket option)) + +;;; Socket option: RECEIVE-TIMEOUT (SO_RCVTIMEO) + +(defmethod socket-option ((usocket stream-usocket) + (option (eql :receive-timeout)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () ; TODO + #+allegro + () ; TODO + #+clisp + (socket:socket-options socket :so-rcvtimeo) + #+clozure + (ccl:stream-input-timeout socket) + #+cmu + (lisp::fd-stream-timeout (socket-stream usocket)) + #+(or ecl clasp) + (sb-bsd-sockets:sockopt-receive-timeout socket) + #+lispworks + (get-socket-receive-timeout socket) + #+mcl + () ; TODO + #+mocl + () ; unknown + #+sbcl + (sb-impl::fd-stream-timeout (socket-stream usocket)) + #+scl + ())) ; TODO + +(defmethod (setf socket-option) (new-value (usocket stream-usocket) + (option (eql :receive-timeout)) &key) + (declare (type number new-value) (ignorable new-value option)) + (let ((socket (socket usocket)) + (timeout new-value)) + (declare (ignorable socket timeout)) + #+abcl + () ; TODO + #+allegro + () ; TODO + #+clisp + (socket:socket-options socket :so-rcvtimeo timeout) + #+clozure + (setf (ccl:stream-input-timeout socket) timeout) + #+cmu + (setf (lisp::fd-stream-timeout (socket-stream usocket)) + (coerce timeout 'integer)) + #+(or ecl clasp) + (setf (sb-bsd-sockets:sockopt-receive-timeout socket) timeout) + #+lispworks + (set-socket-receive-timeout socket timeout) + #+mcl + () ; TODO + #+mocl + () ; unknown + #+sbcl + (setf (sb-impl::fd-stream-timeout (socket-stream usocket)) + (coerce timeout 'single-float)) + #+scl + () ; TODO + new-value)) + +;;; Socket option: SEND-TIMEOUT (SO_SNDTIMEO) + +(defmethod socket-option ((usocket stream-usocket) + (option (eql :send-timeout)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () ; TODO + #+allegro + () ; TODO + #+clisp + (socket:socket-options socket :so-sndtimeo) + #+clozure + (ccl:stream-output-timeout socket) + #+cmu + (lisp::fd-stream-timeout (socket-stream usocket)) + #+(or ecl clasp) + (sb-bsd-sockets:sockopt-send-timeout socket) + #+lispworks + (get-socket-send-timeout socket) + #+mcl + () ; TODO + #+mocl + () ; unknown + #+sbcl + (sb-impl::fd-stream-timeout (socket-stream usocket)) + #+scl + ())) ; TODO + +(defmethod (setf socket-option) (new-value (usocket stream-usocket) + (option (eql :send-timeout)) &key) + (declare (type number new-value) (ignorable new-value option)) + (let ((socket (socket usocket)) + (timeout new-value)) + (declare (ignorable socket timeout)) + #+abcl + () ; TODO + #+allegro + () ; TODO + #+clisp + (socket:socket-options socket :so-sndtimeo timeout) + #+clozure + (setf (ccl:stream-output-timeout socket) timeout) + #+cmu + (setf (lisp::fd-stream-timeout (socket-stream usocket)) + (coerce timeout 'integer)) + #+(or ecl clasp) + (setf (sb-bsd-sockets:sockopt-send-timeout socket) timeout) + #+lispworks + (set-socket-send-timeout socket timeout) + #+mcl + () ; TODO + #+mocl + () ; unknown + #+sbcl + (setf (sb-impl::fd-stream-timeout (socket-stream usocket)) + (coerce timeout 'single-float)) + #+scl + () ; TODO + new-value)) + +;;; Socket option: REUSE-ADDRESS (SO_REUSEADDR), for TCP server + +(defmethod socket-option ((usocket stream-server-usocket) + (option (eql :reuse-address)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () ; TODO + #+allegro + () ; TODO + #+clisp + (int->bool (socket:socket-options socket :so-reuseaddr)) + #+clozure + (int->bool (get-socket-option-reuseaddr socket)) + #+cmu + () ; TODO + #+lispworks + (get-socket-reuse-address socket) + #+mcl + () ; TODO + #+mocl + () ; unknown + #+(or ecl sbcl clasp) + (sb-bsd-sockets:sockopt-reuse-address socket) + #+scl + ())) ; TODO + +(defmethod (setf socket-option) (new-value (usocket stream-server-usocket) + (option (eql :reuse-address)) &key) + (declare (type boolean new-value) (ignorable new-value option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () ; TODO + #+allegro + (socket:set-socket-options socket option new-value) + #+clisp + (socket:socket-options socket :so-reuseaddr (bool->int new-value)) + #+clozure + (set-socket-option-reuseaddr socket (bool->int new-value)) + #+cmu + () ; TODO + #+lispworks + (set-socket-reuse-address socket new-value) + #+mcl + () ; TODO + #+mocl + () ; unknown + #+(or ecl sbcl clasp) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) new-value) + #+scl + () ; TODO + new-value)) + +;;; Socket option: BROADCAST (SO_BROADCAST), for UDP client + +(defmethod socket-option ((usocket datagram-usocket) + (option (eql :broadcast)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () ; TODO + #+allegro + () ; TODO + #+clisp + (int->bool (socket:socket-options socket :so-broadcast)) + #+clozure + (int->bool (get-socket-option-broadcast socket)) + #+cmu + () ; TODO + #+(or ecl clasp) + () ; TODO + #+lispworks + () ; TODO + #+mcl + () ; TODO + #+mocl + () ; unknown + #+sbcl + (sb-bsd-sockets:sockopt-broadcast socket) + #+scl + ())) ; TODO + +(defmethod (setf socket-option) (new-value (usocket datagram-usocket) + (option (eql :broadcast)) &key) + (declare (type boolean new-value) + (ignorable new-value option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () ; TODO + #+allegro + (socket:set-socket-options socket option new-value) + #+clisp + (socket:socket-options socket :so-broadcast (bool->int new-value)) + #+clozure + (set-socket-option-broadcast socket (bool->int new-value)) + #+cmu + () ; TODO + #+(or ecl clasp) + () ; TODO + #+lispworks + () ; TODO + #+mcl + () ; TODO + #+mocl + () ; unknown + #+sbcl + (setf (sb-bsd-sockets:sockopt-broadcast socket) new-value) + #+scl + () ; TODO + new-value)) + +;;; Socket option: TCP-NODELAY (TCP_NODELAY), for TCP client + +(defmethod socket-option ((usocket stream-usocket) + (option (eql :tcp-no-delay)) &key) + (declare (ignorable option)) + (socket-option usocket :tcp-nodelay)) + +(defmethod socket-option ((usocket stream-usocket) + (option (eql :tcp-nodelay)) &key) + (declare (ignorable option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () ; TODO + #+allegro + () ; TODO + #+clisp + (int->bool (socket:socket-options socket :tcp-nodelay)) + #+clozure + (int->bool (get-socket-option-tcp-nodelay socket)) + #+cmu + () + #+(or ecl clasp) + (sb-bsd-sockets::sockopt-tcp-nodelay socket) + #+lispworks + (int->bool (get-socket-tcp-nodelay socket)) + #+mcl + () ; TODO + #+mocl + () ; unknown + #+sbcl + (sb-bsd-sockets::sockopt-tcp-nodelay socket) + #+scl + ())) ; TODO + +(defmethod (setf socket-option) (new-value (usocket stream-usocket) + (option (eql :tcp-no-delay)) &key) + (declare (ignorable option)) + (setf (socket-option usocket :tcp-nodelay) new-value)) + +(defmethod (setf socket-option) (new-value (usocket stream-usocket) + (option (eql :tcp-nodelay)) &key) + (declare (type boolean new-value) + (ignorable new-value option)) + (let ((socket (socket usocket))) + (declare (ignorable socket)) + #+abcl + () ; TODO + #+allegro + (socket:set-socket-options socket :no-delay new-value) + #+clisp + (socket:socket-options socket :tcp-nodelay (bool->int new-value)) + #+clozure + (set-socket-option-tcp-nodelay socket (bool->int new-value)) + #+cmu + () + #+(or ecl clasp) + (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value) + #+lispworks + (progn + #-(or lispworks4 lispworks5.0) + (comm::set-socket-tcp-nodelay socket new-value) + #+(or lispworks4 lispworks5.0) + (set-socket-tcp-nodelay socket (bool->int new-value))) + #+mcl + () ; TODO + #+mocl + () ; unknown + #+sbcl + (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value) + #+scl + () ; TODO + new-value)) + +(eval-when (:load-toplevel :execute) + (export 'socket-option)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/package.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/package.lisp new file mode 100644 index 0000000..4db895c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/package.lisp @@ -0,0 +1,126 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: CL-USER -*- +;;;; See the LICENSE file for licensing information. + +(defpackage :usocket + (:use #-genera :common-lisp + #+genera :future-common-lisp + #+abcl :java + :split-sequence) + (:export #:*version* + #:*wildcard-host* + #:*auto-port* + + #:+max-datagram-packet-size+ + + #:socket-connect ; socket constructors and methods + #:socket-listen + #:socket-accept + #:socket-close + #:socket-shutdown + #:get-local-address + #:get-peer-address + #:get-local-port + #:get-peer-port + #:get-local-name + #:get-peer-name + + #:socket-send ; udp function (send) + #:socket-receive ; udp function (receive) + + #:wait-for-input ; waiting for input-ready state (select() like) + #:make-wait-list + #:add-waiter + #:remove-waiter + #:remove-all-waiters + + #:with-connected-socket ; convenience macros + #:with-server-socket + #:with-client-socket + #:with-socket-listener + + #:usocket ; socket object and accessors + #:stream-usocket + #:stream-server-usocket + #:socket + #:socket-stream + #:datagram-usocket + #:socket-state ; 0.6.4 + + ;; predicates (for version 0.6 or 1.0 ?) + #:usocket-p + #:stream-usocket-p + #:stream-server-usocket-p + #:datagram-usocket-p + + #:host-byte-order ; IPv4 utility functions + #:hbo-to-dotted-quad + #:hbo-to-vector-quad + #:vector-quad-to-dotted-quad + #:dotted-quad-to-vector-quad + + #:vector-to-ipv6-host ; IPv6 utility functions + #:ipv6-host-to-vector + + #:ip= ; IPv4+IPv6 utility function + #:ip/= + + #:integer-to-octet-buffer ; Network utility functions + #:octet-buffer-to-integer + #:port-to-octet-buffer + #:port-from-octet-buffer + #:ip-to-octet-buffer + #:ip-from-octet-buffer + + #:with-mapped-conditions + + #:socket-condition ; conditions + #:ns-condition + #:socket-error ; errors + #:ns-error + #:unknown-condition + #:ns-unknown-condition + #:unknown-error + #:ns-unknown-error + #:socket-warning ; warnings (udp) + + #:insufficient-implementation ; conditions regarding usocket support level + #:unsupported + #:unimplemented + + #:socket-server + #:*remote-host* + #:*remote-port* + + ;; added in 0.7.1 + #:get-host-by-name + #:get-hosts-by-name + #:get-random-host-by-name + #:ns-host-not-found-error + #:ns-no-recovery-error + #:ns-try-again-condition + #:default-udp-handler + #:default-tcp-handler + #:echo-tcp-handler ;; server handlers + + ;; added in 0.8.0 + #:*backend* + #:*default-event-base* + #:host-to-hostname + + ;; these're socket-related conditions from IOlib + #:ADDRESS-NOT-AVAILABLE-ERROR #:HOST-DOWN-ERROR + #:OPERATION-NOT-SUPPORTED-ERROR #:SOCKET-OPTION + #:NETWORK-DOWN-ERROR #:INVALID-SOCKET-ERROR + #:SOCKET-TYPE-NOT-SUPPORTED-ERROR #:DEADLINE-TIMEOUT-ERROR + #:SHUTDOWN-ERROR #:HOST-UNREACHABLE-ERROR + #:NETWORK-UNREACHABLE-ERROR #:CONNECTION-ABORTED-ERROR + #:BAD-FILE-DESCRIPTOR-ERROR #:PROTOCOL-NOT-SUPPORTED-ERROR + #:CONNECTION-RESET-ERROR #:TIMEOUT-ERROR + #:ADDRESS-IN-USE-ERROR #:NO-BUFFERS-ERROR + #:INVALID-SOCKET-STREAM-ERROR #:INTERRUPTED-CONDITION + #:INVALID-ARGUMENT-ERROR #:OPERATION-NOT-PERMITTED-ERROR + #:NETWORK-RESET-ERROR #:CONNECTION-REFUSED-ERROR + + ;; added in 0.8.2 + #:host-or-ip + )) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/server.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/server.lisp new file mode 100644 index 0000000..9bd2076 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/server.lisp @@ -0,0 +1,112 @@ +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defvar *server*) + +(defun socket-server (host port function &optional arguments + &key in-new-thread (protocol :stream) + ;; for udp + (timeout 1) (max-buffer-size +max-datagram-packet-size+) + ;; for tcp + element-type (reuse-address t) multi-threading + name) + (let* ((real-host (or host *wildcard-host*)) + (socket (ecase protocol + (:stream + (apply #'socket-listen + `(,real-host ,port + ,@(when element-type `(:element-type ,element-type)) + ,@(when reuse-address `(:reuse-address ,reuse-address))))) + (:datagram + (socket-connect nil nil :protocol :datagram + :local-host real-host + :local-port port))))) + (labels ((real-call () + (ecase protocol + (:stream + (tcp-event-loop socket function arguments + :element-type element-type + :multi-threading multi-threading)) + (:datagram + (udp-event-loop socket function arguments + :timeout timeout + :max-buffer-size max-buffer-size))))) + (if in-new-thread + (values (bt:make-thread #'real-call :name (or name "USOCKET Server")) socket) + (progn + (setq *server* socket) + (real-call)))))) + +(defvar *remote-host*) +(defvar *remote-port*) + +(defun default-udp-handler (buffer) ; echo + (declare (type (simple-array (unsigned-byte 8) *) buffer)) + buffer) + +(defun udp-event-loop (socket function &optional arguments + &key timeout max-buffer-size) + (let ((buffer (make-array max-buffer-size :element-type '(unsigned-byte 8) :initial-element 0)) + (sockets (list socket))) + (unwind-protect + (loop do + (multiple-value-bind (return-sockets real-time) + (wait-for-input sockets :timeout timeout) + (declare (ignore return-sockets)) + (when real-time + (multiple-value-bind (recv n *remote-host* *remote-port*) + (socket-receive socket buffer max-buffer-size) + (declare (ignore recv)) + (if (plusp n) + (progn + (let ((reply + (apply function (subseq buffer 0 n) arguments))) + (when reply + (replace buffer reply) + (let ((n (socket-send socket buffer (length reply) + :host *remote-host* + :port *remote-port*))) + (when (minusp n) + (error "send error: ~A~%" n)))))) + (error "receive error: ~A" n)))) + #+scl (when thread:*quitting-lisp* (return)) + #+(and cmu mp) (mp:process-yield))) + (socket-close socket) + (values)))) + +(defun default-tcp-handler (stream) ; null + (declare (type stream stream)) + (format stream "Hello world!~%")) + +(defun echo-tcp-handler (stream) + (loop + (when (listen stream) + (let ((line (read-line stream nil))) + (write-line line stream) + (force-output stream))))) + +(defun tcp-event-loop (socket function &optional arguments + &key element-type multi-threading) + (let ((real-function #'(lambda (client-socket &rest arguments) + (unwind-protect + (multiple-value-bind (*remote-host* *remote-port*) (get-peer-name client-socket) + (apply function (socket-stream client-socket) arguments)) + (close (socket-stream client-socket)) + (socket-close client-socket) + nil)))) + (unwind-protect + (loop do + (let* ((client-socket (apply #'socket-accept + `(,socket ,@(when element-type `(:element-type ,element-type))))) + (client-stream (socket-stream client-socket))) + (if multi-threading + (bt:make-thread (lambda () (apply real-function client-socket arguments)) + :name "USOCKET Client") + (prog1 (apply real-function client-socket arguments) + (close client-stream) + (socket-close client-socket))) + #+scl (when thread:*quitting-lisp* (return)) + #+(and cmu mp) (mp:process-yield))) + (socket-close socket) + (values)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/package.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/package.lisp new file mode 100644 index 0000000..bef2a37 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/package.lisp @@ -0,0 +1,11 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: CL-USER -*- +;;;; See the LICENSE file for licensing information. + +(in-package :cl-user) + +(defpackage :usocket-test + (:use :common-lisp + :usocket + :regression-test) + (:export #:do-tests + #:run-usocket-tests)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-condition.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-condition.lisp new file mode 100644 index 0000000..c82ca70 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-condition.lisp @@ -0,0 +1,28 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*- +;;;; See LICENSE for licensing information. + +(in-package :usocket-test) + +(deftest ns-host-not-found-error.1 + (with-caught-conditions (usocket:ns-host-not-found-error nil) + (usocket:socket-connect "xxx" 123) + t) + nil) + +(deftest timeout-error.1 + (with-caught-conditions (usocket:timeout-error nil) + (usocket:socket-connect "common-lisp.net" 81 :timeout 0) + t) + nil) + +(deftest connection-refused-error.1 + (with-caught-conditions (usocket:connection-refused-error nil) + (usocket:socket-connect "common-lisp.net" 81) + t) + nil) + +(deftest operation-not-permitted-error.1 + (with-caught-conditions (usocket:operation-not-permitted-error nil) + (usocket:socket-listen "0.0.0.0" 81) + t) + nil) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-datagram.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-datagram.lisp new file mode 100644 index 0000000..4fb6330 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-datagram.lisp @@ -0,0 +1,124 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*- +;;;; See LICENSE for licensing information. + +(in-package :usocket-test) + +(defvar *echo-server*) +(defvar *echo-server-port*) + +(defun start-server () + (multiple-value-bind (thread socket) + (socket-server "127.0.0.1" 0 #'identity nil + :in-new-thread t + :protocol :datagram) + (setq *echo-server* thread + *echo-server-port* (get-local-port socket)))) + +(defparameter *max-buffer-size* 32) + +(defvar *send-buffer* + (make-array *max-buffer-size* :element-type '(unsigned-byte 8) :initial-element 0)) + +(defvar *receive-buffer* + (make-array *max-buffer-size* :element-type '(unsigned-byte 8) :initial-element 0)) + +(defun clean-buffers () + (fill *send-buffer* 0) + (fill *receive-buffer* 0)) + +;;; UDP Send Test #1: connected socket +(deftest udp-send.1 + (progn + (unless (and *echo-server* *echo-server-port*) + (start-server)) + (let ((s (socket-connect "127.0.0.1" *echo-server-port* :protocol :datagram))) + (clean-buffers) + (replace *send-buffer* #(1 2 3 4 5)) + (socket-send s *send-buffer* 5) + (wait-for-input s :timeout 3) + (multiple-value-bind (buffer size host port) + (socket-receive s *receive-buffer* *max-buffer-size*) + (declare (ignore buffer size host port)) + (reduce #'+ *receive-buffer* :start 0 :end 5)))) + 15) + +;;; UDP Send Test #2: unconnected socket +(deftest udp-send.2 + (progn + (unless (and *echo-server* *echo-server-port*) + (start-server)) + (let ((s (socket-connect nil nil :protocol :datagram))) + (clean-buffers) + (replace *send-buffer* #(1 2 3 4 5)) + (socket-send s *send-buffer* 5 :host "127.0.0.1" :port *echo-server-port*) + (wait-for-input s :timeout 3) + (multiple-value-bind (buffer size host port) + (socket-receive s *receive-buffer* *max-buffer-size*) + (declare (ignore buffer size host port)) + (reduce #'+ *receive-buffer* :start 0 :end 5)))) + 15) + +(deftest mark-h-david ; Mark H. David's remarkable UDP test code + (let* ((host "localhost") + (port 1111) + (server-sock + (socket-connect nil nil :protocol ':datagram :local-host host :local-port port)) + (client-sock + (socket-connect host port :protocol ':datagram)) + (octet-vector + (make-array 2 :element-type '(unsigned-byte 8) :initial-contents `(,(char-code #\O) ,(char-code #\K)))) + (recv-octet-vector + (make-array 2 :element-type '(unsigned-byte 8)))) + (socket-send client-sock octet-vector 2) + (socket-receive server-sock recv-octet-vector 2) + (prog1 (and (equalp octet-vector recv-octet-vector) + recv-octet-vector) + (socket-close server-sock) + (socket-close client-sock))) + #(79 75)) + +(deftest frank-james ; Frank James' test code for LispWorks/UDP + (with-caught-conditions (#+win32 CONNECTION-RESET-ERROR + #-win32 CONNECTION-REFUSED-ERROR + nil) + (let ((sock (socket-connect "localhost" 1234 + :protocol ':datagram :element-type '(unsigned-byte 8)))) + (unwind-protect + (progn + (socket-send sock (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0) 16) + (let ((buffer (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0))) + (socket-receive sock buffer 16))) + (socket-close sock)))) + nil) + +(defun frank-wfi-test () + (let ((s (socket-connect nil nil :protocol :datagram + :element-type '(unsigned-byte 8) + :local-port 8001))) + (unwind-protect + (do ((i 0 (1+ i)) + (buffer (make-array 1024 :element-type '(unsigned-byte 8) + :initial-element 0)) + (now (get-universal-time)) + (done nil)) + ((or done (= i 4)) + nil) + (format t "~Ds ~D Waiting state ~S~%" (- (get-universal-time) now) i (usocket::state s)) + (when (wait-for-input s :ready-only t :timeout 5) + (format t "~D state ~S~%" i (usocket::state s)) + (handler-bind + ((error (lambda (c) + (format t "socket-receive error: ~A~%" c) + (break) + nil))) + (multiple-value-bind (buffer count remote-host remote-port) + (socket-receive s buffer 1024) + (handler-bind + ((error (lambda (c) + (format t "socket-send error: ~A~%" c) + (break)))) + (when buffer + (socket-send s (subseq buffer 0 count) count + :host remote-host + :port remote-port))))))) + (socket-close s)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-usocket.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-usocket.lisp new file mode 100644 index 0000000..ff03f7f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-usocket.lisp @@ -0,0 +1,179 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*- +;;;; See LICENSE for licensing information. + +;;;; Usage: (usoct:run-usocket-tests) or (usoct:do-tests) + +(in-package :usocket-test) + +(defparameter +non-existing-host+ "1.2.3.4") +(defparameter +unused-local-port+ 15213) + +(defparameter *fake-usocket* + (usocket::make-stream-socket :socket :my-socket + :stream :my-stream)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *common-lisp-net* + (get-host-by-name "common-lisp.net"))) + +(defvar *local-ip*) + +(defmacro with-caught-conditions ((expect throw) &body body) + `(catch 'caught-error + (handler-case + (handler-bind ((unsupported + #'(lambda (c) + (declare (ignore c)) (continue)))) + (progn ,@body)) + (unknown-error (c) (if (typep c ',expect) + (throw 'caught-error ,throw) + (progn + (describe c) + (describe + (usocket::usocket-real-error c)) + c))) + (error (c) (if (typep c ',expect) + (throw 'caught-error ,throw) + (progn + (describe c) + c))) + (unknown-condition (c) (if (typep c ',expect) + (throw 'caught-error ,throw) + (progn + (describe c) + (describe + (usocket::usocket-real-condition c)) + c))) + (condition (c) (if (typep c ',expect) + (throw 'caught-error ,throw) + (progn + (describe c) + c)))))) + +(deftest make-socket.1 (socket *fake-usocket*) :my-socket) +(deftest make-socket.2 (socket-stream *fake-usocket*) :my-stream) + +(deftest socket-no-connect.1 + (with-caught-conditions (socket-error nil) + (socket-connect "127.0.0.1" +unused-local-port+ :timeout 1) + t) + nil) + +(deftest socket-no-connect.2 + (with-caught-conditions (socket-error nil) + (socket-connect #(127 0 0 1) +unused-local-port+ :timeout 1) + t) + nil) + +(deftest socket-no-connect.3 + (with-caught-conditions (socket-error nil) + (socket-connect 2130706433 +unused-local-port+ :timeout 1) ;; == #(127 0 0 1) + t) + nil) + +(deftest socket-failure.1 + (with-caught-conditions (timeout-error nil) + (socket-connect 2130706433 +unused-local-port+ :timeout 1) ;; == #(127 0 0 1) + :unreach) + nil) + +(deftest socket-failure.2 + (with-caught-conditions (timeout-error nil) + (socket-connect +non-existing-host+ 80 :timeout 1) ;; 80 = just a port + :unreach) + nil) + +;; let's hope c-l.net doesn't move soon, or that people start to +;; test usocket like crazy.. +(deftest socket-connect.1 + (with-caught-conditions (nil nil) + (let ((sock (socket-connect "common-lisp.net" 80))) + (unwind-protect + (when (typep sock 'usocket) t) + (socket-close sock)))) + t) + +(deftest socket-connect.2 + (with-caught-conditions (nil nil) + (let ((sock (socket-connect *common-lisp-net* 80))) + (unwind-protect + (when (typep sock 'usocket) t) + (socket-close sock)))) + t) + +(deftest socket-connect.3 + (with-caught-conditions (nil nil) + (let ((sock (socket-connect (usocket::host-byte-order *common-lisp-net*) 80))) + (unwind-protect + (when (typep sock 'usocket) t) + (socket-close sock)))) + t) + +;; let's hope c-l.net doesn't change its software any time soon +(deftest socket-stream.1 + (with-caught-conditions (nil nil) + (let ((sock (socket-connect "common-lisp.net" 80))) + (unwind-protect + (progn + (format (socket-stream sock) + "GET / HTTP/1.0~2%") + (force-output (socket-stream sock)) + (subseq (read-line (socket-stream sock)) 0 4)) + (socket-close sock)))) + "HTTP") + +(deftest socket-name.1 + (with-caught-conditions (nil nil) + (let ((sock (socket-connect *common-lisp-net* 80))) + (unwind-protect + (get-peer-address sock) + (socket-close sock)))) + #.*common-lisp-net*) + +(deftest socket-name.2 + (with-caught-conditions (nil nil) + (let ((sock (socket-connect *common-lisp-net* 80))) + (unwind-protect + (get-peer-port sock) + (socket-close sock)))) + 80) + +(deftest socket-name.3 + (with-caught-conditions (nil nil) + (let ((sock (socket-connect *common-lisp-net* 80))) + (unwind-protect + (get-peer-name sock) + (socket-close sock)))) + #.*common-lisp-net* 80) + +#+ignore +(deftest socket-name.4 + (with-caught-conditions (nil nil) + (let ((sock (socket-connect *common-lisp-net* 80))) + (unwind-protect + (equal (get-local-address sock) *local-ip*) + (socket-close sock)))) + t) + +(deftest socket-shutdown.1 + (with-caught-conditions (nil nil) + (let ((sock (socket-connect *common-lisp-net* 80))) + (unwind-protect + (usocket::ignore-unsupported-warnings + (socket-shutdown sock :input)) + (socket-close sock)) + t)) + t) + +(deftest socket-shutdown.2 + (with-caught-conditions (nil nil) + (let ((sock (socket-connect *common-lisp-net* 80))) + (unwind-protect + (usocket::ignore-unsupported-warnings + (socket-shutdown sock :output)) + (socket-close sock)) + t)) + t) + +(defun run-usocket-tests () + (do-tests)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/udp-one-shot.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/udp-one-shot.lisp new file mode 100644 index 0000000..db09687 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/udp-one-shot.lisp @@ -0,0 +1,86 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*- + +(in-package :usocket-test) + +;; Test code from "INVALID-ARGUMENT-ERROR on socket-receive (#48)" + +;; Author: @4lph4-Ph4un +;; Environment: SBCL 1.4.16, WSL on Windows 10 + +(defun UDP-one-shot-V1 (&optional (port 1232)) + (let ((socket (usocket:socket-connect + nil + nil + :protocol :datagram + :element-type '(unsigned-byte 8) + :local-host "127.0.0.1" + :local-port port)) + (buffer (make-array 8 :element-type '(unsigned-byte 8)))) + (unwind-protect + (multiple-value-bind (received size remote-host remote-port) + ;; NOTE: An explicit buffer can be given. If the length + ;; is nil buffer's length will be used. + (usocket:socket-receive socket buffer 8) + (format t "~A~%" received) + (usocket:socket-send socket + (reverse received) + size + :host remote-host + :port remote-port)) + (usocket:socket-close socket)))) + +#| +Backtrace: + 0: (USOCKET::HANDLE-CONDITION # #) + Locals: + CONDITION = # + SOCKET = # + 1: (SB-KERNEL::%SIGNAL #) + Locals: + CONDITION = # + HANDLER-CLUSTERS = (((# . #)) ((# . #)) ..) + 2: (ERROR SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR :ERRNO 22 :SYSCALL "recvfrom") + Locals: + CONDITION = # + #:G8039 = SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR + SB-DEBUG::MORE = (:ERRNO 22 :SYSCALL "recvfrom") + 3: (SB-BSD-SOCKETS:SOCKET-ERROR "recvfrom" 22) + Locals: + ERRNO = 22 + WHERE = "recvfrom" + 4: ((FLET SB-BSD-SOCKETS::WITH-SOCKET-ADDR-THUNK :IN SB-BSD-SOCKETS:SOCKET-RECEIVE) # + SB-BSD-SOCKETS::SIZE = 16 + SB-BSD-SOCKETS::SOCKADDR = # + 5: (SB-BSD-SOCKETS::CALL-WITH-SOCKET-ADDR # NIL # + SOCKADDR-ARGS = NIL + SOCKET = # + THUNK = # + 6: ((:METHOD SB-BSD-SOCKETS:SOCKET-RECEIVE (SB-BSD-SOCKETS:SOCKET T T)) # #(0 0 0 0 0 0 ...) 8 :OOB NIL :PEEK NIL :WAITALL NIL :DONTWAIT NIL.. + Locals: + #:.DEFAULTING-TEMP. = (UNSIGNED-BYTE 8) + SB-BSD-SOCKETS::BUFFER = #(0 0 0 0 0 0 ...) + SB-BSD-SOCKETS::BUFFER#1 = #(0 0 0 0 0 0 ...) + SB-BSD-SOCKETS::DONTWAIT = NIL + SB-BSD-SOCKETS::ELEMENT-TYPE = (UNSIGNED-BYTE 8) + LENGTH = 8 + LENGTH#1 = 8 + SB-BSD-SOCKETS::OOB = NIL + SB-BSD-SOCKETS::PEEK = NIL + SB-BSD-SOCKETS:SOCKET = # + SB-BSD-SOCKETS::WAITALL = NIL + 7: ((:METHOD USOCKET:SOCKET-RECEIVE (USOCKET:DATAGRAM-USOCKET T T)) # #(0 0 0 0 0 0 ...) 8 :ELEMENT-TYPE (UNSIGNED-BYTE 8)) [fast-method] + Locals: + USOCKET::BUFFER = #(0 0 0 0 0 0 ...) + USOCKET::ELEMENT-TYPE = (UNSIGNED-BYTE 8) + LENGTH = 8 + USOCKET:SOCKET = # + 8: (MASTER-CLASS/SRC/SERVER-03:UDP-ONE-SHOT-V1 1232) + Locals: + PORT = 1232 + SOCKET = # +|# + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/wait-for-input.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/wait-for-input.lisp new file mode 100644 index 0000000..dadd4ca --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/wait-for-input.lisp @@ -0,0 +1,140 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*- +;;;; See LICENSE for licensing information. + +(in-package :usocket-test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *wait-for-input-timeout* 2)) + +(deftest wait-for-input.1 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect *common-lisp-net* 80)) + (time (get-universal-time))) + (unwind-protect + (progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout*) + (- (get-universal-time) time)) + (usocket:socket-close sock)))) + #.*wait-for-input-timeout*) + +(deftest wait-for-input.2 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect *common-lisp-net* 80)) + (time (get-universal-time))) + (unwind-protect + (progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout* :ready-only t) + (- (get-universal-time) time)) + (usocket:socket-close sock)))) + #.*wait-for-input-timeout*) + +(deftest wait-for-input.3 + (with-caught-conditions (nil nil) + (let ((sock (usocket:socket-connect *common-lisp-net* 80))) + (unwind-protect + (progn + (format (usocket:socket-stream sock) + "GET / HTTP/1.0~2%") + (force-output (usocket:socket-stream sock)) + (usocket:wait-for-input sock :timeout *wait-for-input-timeout*) + (subseq (read-line (usocket:socket-stream sock)) 0 4)) + (usocket:socket-close sock)))) + "HTTP") + +;;; Advanced W-F-I tests by Elliott Slaughter + +(defvar *socket-server-port* 0) +(defvar *socket-server-listen* nil) +(defvar *socket-server-connection*) +(defvar *socket-client-connection*) +(defvar *output-p* t) + +(defun stage-1 () + (unless *socket-server-listen* + (setf *socket-server-listen* + (socket-listen *wildcard-host* 0 :element-type '(unsigned-byte 8))) + (setf *socket-server-port* (get-local-port *socket-server-listen*))) + + (setf *socket-server-connection* + (when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t) + (socket-accept *socket-server-listen*))) + + (when *output-p* ; should be NIL + (format t "First time (before client connects) is ~s.~%" + *socket-server-connection*)) + + *socket-server-connection*) + +;; TODO: original test code have addition (:TIMEOUT 0) when doing the SOCKET-CONNECT, +;; it seems cannot work on SBCL/Windows, need to investigate, but here we ignore it. + +(defun stage-2 () + (setf *socket-client-connection* + (socket-connect "localhost" *socket-server-port* :protocol :stream + :element-type '(unsigned-byte 8))) + (setf *socket-server-connection* + (when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t) + #+(and win32 (or lispworks ecl sbcl)) + (when *output-p* + (format t "%READY-P: ~D~%" (usocket::%ready-p *socket-server-listen*))) + (socket-accept *socket-server-listen*))) + + (when *output-p* ; should be a usocket object + (format t "Second time (after client connects) is ~s.~%" + *socket-server-connection*)) + + *socket-server-connection*) + +(defun stage-3 () + (setf *socket-server-connection* + (when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t) + #+(and win32 (or lispworks ecl sbcl)) + (when *output-p* + (format t "%READY-P: ~D~%" (usocket::%ready-p *socket-server-listen*))) + (socket-accept *socket-server-listen*))) + + (when *output-p* ; should be NIL again + (format t "Third time (before second client) is ~s.~%" + *socket-server-connection*)) + + *socket-server-connection*) + +(deftest elliott-slaughter.1 + (let ((*output-p* nil)) + (let* ((s-1 (stage-1)) (s-2 (stage-2)) (s-3 (stage-3))) + (prog1 (and (null s-1) (usocket::usocket-p s-2) (null s-3)) + (socket-close *socket-server-listen*) + (setf *socket-server-listen* nil)))) + t) + +#| + +Issue elliott-slaughter.2 (WAIT-FOR-INPUT/win32 on TCP socket) + +W-F-I correctly found the inputs, but :READY-ONLY didn't work. + +|# +(defun receive-each (connections) + (let ((ready (usocket:wait-for-input connections :timeout 0 :ready-only t))) + (loop for connection in ready + collect (read-line (usocket:socket-stream connection))))) + +(defun receive-all (connections) + (loop for messages = (receive-each connections) + then (receive-each connections) + while messages append messages)) + +(defun send (connection message) + (format (usocket:socket-stream connection) "~a~%" message) + (force-output (usocket:socket-stream connection))) + +(defun server () + (let* ((listen (usocket:socket-listen usocket:*wildcard-host* 12345)) + (connection (usocket:socket-accept listen))) + (loop for messages = (receive-all connection) then (receive-all connection) + do (format t "Got messages:~%~s~%" messages) + do (sleep 1/50)))) + +(defun client () + (let ((connection (usocket:socket-connect "localhost" 12345))) + (loop for i from 0 + do (send connection (format nil "This is message ~a." i)) + do (sleep 1/100)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket-server.asd b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket-server.asd new file mode 100644 index 0000000..61d1c9d --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket-server.asd @@ -0,0 +1,14 @@ +;;;; -*- Mode: Lisp -*- +;;;; +;;;; See the LICENSE file for licensing information. + +(in-package :asdf) + +(defsystem usocket-server + :name "usocket (server)" + :author "Chun Tian (binghe)" + :version (:read-file-form "version.sexp") + :licence "MIT" + :description "Universal socket library for Common Lisp (server side)" + :depends-on (:usocket :bordeaux-threads) + :components ((:file "server"))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket-test.asd b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket-test.asd new file mode 100644 index 0000000..58f5626 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket-test.asd @@ -0,0 +1,23 @@ +;;;; -*- Mode: Lisp -*- + +;;;; See the LICENSE file for licensing information. + +(defsystem usocket-test + :name "usocket test" + :author "Erik Enge" + :maintainer "Chun Tian (binghe)" + :version (:read-file-form "version.sexp") + :licence "MIT" + :description "Tests for usocket" + :depends-on (:usocket-server + :rt) + :components ((:module "test" + :serial t + :components ((:file "package") + (:file "test-usocket") + (:file "test-condition") + (:file "test-datagram") + (:file "wait-for-input"))))) + +(defmethod perform ((op test-op) (c (eql (find-system :usocket-test)))) + (funcall (intern "DO-TESTS" "USOCKET-TEST"))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket.asd b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket.asd new file mode 100644 index 0000000..a4c184b --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket.asd @@ -0,0 +1,58 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; -*- +;;;; +;;;; See the LICENSE file for licensing information. + +(in-package :asdf) + +;;; NOTE: the key "art" here is, no need to recompile any file when switching +;;; between a native backend and IOlib backend. -- Chun Tian (binghe) + +#+sample +(pushnew :usocket-iolib *features*) + +(defsystem usocket + :name "usocket (client, with server symbols)" + :author "Erik Enge & Erik Huelsmann" + :maintainer "Chun Tian (binghe) & Hans Huebner" + :version (:read-file-form "version.sexp") + :licence "MIT" + :description "Universal socket library for Common Lisp" + :depends-on (:split-sequence + #+(and (or sbcl ecl) + (not usocket-iolib)) :sb-bsd-sockets + #+usocket-iolib :iolib) + :components ((:file "package") + (:module "vendor" :depends-on ("package") + :components (#+mcl (:file "kqueue") + #+mcl (:file "OpenTransportUDP"))) + (:file "usocket" :depends-on ("vendor")) + (:file "condition" :depends-on ("usocket")) + #-usocket-iolib + (:module "backend" :depends-on ("condition") + :components (#+abcl (:file "abcl") + #+(or allegro cormanlisp) + (:file "allegro") + #+clisp (:file "clisp") + #+(or openmcl clozure) + (:file "openmcl") + #+clozure (:file "clozure" :depends-on ("openmcl")) + #+cmu (:file "cmucl") + #+(or sbcl ecl clasp) + (:file "sbcl") + #+ecl (:file "ecl" :depends-on ("sbcl")) + #+clasp (:file "clasp" :depends-on ("sbcl")) + #+lispworks (:file "lispworks") + #+mcl (:file "mcl") + #+mocl (:file "mocl") + #+scl (:file "scl") + #+genera (:file "genera") + #+mezzano (:file "mezzano"))) + #-usocket-iolib + (:file "option" :depends-on ("backend")) + #+usocket-iolib + (:module "backend" :depends-on ("condition") + :components ((:file "iolib"))))) + +(defmethod perform ((op test-op) (c (eql (find-system :usocket)))) + (oos 'load-op ':usocket-test) + (oos 'test-op ':usocket-test)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket.lisp new file mode 100644 index 0000000..20025e0 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket.lisp @@ -0,0 +1,727 @@ +;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*- +;;;; See LICENSE for licensing information. + +(in-package :usocket) + +(defparameter *wildcard-host* #(0 0 0 0) + "Hostname to pass when all interfaces in the current system are to + be bound. If this variable is passed to socket-listen, IPv6 capable + systems will also listen for IPv6 connections.") + +(defparameter *auto-port* 0 + "Port number to pass when an auto-assigned port number is wanted.") + +(defparameter *version* #.(asdf:component-version (asdf:find-system :usocket)) + "usocket version string") + +(defconstant +max-datagram-packet-size+ 65507 + "The theoretical maximum amount of data in a UDP datagram. + +The IPv4 UDP packets have a 16-bit length constraint, and IP+UDP header has 28-byte. + +IP_MAXPACKET = 65535, /* netinet/ip.h */ +sizeof(struct ip) = 20, /* netinet/ip.h */ +sizeof(struct udphdr) = 8, /* netinet/udp.h */ + +65535 - 20 - 8 = 65507 + +(But for UDP broadcast, the maximum message size is limited by the MTU size of the underlying link)") + +(defclass usocket () + ((socket + :initarg :socket + :accessor socket + :documentation "Implementation specific socket object instance.'") + (wait-list + :initform nil + :accessor wait-list + :documentation "WAIT-LIST the object is associated with.") + (state + :initform nil + :accessor state + :documentation "Per-socket return value for the `wait-for-input' function. + +The value stored in this slot can be any of + NIL - not ready + :READ - ready to read + :READ-WRITE - ready to read and write + :WRITE - ready to write + +The last two remain unused in the current version. +") + #+(and win32 (or sbcl ecl lispworks)) + (%ready-p + :initform nil + :accessor %ready-p + :documentation "Indicates whether the socket has been signalled +as ready for reading a new connection. + +The value will be set to T by `wait-for-input-internal' (given the +right conditions) and reset to NIL by `socket-accept'. + +Don't modify this slot or depend on it as it is really intended +to be internal only. + +Note: Accessed, but not used for 'stream-usocket'. +" + )) + (:documentation +"The main socket class. + +Sockets should be closed using the `socket-close' method.")) + +(defgeneric socket-state (socket) + (:documentation "NIL - not ready +:READ - ready to read +:READ-WRITE - ready to read and write +:WRITE - ready to write")) + +(defmethod socket-state ((socket usocket)) + (state socket)) + +(defclass stream-usocket (usocket) + ((stream + :initarg :stream + :accessor socket-stream + :documentation "Stream instance associated with the socket." +;; +;;Iff an external-format was passed to `socket-connect' or `socket-listen' +;;the stream is a flexi-stream. Otherwise the stream is implementation +;;specific." +)) + (:documentation +"Stream socket class. +' +Contrary to other sockets, these sockets may be closed either +with the `socket-close' method or by closing the associated stream +(which can be retrieved with the `socket-stream' accessor).")) + +(defclass stream-server-usocket (usocket) + ((element-type + :initarg :element-type + :initform #-lispworks 'character + #+lispworks 'base-char + :reader element-type + :documentation "Default element type for streams created by +`socket-accept'.")) + (:documentation "Socket which listens for stream connections to +be initiated from remote sockets.")) + +(defclass datagram-usocket (usocket) + ((connected-p :type boolean + :accessor connected-p + :initarg :connected-p) + #+(or cmu scl lispworks mcl + (and clisp ffi (not rawsock))) + (%open-p :type boolean + :accessor %open-p + :initform t + :documentation "Flag to indicate if usocket is open, +for GC on implementions operate on raw socket fd.") + #+(or lispworks mcl + (and clisp ffi (not rawsock))) + (recv-buffer :documentation "Private RECV buffer.") + #+(or lispworks mcl) + (send-buffer :documentation "Private SEND buffer.")) + (:documentation "UDP (inet-datagram) socket")) + +(defun usocket-p (socket) + (typep socket 'usocket)) + +(defun stream-usocket-p (socket) + (typep socket 'stream-usocket)) + +(defun stream-server-usocket-p (socket) + (typep socket 'stream-server-usocket)) + +(defun datagram-usocket-p (socket) + (typep socket 'datagram-usocket)) + +(defun make-socket (&key socket) + "Create a usocket socket type from implementation specific socket." + (unless socket + (error 'invalid-socket-error)) + (make-stream-socket :socket socket)) + +(defun make-stream-socket (&key socket stream) + "Create a usocket socket type from implementation specific socket +and stream objects. + +Sockets returned should be closed using the `socket-close' method or +by closing the stream associated with the socket. +" + (unless socket + (error 'invalid-socket-error)) + (unless stream + (error 'invalid-socket-stream-error)) + (make-instance 'stream-usocket + :socket socket + :stream stream)) + +(defun make-stream-server-socket (socket &key (element-type + #-lispworks 'character + #+lispworks 'base-char)) + "Create a usocket-server socket type from an +implementation-specific socket object. + +The returned value is a subtype of `stream-server-usocket'. +" + (unless socket + (error 'invalid-socket-error)) + (make-instance 'stream-server-usocket + :socket socket + :element-type element-type)) + +(defun make-datagram-socket (socket &key connected-p) + (unless socket + (error 'invalid-socket-error)) + (make-instance 'datagram-usocket + :socket socket + :connected-p connected-p)) + +(defgeneric socket-accept (socket &key element-type) + (:documentation + "Accepts a connection from `socket', returning a `stream-socket'. + +The stream associated with the socket returned has `element-type' when +explicitly specified, or the element-type passed to `socket-listen' otherwise.")) + +(defgeneric socket-close (usocket) + (:documentation "Close a previously opened `usocket'.")) + +(defmethod socket-close :before ((usocket usocket)) + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket))) + +;; also see http://stackoverflow.com/questions/4160347/close-vs-shutdown-socket +(defgeneric socket-shutdown (usocket direction) + (:documentation "Shutdown communication on the socket in DIRECTION. + +After a shutdown no input and/or output of the indicated DIRECTION +can be performed on the `usocket'. + +DIRECTION should be either :INPUT or :OUTPUT or :IO")) + +(defgeneric socket-send (usocket buffer length &key host port) + (:documentation "Send packets through a previously opend `usocket'.")) + +(defgeneric socket-receive (usocket buffer length &key) + (:documentation "Receive packets from a previously opend `usocket'. + +Returns 4 values: (values buffer size host port)")) + +(defgeneric get-local-address (socket) + (:documentation "Returns the IP address of the socket.")) + +(defgeneric get-peer-address (socket) + (:documentation + "Returns the IP address of the peer the socket is connected to.")) + +(defgeneric get-local-port (socket) + (:documentation "Returns the IP port of the socket. + +This function applies to both `stream-usocket' and `server-stream-usocket' +type objects.")) + +(defgeneric get-peer-port (socket) + (:documentation "Returns the IP port of the peer the socket to.")) + +(defgeneric get-local-name (socket) + (:documentation "Returns the IP address and port of the socket as values. + +This function applies to both `stream-usocket' and `server-stream-usocket' +type objects.")) + +(defgeneric get-peer-name (socket) + (:documentation + "Returns the IP address and port of the peer +the socket is connected to as values.")) + +(defmacro with-connected-socket ((var socket) &body body) + "Bind `socket' to `var', ensuring socket destruction on exit. + +`body' is only evaluated when `var' is bound to a non-null value. + +The `body' is an implied progn form." + `(let ((,var ,socket)) + (unwind-protect + (when ,var + (with-mapped-conditions (,var) + ,@body)) + (when ,var + (socket-close ,var))))) + +(defmacro with-client-socket ((socket-var stream-var &rest socket-connect-args) + &body body) + "Bind the socket resulting from a call to `socket-connect' with +the arguments `socket-connect-args' to `socket-var' and if `stream-var' is +non-nil, bind the associated socket stream to it." + `(with-connected-socket (,socket-var (socket-connect ,@socket-connect-args)) + ,(if (null stream-var) + `(progn ,@body) + `(let ((,stream-var (socket-stream ,socket-var))) + ,@body)))) + +(defmacro with-server-socket ((var server-socket) &body body) + "Bind `server-socket' to `var', ensuring socket destruction on exit. + +`body' is only evaluated when `var' is bound to a non-null value. + +The `body' is an implied progn form." + `(with-connected-socket (,var ,server-socket) + ,@body)) + +(defmacro with-socket-listener ((socket-var &rest socket-listen-args) + &body body) + "Bind the socket resulting from a call to `socket-listen' with arguments +`socket-listen-args' to `socket-var'." + `(with-server-socket (,socket-var (socket-listen ,@socket-listen-args)) + ,@body)) + +(defstruct (wait-list (:constructor %make-wait-list)) + %wait ;; implementation specific + waiters ;; the list of all usockets + map) ;; maps implementation sockets to usockets + +;; Implementation specific: +;; +;; %setup-wait-list +;; %add-waiter +;; %remove-waiter + +(defun make-wait-list (waiters) + (let ((wl (%make-wait-list))) + (setf (wait-list-map wl) (make-hash-table)) + (%setup-wait-list wl) + (dolist (x waiters wl) ; wl is returned + (add-waiter wl x)))) + +(defun add-waiter (wait-list input) + (setf (gethash (socket input) (wait-list-map wait-list)) input + (wait-list input) wait-list) + (pushnew input (wait-list-waiters wait-list)) + (%add-waiter wait-list input)) + +(defun remove-waiter (wait-list input) + (%remove-waiter wait-list input) + (setf (wait-list-waiters wait-list) + (remove input (wait-list-waiters wait-list)) + (wait-list input) nil) + (remhash (socket input) (wait-list-map wait-list))) + +(defun remove-all-waiters (wait-list) + (dolist (waiter (wait-list-waiters wait-list)) + (%remove-waiter wait-list waiter)) + (setf (wait-list-waiters wait-list) nil) + (clrhash (wait-list-map wait-list))) + +(defun wait-for-input (socket-or-sockets &key timeout ready-only + &aux (single-socket-p + (usocket-p socket-or-sockets))) + "Waits for one or more streams to become ready for reading from +the socket. When `timeout' (a non-negative real number) is +specified, wait `timeout' seconds, or wait indefinitely when +it isn't specified. A `timeout' value of 0 (zero) means polling. + +Returns two values: the first value is the list of streams which +are readable (or in case of server streams acceptable). NIL may +be returned for this value either when waiting timed out or when +it was interrupted (EINTR). The second value is a real number +indicating the time remaining within the timeout period or NIL if +none. + +Without the READY-ONLY arg, WAIT-FOR-INPUT will return all sockets in +the original list you passed it. This prevents a new list from being +consed up. Some users of USOCKET were reluctant to use it if it +wouldn't behave that way, expecting it to cost significant performance +to do the associated garbage collection. + +Without the READY-ONLY arg, you need to check the socket STATE slot for +the values documented in usocket.lisp in the usocket class." + + ;; for NULL sockets, return NIL with respect of TIMEOUT. + (when (null socket-or-sockets) + (when timeout + (sleep timeout)) + (return-from wait-for-input nil)) + + ;; create a new wait-list if it's not created by the caller. + (unless (wait-list-p socket-or-sockets) + ;; OPTIMIZATION: in case socket-or-sockets is an atom, create the wait-list + ;; only once and store it into the usocket itself. + (let ((wl (if (and single-socket-p + (wait-list socket-or-sockets)) + (wait-list socket-or-sockets) ; reuse the per-usocket wait-list + (make-wait-list (if (listp socket-or-sockets) + socket-or-sockets (list socket-or-sockets)))))) + (multiple-value-bind (sockets to-result) + (wait-for-input wl :timeout timeout :ready-only ready-only) + ;; in case of single socket, keep the wait-list + (unless single-socket-p + (remove-all-waiters wl)) + (return-from wait-for-input + (values (if ready-only sockets socket-or-sockets) to-result))))) + + (let* ((start (get-internal-real-time)) + (sockets-ready 0)) + (dolist (x (wait-list-waiters socket-or-sockets)) + (when (setf (state x) + #+(and win32 (or sbcl ecl)) nil ; they cannot rely on LISTEN + #-(and win32 (or sbcl ecl)) + (if (and (stream-usocket-p x) + (listen (socket-stream x))) + :read + nil)) + (incf sockets-ready))) + ;; the internal routine is responsibe for + ;; making sure the wait doesn't block on socket-streams of + ;; which theready- socket isn't ready, but there's space left in the + ;; buffer. socket-or-sockets is not destructed. + (wait-for-input-internal socket-or-sockets + :timeout (if (zerop sockets-ready) timeout 0)) + (let ((to-result (when timeout + (let ((elapsed (/ (- (get-internal-real-time) start) + internal-time-units-per-second))) + (when (< elapsed timeout) + (- timeout elapsed)))))) + ;; two return values: + ;; 1) the original wait-list, or available sockets (ready-only) + ;; 2) remaining timeout + (values (cond (ready-only + (cond (single-socket-p + (if (null (state (car (wait-list-waiters socket-or-sockets)))) + nil ; nothing left if the only socket is not waiting + (wait-list-waiters socket-or-sockets))) + (t (remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state)))) + (t socket-or-sockets)) + to-result)))) + +;; +;; Data utility functions +;; + +(defun integer-to-octet-buffer (integer buffer octets &key (start 0)) + (do ((b start (1+ b)) + (i (ash (1- octets) 3) ;; * 8 + (- i 8))) + ((> 0 i) buffer) + (setf (aref buffer b) + (ldb (byte 8 i) integer)))) + +(defun octet-buffer-to-integer (buffer octets &key (start 0)) + (let ((integer 0)) + (do ((b start (1+ b)) + (i (ash (1- octets) 3) ;; * 8 + (- i 8))) + ((> 0 i) + integer) + (setf (ldb (byte 8 i) integer) + (aref buffer b))))) + +(defmacro port-to-octet-buffer (port buffer &key (start 0)) + `(integer-to-octet-buffer ,port ,buffer 2 :start ,start)) + +(defmacro ip-to-octet-buffer (ip buffer &key (start 0)) + `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 :start ,start)) + +(defmacro port-from-octet-buffer (buffer &key (start 0)) + `(octet-buffer-to-integer ,buffer 2 :start ,start)) + +(defmacro ip-from-octet-buffer (buffer &key (start 0)) + `(octet-buffer-to-integer ,buffer 4 :start ,start)) + +;; +;; IPv4 utility functions +;; + +(defun list-of-strings-to-integers (list) + "Take a list of strings and return a new list of integers (from +parse-integer) on each of the string elements." + (let ((new-list nil)) + (dolist (element (reverse list)) + (push (parse-integer element) new-list)) + new-list)) + +(defun ip-address-string-p (string) + "Return a true value if the given string could be an IP address." + (every (lambda (char) + (or (digit-char-p char) + (eql char #\.))) + string)) + +(defun hbo-to-dotted-quad (integer) ; exported + "Host-byte-order integer to dotted-quad string conversion utility." + (let ((first (ldb (byte 8 24) integer)) + (second (ldb (byte 8 16) integer)) + (third (ldb (byte 8 8) integer)) + (fourth (ldb (byte 8 0) integer))) + (format nil "~A.~A.~A.~A" first second third fourth))) + +(defun hbo-to-vector-quad (integer) ; exported + "Host-byte-order integer to dotted-quad string conversion utility." + (let ((first (ldb (byte 8 24) integer)) + (second (ldb (byte 8 16) integer)) + (third (ldb (byte 8 8) integer)) + (fourth (ldb (byte 8 0) integer))) + (vector first second third fourth))) + +(defun vector-quad-to-dotted-quad (vector) ; exported + (format nil "~A.~A.~A.~A" + (aref vector 0) + (aref vector 1) + (aref vector 2) + (aref vector 3))) + +(defun dotted-quad-to-vector-quad (string) ; exported + (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) + (vector (first list) (second list) (third list) (fourth list)))) + +(defgeneric host-byte-order (address)) ; exported + +(defmethod host-byte-order ((string string)) + "Convert a string, such as 192.168.1.1, to host-byte-order, +such as 3232235777." + (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) + (+ (* (first list) 256 256 256) (* (second list) 256 256) + (* (third list) 256) (fourth list)))) + +(defmethod host-byte-order ((vector vector)) ; IPv4 only + "Convert a vector, such as #(192 168 1 1), to host-byte-order, such as +3232235777." + (+ (* (aref vector 0) 256 256 256) (* (aref vector 1) 256 256) + (* (aref vector 2) 256) (aref vector 3))) + +(defmethod host-byte-order ((int integer)) + int) ; this assume input integer is already host-byte-order + +;; +;; IPv6 utility functions +;; + +(defun vector-to-ipv6-host (vector) ; exported + (with-output-to-string (*standard-output*) + (loop with zeros-collapsed-p + with collapsing-zeros-p + for i below 16 by 2 + for word = (+ (ash (aref vector i) 8) + (aref vector (1+ i))) + do (cond + ((and (zerop word) + (not collapsing-zeros-p) + (not zeros-collapsed-p)) + (setf collapsing-zeros-p t)) + ((or (not (zerop word)) + zeros-collapsed-p) + (when collapsing-zeros-p + (write-string ":") + (setf collapsing-zeros-p nil + zeros-collapsed-p t)) + (format t "~:[~;:~]~X" (plusp i) word))) + finally (when collapsing-zeros-p + (write-string "::"))))) + +(defun split-ipv6-address (string) + (let ((pos 0) + word + double-colon-seen-p + words-before-double-colon + words-after-double-colon) + (loop + (multiple-value-setq (word pos) (parse-integer string :radix 16 :junk-allowed t :start pos)) + (labels ((at-end-p () + (= pos (length string))) + (looking-at-colon-p () + (char= (char string pos) #\:)) + (ensure-colon () + (unless (looking-at-colon-p) + (error "unsyntactic IPv6 address string ~S, expected a colon at position ~D" + string pos)) + (incf pos))) + (cond + ((null word) + (when double-colon-seen-p + (error "unsyntactic IPv6 address string ~S, can only have one double-colon filler mark" + string)) + (setf double-colon-seen-p t)) + (double-colon-seen-p + (push word words-after-double-colon)) + (t + (push word words-before-double-colon))) + (if (at-end-p) + (return (list (nreverse words-before-double-colon) (nreverse words-after-double-colon))) + (ensure-colon)))))) + +(defun ipv6-host-to-vector (string) ; exported + (assert (> (length string) 2) () + "Unsyntactic IPv6 address literal ~S, expected at least three characters" string) + (destructuring-bind (words-before-double-colon words-after-double-colon) + (split-ipv6-address (concatenate 'string + (when (eql (char string 0) #\:) + "0") + string + (when (eql (char string (1- (length string))) #\:) + "0"))) + (let ((number-of-words-specified (+ (length words-before-double-colon) (length words-after-double-colon)))) + (assert (<= number-of-words-specified 8) () + "Unsyntactic IPv6 address literal ~S, too many colon separated address components" string) + (assert (or (= number-of-words-specified 8) words-after-double-colon) () + "Unsyntactic IPv6 address literal ~S, too few address components and no double-colon filler found" string) + (loop with vector = (make-array 16 :element-type '(unsigned-byte 8)) + for i below 16 by 2 + for word in (append words-before-double-colon + (make-list (- 8 number-of-words-specified) :initial-element 0) + words-after-double-colon) + do (setf (aref vector i) (ldb (byte 8 8) word) + (aref vector (1+ i)) (ldb (byte 8 0) word)) + finally (return vector))))) + +;; exported since 0.8.0 +(defun host-to-hostname (host) ; host -> string + "Translate a string, vector quad or 16 byte IPv6 address to a +stringified hostname." + (etypecase host + (string host) ; IPv4 or IPv6 + ((or (vector t 4) ; IPv4 + (array (unsigned-byte 8) (4))) + (vector-quad-to-dotted-quad host)) + ((or (vector t 16) ; IPv6 + (array (unsigned-byte 8) (16))) + (vector-to-ipv6-host host)) + (integer (hbo-to-dotted-quad host)) ; integer input is IPv4 only + (null "0.0.0.0"))) ; null is IPv4 + +(defun ip= (ip1 ip2) ; exported + (etypecase ip1 + (string (string= ip1 ; IPv4 or IPv6 + (host-to-hostname ip2))) + ((or (vector t 4) ; IPv4 + (array (unsigned-byte 8) (4)) ; IPv4 + (vector t 16) ; IPv6 + (array (unsigned-byte 8) (16))) ; IPv6 + (equalp ip1 ip2)) + (integer (= ip1 ; IPv4 only + (host-byte-order ip2))))) ; convert ip2 to integer (hbo) + +(defun ip/= (ip1 ip2) ; exported + (not (ip= ip1 ip2))) + +;; +;; DNS helper functions +;; + +(defun get-host-by-name (name) + "0.7.1+: if there're IPv4 addresses, return the first IPv4 address." + (let* ((hosts (get-hosts-by-name name)) + (pos (position-if #'(lambda (ip) (= 4 (length ip))) hosts))) + (if pos (elt hosts pos) + (car hosts)))) + +(defun get-random-host-by-name (name) + "0.7.1+: if there're IPv4 addresses, only return a random IPv4 address." + (let* ((hosts (get-hosts-by-name name)) + (ipv4-hosts (remove-if-not #'(lambda (ip) (= 4 (length ip))) hosts))) + (cond (ipv4-hosts + (elt ipv4-hosts (random (length ipv4-hosts)))) + (hosts + (elt hosts (random (length hosts))))))) + +(defun host-to-vector-quad (host) ; internal + "Translate a host specification (vector quad, dotted quad or domain name) +to a vector quad." + (etypecase host + (string (let* ((ip (when (ip-address-string-p host) + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + ;; valid IP dotted quad? not sure + ip + (get-random-host-by-name host)))) + ((or (vector t 4) + (array (unsigned-byte 8) (4))) + host) + (integer (hbo-to-vector-quad host)))) + +(defun host-to-hbo (host) ; internal + (etypecase host + (string (let ((ip (when (ip-address-string-p host) + (dotted-quad-to-vector-quad host)))) + (if (and ip (= 4 (length ip))) + (host-byte-order ip) + (host-to-hbo (get-host-by-name host))))) + ((or (vector t 4) + (array (unsigned-byte 8) (4))) + (host-byte-order host)) + (integer host))) + +;; +;; Other utility functions +;; + +(defun split-timeout (timeout &optional (fractional 1000000)) + "Split real value timeout into seconds and microseconds. +Optionally, a different fractional part can be specified." + (multiple-value-bind + (secs sec-frac) + (truncate timeout 1) + (values secs + (truncate (* fractional sec-frac) 1)))) + +;; +;; Setting of documentation for backend defined functions +;; + +;; Documentation for the function +;; +;; (defun SOCKET-CONNECT (host port &key element-type nodelay some-other-keys...) ..) +;; +(setf (documentation 'socket-connect 'function) + "Connect to `host' on `port'. `host' is assumed to be a string or +an IP address represented in vector notation, such as #(192 168 1 1). +`port' is assumed to be an integer. + +`element-type' specifies the element type to use when constructing the +stream associated with the socket. The default is 'character. + +`nodelay' Allows to disable/enable Nagle's algorithm (http://en.wikipedia.org/wiki/Nagle%27s_algorithm). +If this parameter is omitted, the behaviour is inherited from the +CL implementation (in most cases, Nagle's algorithm is +enabled by default, but for example in ACL it is disabled). +If the parameter is specified, one of these three values is possible: + T - Disable Nagle's algorithm; signals an UNSUPPORTED + condition if the implementation does not support explicit + manipulation with that option. + NIL - Leave Nagle's algorithm enabled on the socket; + signals an UNSUPPORTED condition if the implementation does + not support explicit manipulation with that option. + :IF-SUPPORTED - Disables Nagle's algorithm if the implementation + allows this, otherwises just ignore this option. + +Returns a usocket object.") + +;; Documentation for the function +;; +;; (defun SOCKET-LISTEN (host port &key reuseaddress backlog element-type) ..) +;;###FIXME: extend with default-element-type +(setf (documentation 'socket-listen 'function) + "Bind to interface `host' on `port'. `host' should be the +representation of an ready-interface address. The implementation is +not required to do an address lookup, making no guarantees that +hostnames will be correctly resolved. If `*wildcard-host*' or NIL is +passed for `host', the socket will be bound to all available +interfaces for the system. `port' can be selected by the IP stack by +passing `*auto-port*'. + +Returns an object of type `stream-server-usocket'. + +`reuse-address' and `backlog' are advisory parameters for setting socket +options at creation time. `element-type' is the element type of the +streams to be created by `socket-accept'. `reuseaddress' is supported for +backward compatibility (but deprecated); when both `reuseaddress' and +`reuse-address' have been specified, the latter takes precedence. +") + +;;; Small utility functions mapping true/false to 1/0, moved here from option.lisp + +(proclaim '(inline bool->int int->bool)) + +(defun bool->int (bool) (if bool 1 0)) +(defun int->bool (int) (= 1 int)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/vendor/OpenTransportUDP.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/vendor/OpenTransportUDP.lisp new file mode 100644 index 0000000..5dc3cdc --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/vendor/OpenTransportUDP.lisp @@ -0,0 +1,146 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;; +;;; OpenTransportUDP.lisp +;;; Copyright 2012 Chun Tian (binghe) + +;;; UDP extension to OpenTransport.lisp (with some TCP patches) + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :opentransport)) + +;; MCL Issue 28: Passive TCP streams should be able to listen to the loopback interface +;; see http://code.google.com/p/mcl/issues/detail?id=28 for details + +(defparameter *passive-interface-address* NIL + "Address to use for passive connections - optionally bind to loopback address while opening a tcp stream") + +(advise local-interface-ip-address + (or *passive-interface-address* (:do-it)) + :when :around :name 'override-local-interface-ip-address) + +;; MCL Issue 29: Passive TCP connections on OS assigned ports +;; see http://code.google.com/p/mcl/issues/detail?id=29 for details +(advise ot-conn-tcp-passive-connect + (destructuring-bind (conn port &optional (allow-reuse t)) arglist + (declare (ignore allow-reuse)) + (if (eql port #$kOTAnyInetAddress) + ;; Avoids registering a proxy for port 0 but instead registers one for the true port: + (multiple-value-bind (proxy result) + (let* ((*opentransport-class-proxies* NIL) ; makes ot-find-proxy return NIL + (result (:do-it)) ;; pushes onto *opentransport-class-proxies* + (proxy (prog1 + (pop *opentransport-class-proxies*) + (assert (not *opentransport-class-proxies*)))) + (context (cdr proxy)) + (tmpconn (make-ot-conn :context context + :endpoint (pref context :ot-context.ref))) + (localaddress (ot-conn-tcp-get-addresses tmpconn))) + (declare (dynamic-extent tmpconn)) + ;; replace original set in body of function + (setf (ot-conn-local-address conn) localaddress) + (values + (cons localaddress context) + result)) + ;; need to be outside local binding of *opentransport-class-proxies* + (without-interrupts + (push proxy *opentransport-class-proxies*)) + result) + (:do-it))) + :when :around :name 'ot-conn-tcp-passive-connect-any-address) + +(defun open-udp-socket (&key local-address local-port) + (init-opentransport) + (let (endpoint ; TODO: opentransport-alloc-endpoint-from-freelist + (err #$kOTNoError) + (configptr (ot-cloned-configuration traps::$kUDPName))) + (rlet ((errP :osstatus)) + (setq endpoint #+carbon-compat (#_OTOpenEndpointInContext configptr 0 (%null-ptr) errP *null-ptr*) + #-carbon-compat (#_OTOpenEndpoint configptr 0 (%null-ptr) errP) + err (pref errP :osstatus)) + (if (eql err #$kOTNoError) + (let* ((context (ot-make-endpoint-context endpoint nil nil)) ; no notifier, not minimal + (conn (make-ot-conn :context context :endpoint endpoint))) + (macrolet ((check-ot-error-return (error-context) + `(unless (eql (setq err (pref errP :osstatus)) #$kOTNoError) + (values (ot-error err ,error-context))))) + (setf (ot-conn-bindreq conn) + #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP) + #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*) + ) + (check-ot-error-return :alloc) + (setf (ot-conn-bindret conn) + #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP) + #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*) + ) + (check-ot-error-return :alloc) + (setf (ot-conn-options conn) + #-carbon-compat (#_OTAlloc endpoint #$T_OPTMGMT #$T_OPT errP) + #+carbon-compat (#_OTAllocInContext endpoint #$T_OPTMGMT #$T_OPT errP *null-ptr*) + ) + (check-ot-error-return :alloc)) + ;; BIND to local address (for UDP server) + (when local-port ; local-address + (let* ((host (or local-address (local-interface-ip-address))) + (port (tcp-service-port-number local-port)) + (localaddress `(:tcp ,host ,port)) + (bindreq (ot-conn-bindreq conn)) + (bindret (ot-conn-bindret conn))) + (let* ((netbuf (pref bindreq :tbind.addr))) + (declare (dynamic-extent netbuf)) + (setf (pref netbuf :tnetbuf.len) (record-length :inetaddress) + (pref bindreq :tbind.qlen) 5) ; arbitrary qlen + (#_OTInitInetAddress (pref netbuf :tnetbuf.buf) port host) + (setf (pref context :ot-context.completed) nil) + (unless (= (setq err (#_OTBind endpoint bindreq bindret)) #$kOTNoError) + (ot-error err :bind))) + (setf (ot-conn-local-address conn) localaddress))) + conn) + (ot-error err :create))))) + +(defun make-TUnitData (endpoint) + "create the send/recv buffer for UDP sockets" + (let ((err #$kOTNoError)) + (rlet ((errP :osstatus)) + (macrolet ((check-ot-error-return (error-context) + `(unless (eql (setq err (pref errP :osstatus)) #$kOTNoError) + (values (ot-error err ,error-context))))) + (let ((udata #-carbon-compat (#_OTAlloc endpoint #$T_UNITDATA #$T_ALL errP) + #+carbon-compat (#_OTAllocInContext endpoint #$T_UNITDATA #$T_ALL errP *null-ptr*))) + (check-ot-error-return :alloc) + udata))))) + +(defun send-message (conn data buffer size host port &optional (offset 0)) + ;; prepare dest address + (let ((addr (pref data :tunitdata.addr))) + (declare (dynamic-extent addr)) + (setf (pref addr :tnetbuf.len) (record-length :inetaddress)) + (#_OTInitInetAddress (pref addr :tnetbuf.buf) port host)) + ;; prepare data buffer + (let* ((udata (pref data :tunitdata.udata)) + (outptr (pref udata :tnetbuf.buf))) + (declare (dynamic-extent udata)) + (%copy-ivector-to-ptr buffer offset outptr 0 size) + (setf (pref udata :tnetbuf.len) size)) + ;; send the packet + (let* ((endpoint (ot-conn-endpoint conn)) + (result (#_OTSndUData endpoint data))) + (the fixnum result))) + +(defun receive-message (conn data buffer length) + (let* ((endpoint (ot-conn-endpoint conn)) + (err (#_OTRcvUData endpoint data *null-ptr*))) + (if (eql err #$kOTNoError) + (let* (;(addr (pref data :tunitdata.addr)) + (udata (pref data :tunitdata.udata)) + (inptr (pref udata :tnetbuf.buf)) + (read-bytes (pref udata :tnetbuf.len)) + (buffer (or buffer (make-array read-bytes :element-type '(unsigned-byte 8)))) + (length (or length (length buffer))) + (actual-size (min read-bytes length))) + (%copy-ptr-to-ivector inptr 0 buffer 0 actual-size) + (values buffer + actual-size + 0 0)) ; TODO: retrieve address and port + (ot-error err :receive)))) ; TODO: use OTRcvUDErr instead diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/vendor/kqueue.lisp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/vendor/kqueue.lisp new file mode 100644 index 0000000..72d370f --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/vendor/kqueue.lisp @@ -0,0 +1,506 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;; +;; KQUEUE.LISP +;; +;; KQUEUE - BSD kernel event notification mechanism support for Common LISP. +;; Copyright (C) 2007 Terje Norderhaug +;; Released under LGPL - see . +;; Alternative licensing available upon request. +;; +;; DISCLAIMER: The user of this module should understand that executing code is a potentially hazardous +;; activity, and that many dangers and obstacles, marked or unmarked, may exist within this code. +;; As a condition of your use of the module, you assume all risk of personal injury, death, or property +;; loss, and all other bad things that may happen, even if caused by negligence, ignorance or stupidity. +;; The author is is no way responsible, and besides, does not have "deep pockets" nor any spare change. +;; +;; Version: 0.20 alpha (July 26, 2009) - subject to major revisions, so consider yourself warned. +;; Tested with Macintosh Common LISP 5.1 and 5.2, but is intended to be platform and system independent in the future. +;; +;; Email feedback and improvements to . +;; Updated versions will be available from . +;; +;; RELATED IMPLEMENTATIONS +;; There is another kevent.lisp for other platforms by Risto Laakso (merge?). +;; Also a Scheme kevent.ss by Jose Antonio Ortega. +;; +;; SEE ALSO: +;; http://people.freebsd.org/~jlemon/papers/kqueue.pdf +;; http://developer.apple.com/samplecode/FileNotification/index.html +;; The Man page for kqueue() or kevent(). +;; PyKQueue - Python OO interface to KQueue. +;; LibEvent - an event notification library in C by Niels Provos. +;; Liboop - another abstract library in C on top of kevent or other kernel notification. + +#| HISTORY: + +2007-Oct-18 terje version 0.1 released on the Info-MCL mailing list. +2008-Aug-21 terje load-framework-bundle is not needed under MCL 5.2 +2008-Aug-21 terje rename get-addr to lookup-function-in-bundle (only for pre MCL 5.2) +2009-Jul-19 terje uses kevent-error condition and strerror. +2009-Jul-24 terje reports errors unless nil-if-not-found in lookup-function-in-bundle. +2009-Jul-24 terje kevent :variant for C's intptr_t type for 64bit (and osx 10.5) compatibility. +2009-Jul-25 terje 64bit support, dynamically determined for PPC. Kudos to Glen Foy for helping out. +2009-Jul-25 terje make-kevent function. +|# + +#| IMPLEMENTATION NOTES: + +kevents are copied into and from the kernel, so the records don't have to be kept in the app! +kevents does not work in OSX before 10.3. +*kevent-record* has to be explcitly set to :kevent64 to work on 64bit intel macs. +Consider using sysctlbyname() to test for 64bit, + combining hw.cpu64bit_capable, hw.optional.x86_64 and hw.optional.64bitops +|# + +(in-package :ccl) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#-ccl-5.2 ; has been added to MCL 5.2 +(defmethod load-framework-bundle ((framework-name string) &key (load-executable t)) + ;; FRAMWORK CALL FUNCTIONALITY FROM BSD.LISP + ;; (C) 2003 Brendan Burns + ;; Released under LGPL. + (with-cfstrs ((framework framework-name)) + (let ((err 0) + (baseURL nil) + (bundleURL nil) + (result nil)) + (rlet ((folder :fsref)) + ;; Find the folder holding the bundle + (setf err (#_FSFindFolder #$kOnAppropriateDisk #$kFrameworksFolderType + t folder)) + + ;; if everything's cool, make a URL for it + (when (zerop err) + (setf baseURL (#_CFURLCreateFromFSRef (%null-ptr) folder)) + (if (%null-ptr-p baseURL) + (setf err #$coreFoundationUnknownErr))) + + ;; if everything's cool, make a URL for the bundle + (when (zerop err) + (setf bundleURL (#_CFURLCreateCopyAppendingPathComponent (%null-ptr) + baseURL framework nil)) + (if (%null-ptr-p bundleURL) + (setf err #$coreFoundationUnknownErr))) + + ;; if everything's cool, load it + (when (zerop err) + (setf result (#_CFBundleCreate (%null-ptr) bundleURL)) + (if (%null-ptr-p result) + (setf err #$coreFoundationUnknownErr))) + + ;; if everything's cool, and the user wants it loaded, load it + (when (and load-executable (zerop err)) + (if (not (#_CFBundleLoadExecutable result)) + (setf err #$coreFoundationUnknownErr))) + + ;; if there's an error, but we've got a pointer, free it and clear result + (when (and (not (zerop err)) (not (%null-ptr-p result))) + (#_CFRelease result) + (setf result nil)) + + ;; free the URLs if there non-null + (when (not (%null-ptr-p bundleURL)) + (#_CFRelease bundleURL)) + (when (not (%null-ptr-p baseURL)) + (#_CFRelease baseURL)) + + ;; return pointer + error value + (values result err))))) + +#+ignore +(defun get-addr (bundle name) + (let* ((addr (#_CFBundleGetFunctionPointerForName bundle name))) + (rlet ((buf :long)) + (setf (%get-ptr buf) addr) + (ash (%get-signed-long buf) -2)))) + +#-ccl-5.2 +(defun lookup-function-in-bundle (name bundle &optional nil-if-not-found) + (with-cfstrs ((str name)) + (let* ((addr (#_CFBundleGetFunctionPointerForName bundle str))) + (if (%null-ptr-p addr) + (unless nil-if-not-found + (error "Couldn't resolve address of foreign function ~s" name)) + (rlet ((buf :long)) ;; mcl 5.2 uses %fixnum-from-macptr here + (setf (%get-ptr buf) addr) + (ash (%get-signed-long buf) -2)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Convenient way to declare BSD system calls + +#+ignore +(defparameter *system-bundle* + #+ccl-5.2 (get-bundle-for-framework-name "System.framework") + #-ccl-5.2 + (let ((bundle (load-framework-bundle "System.framework"))) + (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b))) + bundle)) + +(defmacro declare-bundle-ff (name name-string &rest arglist &aux (fn (gensym (format nil "ff_~A_" (string name))))) + ;; Is there an existing define-trap like macro for this? or could one be modified for use with bundles? + `(progn + (defloadvar ,fn + (let* ((bundle #+ccl-5.2 (get-bundle-for-framework-name "System.framework") + #-ccl-5.2 + (let ((bundle (load-framework-bundle "System.framework"))) + (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b))) + bundle))) + (lookup-function-in-bundle ,name-string bundle))) + ,(let ((args (do ((arglist arglist (cddr arglist)) + (result)) + ((not (cdr arglist)) (nreverse result)) + (push (second arglist) result)))) + `(defun ,name ,args + (ppc-ff-call ,fn ,@arglist))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declare-bundle-ff %system-kqueue "kqueue" + :signed-fullword) ;; returns a file descriptor no! + +(defun system-kqueue () + (let ((kq (%system-kqueue))) + (if (= kq -1) + (ecase (%system-errno) + (12 (error "The kernel failed to allocate enough memory for the kernel queue")) ; ENOMEM + (24 (error "The per-process descriptor table is full")) ; EMFILE + (23 (error "The system file table is full"))) ; ENFILE + kq))) + +(declare-bundle-ff %system-kevent "kevent" + :unsigned-fullword kq + :address ke + :unsigned-fullword nke + :address ko + :unsigned-fullword nko + :address timeout + :signed-fullword) + +(declare-bundle-ff %system-open "open" + :address name + :unsigned-fullword mode + :unsigned-fullword arg + :signed-fullword) + +(declare-bundle-ff %system-close "close" + :unsigned-fullword fd + :signed-fullword) + +(declare-bundle-ff %system-errno* "__error" + :signed-fullword) + +(declare-bundle-ff %system-strerror "strerror" + :signed-fullword errno + :address) + +(defun %system-errno () + (%get-fixnum (%int-to-ptr (%system-errno*)))) + +; (%system-errno) + +(defconstant $O-EVTONLY #x8000) +; (defconstant $O-NONBLOCK #x800 "Non blocking mode") + +(defun system-open (posix-namestring) + "Low level open function, as in C, returns an fd number" + (with-cstrs ((name posix-namestring)) + (%system-open name $O-EVTONLY 0))) + +(defun system-close (fd) + (%system-close fd)) + +(defrecord timespec + (sec :unsigned-long) + (usec :unsigned-long)) + +(defVar *kevent-record* nil) + +(def-ccl-pointers determine-64bit-kevents () + (setf *kevent-record* + (if (ccl::gestalt #$gestaltPowerPCProcessorFeatures + #+ccl-5.2 #$gestaltPowerPCHas64BitSupport #-ccl-5.2 6) + :kevent32 + :kevent64))) + +(defrecord :kevent32 + (ident :unsigned-long) ; uintptr_t + (filter :short) + (flags :unsigned-short) + (fflags :unsigned-long) + (data :long) ; intptr_t + (udata :pointer)) + +(defrecord :kevent64 + (:variant ; uintptr_t + ((ident64 :uint64)) + ((ident :unsigned-long))) + (filter :short) + (flags :unsigned-short) + (fflags :unsigned-long) + (:variant ; intptr_t + ((data64 :sint64)) + ((data :long))) + (:variant ; RMCL :pointer is 32bit + ((udata64 :uint64)) + ((udata :pointer)))) + +(defun make-kevent (&key (ident 0) (filter 0) (flags 0) (fflags 0) (data 0) (udata *null-ptr*)) + (ecase *kevent-record* + (:kevent64 + (make-record kevent64 + :ident ident + :filter filter + :flags flags + :fflags fflags + :data data + :udata udata)) + (:kevent32 + (make-record kevent32 + :ident ident + :filter filter + :flags flags + :fflags fflags + :data data + :udata udata)))) + +(defun kevent-rref (ke field) + (ecase *kevent-record* + (:kevent32 + (ecase field + (:ident (rref ke :kevent32.ident)) + (:filter (rref ke :kevent32.filter)) + (:flags (rref ke :kevent32.flags)) + (:fflags (rref ke :kevent32.fflags)) + (:data (rref ke :kevent32.data)) + (:udata (rref ke :kevent32.udata)))) + (:kevent64 + (ecase field + (:ident (rref ke :kevent64.ident)) + (:filter (rref ke :kevent64.filter)) + (:flags (rref ke :kevent64.flags)) + (:fflags (rref ke :kevent64.fflags)) + (:data (rref ke :kevent64.data)) + (:udata (rref ke :kevent64.udata)))))) + +(defun kevent-filter (ke) + (kevent-rref ke :filter)) + +(defun kevent-flags (ke) + (kevent-rref ke :flags)) + +(defun kevent-data (ke) + (kevent-rref ke :data)) + + +;; FILTER TYPES: + +(eval-when (:compile-toplevel :load-toplevel :execute) ; added by binghe + +(defconstant $kevent-read-filter -1 "Data available to read") +(defconstant $kevent-write-filter -2 "Writing is possible") +(defconstant $kevent-aio-filter -3 "AIO system call has been made") +(defconstant $kevent-vnode-filter -4 "Event occured on a file descriptor") +(defconstant $kevent-proc-filter -5 "Process performed one or more of the requested events") +(defconstant $kevent-signal-filter -6 "Attempted to deliver a signal to a process") +(defconstant $kevent-timer-filter -7 "Establishes an arbitrary timer") +(defconstant $kevent-netdev-filter -8 "Event occured on a network device") +(defconstant $kevent-filesystem-filter -9) + +) ; eval-when + +; FLAGS: + +(defconstant $kevent-add #x01) +(defconstant $kevent-delete #x02) +(defconstant $kevent-enable #x04) +(defconstant $kevent-disable #x08) +(defconstant $kevent-oneshot #x10) +(defconstant $kevent-clear #x20) +(defconstant $kevent-error #x4000) +(defconstant $kevent-eof #x8000 "EV_EOF") + +;; FFLAGS: + +(defconstant $kevent-file-delete #x01 "The file was unlinked from the file system") +(defconstant $kevent-file-write #x02 "A write occurred on the file") +(defconstant $kevent-file-extend #x04 "The file was extended") +(defconstant $kevent-file-attrib #x08 "The file had its attributes changed") +(defconstant $kevent-file-link #x10 "The link count on the file changed") +(defconstant $kevent-file-rename #x20 "The file was renamed") +(defconstant $kevent-file-revoke #x40 "Access to the file was revoked or the file system was unmounted") +(defconstant $kevent-file-all (logior $kevent-file-delete $kevent-file-write $kevent-file-extend + $kevent-file-attrib $kevent-file-link $kevent-file-rename $kevent-file-revoke)) + + +(defconstant $kevent-net-linkup #x01 "Link is up") +(defconstant $kevent-net-linkdown #x02 "Link is down") +(defconstant $kevent-net-linkinvalid #x04 "Link state is invalid") +(defconstant $kevent-net-added #x08 "IP adress added") +(defconstant $kevent-net-deleted #x10 "IP adress deleted") + +(define-condition kevent-error (simple-error) + ((errno :initform NIL :initarg :errno) + (ko :initform nil :type (or null kevent) :initarg :ko) + (syserr :initform (%system-errno))) + (:report + (lambda (c s) + (with-slots (errno ko syserr) c + (format s "kevent system call error ~A [~A]" errno syserr) + (when errno + (format s "(~A)" (%get-cstring (%system-strerror errno)))) + (when ko + (format s " for ") + (let ((*standard-output* s)) + (print-record ko *kevent-record*))))))) + +(defun %kevent (kq &optional ke ko (timeout 0)) + (check-type kq integer) + (rlet ((&timeout :timespec :sec timeout :usec 1)) + (let ((num (with-timer ;; does not seem to make a difference... + (%system-kevent kq (or ke (%null-ptr))(if ke 1 0)(or ko (%null-ptr))(if ko 1 0) &timeout)))) + ; "If an error occurs while processing an element of the changelist and there + ; is enough room in the eventlist, then the event will be placed in the eventlist with + ; EV_ERROR set in flags and the system error in data." + (when (and ko (plusp (logand $kevent-error (kevent-flags ko)))) + (error 'kevent-error + :errno (kevent-data ko) + :ko ko)) + ; "Otherwise, -1 will be returned, and errno will be set to indicate the error condition." + (when (= num -1) + ;; hack - opentransport provides the constants for the errors documented for the call + (case (%system-errno) + (0 (error "kevent system call failed with an unspecified error")) ;; should not happen! + (13 (error "The process does not have permission to register a filter")) + (14 (error "There was an error reading or writing the kevent structure")) ; EFAULT + (9 (error "The specified descriptor is invalid")) ; EBADF + (4 (error "A signal was delivered before the timeout expired and before any events were placed on the kqueue for return.")) ; EINTR + (22 (error "The specified time limit or filter is invalid")) ; EINVAL + (2 (error "The event could not be found to be modified or deleted")) ; ENOENT + (12 (error "No memory was available to register the event")) ; ENOMEM + (78 (error "The specified process to attach to does not exist"))) ; ESRCH + ;; shouldn't get here... + (errchk (%system-errno)) + (error "error ~A" (%system-errno))) + (unless (zerop num) + (values ko num))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; CLOS INTERFACE + +(defclass kqueue () + ((kq :initform (system-kqueue) + :documentation "file descriptor referencing the kqueue") + (fds :initform NIL)) ;; ## better if kept on top level, perhaps as a hash table... + (:documentation "A kernal event notification channel")) + +(defmethod initialize-instance :after ((q kqueue) &rest rest) + (declare (ignore rest)) + (terminate-when-unreachable q 'kqueue-close)) + +(defmethod kqueue-close ((q kqueue)) + (with-slots (kq fds) q + (when (or kq fds) ;; allow repeated close + (system-close kq) + (setf fds NIL) + (setf kq NIL)))) + +(defmethod kqueue-poll ((q kqueue)) + "Polls a kqueue for kevents" + ;; may not have to be cleared, but just in case: + (flet ((kqueue-poll2 (ko) + (let ((result (with-slots (kq) q + (without-interrupts + (%kevent kq NIL ko))))) + (when result + (let ((type (kevent-filter result))) + (ecase type + (0 (values)) + (#.$kevent-read-filter + (values + :read + (kevent-rref result :ident) + (kevent-rref result :flags) + (kevent-rref result :fflags) + (kevent-rref result :data) + (kevent-rref result :udata))) + (#.$kevent-write-filter :write) + (#.$kevent-aio-filter :aio) + (#.$kevent-vnode-filter + (values + :vnode + (cdr (assoc (kevent-rref result :ident) (slot-value q 'fds))) + (kevent-rref result :flags) + (kevent-rref result :fflags) + (kevent-rref result :data) + (kevent-rref result :udata))) + (#.$kevent-filesystem-filter :filesystem))))))) + (ecase *kevent-record* + (:kevent64 + (rlet ((ko :kevent64 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr))) + (kqueue-poll2 ko))) + (:kevent32 + (rlet ((ko :kevent32 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr))) + (kqueue-poll2 ko)))))) + +(defmethod kqueue-subscribe ((q kqueue) &key ident filter (flags 0) (fflags 0) (data 0) (udata (%null-ptr))) + (let ((ke (make-kevent :ident ident + :filter filter + :flags flags + :fflags fflags + :data data + :udata udata))) + (with-slots (kq) q + (without-interrupts + (%kevent kq ke))))) + +(defmethod kqueue-vnode-subscribe ((q kqueue) pathname) + "Makes the queue report an event when there is a change to a directory or file" + (let* ((namestring (posix-namestring (full-pathname pathname))) + (fd (system-open namestring))) + (with-slots (fds) q + (push (cons fd pathname) fds)) + (kqueue-subscribe q + :ident fd + :filter $kevent-vnode-filter + :flags (logior $kevent-add $kevent-clear) + :fflags $kevent-file-all) + namestring)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#+test +(defun kevent-d (pathname &optional (*standard-output* (fred))) + "Report changes to a file or directory" + (loop + with kqueue = (make-instance 'kqueue) + with sub = (kqueue-vnode-subscribe kqueue pathname) + for i from 1 to 60 + for result = (multiple-value-list (kqueue-poll kqueue)) + unless (equal result '(NIL)) + do (progn + (format T "~A~%" result) + (force-output)) + ; do (process-allow-schedule) + do (sleep 1) + finally (write-line "Done") + )) + +#| + +; Report changes to this file in a fred window (save this document to see what happens): + +(process-run-function "kevent-d" #'kevent-d *loading-file-source-file* + (fred)) + +; Reports files added or removed from the directory of this file: + +(process-run-function "kevent-d" #'kevent-d + (make-pathname :directory (pathname-directory *loading-file-source-file*)) + (fred)) +|# + + + + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/version.sexp b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/version.sexp new file mode 100644 index 0000000..b33445a --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/version.sexp @@ -0,0 +1 @@ +"0.8.3" diff --git a/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/LICENSE b/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/LICENSE new file mode 100644 index 0000000..3d15c9c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2014 Lyon Bros. Enterprises, LLC + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/README.md b/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/README.md new file mode 100644 index 0000000..71cc47c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/README.md @@ -0,0 +1,82 @@ +Vom - A tiny logging library for Common Lisp +============================================ + +Vom is a logging library for lisp. It's goal is to be useful and small. It does +not provide a lot of features as other loggers do, but has a small codebase +that's easy to understand and use. + +## Documentation + +Logging is done by calling one of the logging macros: + +- emerg +- alert +- crit +- error +- warn +- notice +- info +- debug +- debug1 +- debug2 +- debug3 +- debug4 + +Each of these is a macro defined as such: + +```lisp +(defmacro notice (format-str &rest args) ...) +``` + +They are used almost exactly like `format` (but without specifying the stream): + +```lisp +(vom:error "there was a problem setting up your database: ~a" error) +``` + +### Configuration + +You can set a global logging level: + +```lisp +;; set the default loglevel such that only errors (or higher) get logged +(vom:config t :error) +``` + +or you can set per-package loglevels: + +```lisp +(vom:config :my-package :notice) +``` + +In the above examples, any unconfigured package will have the loglevel of +`:error`, but the package `my-package` will log anything that's a `:notice` or +above. + +### \*log-stream\* + +The stream that vom logs to by default. This defaults to `t` (aka +`*standard-output*`) + +### \*log-hook\* + +This is a function of 3 arguments that takes a log level, a package keyword +name, and that package's configured log level and returns one or more streams as +multiple values that the log entry will be logged to: + +```lisp +;; example: this hook logs the request to multiple streams if we're getting a +;; log entry from the "particle-accelerator" package +(setf vom:*log-hook* + (lambda (level package package-level) + (declare (ignore level package-level)) + (if (eq package :particle-accelerator) + (values t *my-file-log-stream* *another-stream*) + t))) +``` + +## License + +MIT. Do what you want with it. Just give me credit. Or I'll come to your house +for two weeks and eat your food and sleep on your couch and use your toothbrush. + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/vom.asd b/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/vom.asd new file mode 100644 index 0000000..614b37e --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/vom.asd @@ -0,0 +1,6 @@ +(asdf:defsystem vom + :author "Andrew Danger Lyon " + :license "MIT" + :version "0.1.4" + :description "A tiny logging utility." + :components ((:file "vom"))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/vom.lisp b/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/vom.lisp new file mode 100644 index 0000000..aafd501 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/vom-20160825-git/vom.lisp @@ -0,0 +1,204 @@ +(defpackage :vom + ;; DON'T use :cl, otherwise most of the implementations bitch about using + ;; error and warn functions + (:use) + ;; import everything from cl that we actually need. while obnoxious, it makes + ;; sure vom runs smoothly on most (all?) implementations. + (:import-from #:cl + #:t #:nil + #:defpackage #:in-package #:*package* #:package-name #:find-package + #:eval-when + #:eval + #:lambda #:defun #:multiple-value-list #:defmacro + #:return-from + #:defvar #:defparameter + #:declare #:optimize #:type #:ignore + #:keyword #:integer + #:assert + #:member + #:macro-function + #:documentation + #:let #:let* #:progn #:multiple-value-bind + #:&rest #:&key + #:if #:when #:unless #:cond + #:loop #:dolist + #:car #:cdr #:cddr + #:write-sequence #:format + #:get-universal-time + #:get-decoded-time + #:string #:string-downcase #:make-string #:concatenate + #:symbolp + #:intern + #:setf #:getf + #:max #:min + #:eq + #:+ #:- #:> #:< #:<= #:>= + #:apply #:funcall + #:append #:list #:length + #:make-synonym-stream) + (:shadow #:error + #:warn + #:debug) + (:export #:config + #:*log-stream* + #:*log-hook* + #:*config* + #:*time-formatter* + #:*log-formatter* + + #:emerg + #:alert + #:crit + #:error + #:warn + #:notice + #:info + #:debug + #:debug1 + #:debug2 + #:debug3 + #:debug4)) +(in-package :vom) + +;; define our *levels* and *max-level-name-length* before the define-level macro +;; is defined (so it can access them) +(eval-when (:load-toplevel :compile-toplevel) + (defparameter *levels* '(:off 0) + "Holds the log level mappings (keyword -> value).") + + (defparameter *max-level-name-length* 0 + "Holds the number of characters in the longest log-level name.")) + +(defvar *config* '(t :warn) + "Holds the logging config as a plist. Holds package -> level mappings, using + T as the default (used if logging from a package that hasn't been + configured).") + +(defvar *log-stream* (make-synonym-stream 'cl:*standard-output*) + "Holds the default stream we're logging to.") + +(defvar *log-hook* + (lambda (log-level package-keyword package-log-level) + (declare (ignore log-level package-keyword package-log-level)) + *log-stream*) + "Holds a function that, given a log-level, a package name, and the effective + log-level for that package, returns one or more (via (values ...)) streams + that this log will be sent to.") + +(defvar *package-level-cache* nil + "A cache that holds package alias -> package loglevel values for quick lookup.") + +(defparameter *time-formatter* + (lambda () + (multiple-value-bind (second minute hour) + (get-decoded-time) + (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second))) + "A function of 0 args that returns the current time in the desired format.") + +(defparameter *log-formatter* + (lambda (format-str level-str package-keyword args) + (let* ((format-str (concatenate 'string "~a<~a> [~a] ~a - " format-str "~%"))) + (apply 'format + (append (list + nil + format-str) + (list + (make-string (- *max-level-name-length* (length level-str)) + :initial-element #\space) + level-str + (funcall *time-formatter*) + (string-downcase (string package-keyword))) + args)))) + "A function that takes a format string (user-supplied), a level string (eg + 'notice' or 'error'), a keyword of the current package, and a list of args + the user supplied with the format string and returns a string of the log line + we want logged.") + +(defun config (package-keyword level-name) + "Configure the log level for a package (or use t for the package name to set + the default log level). The log level is given as a keyword." + (assert (member level-name *levels*)) + (clear-level-cache) + (cond ((eq package-keyword t) + (setf (getf *config* t) level-name)) + ((symbolp package-keyword) + (let* ((name (find-package package-keyword)) + (package-name (string (if name + (package-name name) + package-keyword)))) + (setf (getf *config* (intern package-name :keyword)) level-name))))) + +(defun find-package-level (package-keyword) + "Given package keyword (doesn't have to be an exact match, can be an alias), + find the configured loglevel of that package. + + This caches the package->level connection in *package-level-cache*." + (declare (optimize (cl:speed 3) (cl:safety 0) (cl:debug 0)) + (type keyword package-keyword)) + (let ((cached (getf *package-level-cache* package-keyword))) + (when cached (return-from find-package-level cached)) + (let* ((package (find-package package-keyword)) + (package-name (when package + (intern (package-name package) :keyword))) + (package-level (getf *config* package-name)) + (package-level (if package-level + package-level + (getf *config* t))) + (package-level-value (getf *levels* package-level 0))) + (setf (getf *package-level-cache* package-keyword) package-level-value) + package-level-value))) + +(defun clear-level-cache () + "Clears the package loglevel cache." + (setf *package-level-cache* nil)) + +(defun do-log (level-name log-level package-keyword format-str &rest args) + "The given data to the current *log-stream* stream." + (declare (optimize (cl:speed 3) (cl:safety 0) (cl:debug 0)) + (type keyword level-name package-keyword) + (type integer log-level) + (type string format-str) + (type list args)) + (let* ((package-level-value (find-package-level package-keyword))) + (when (<= log-level package-level-value) + (let* ((level-str (string level-name)) + (logline (funcall *log-formatter* format-str level-str package-keyword args)) + (log-streams (multiple-value-list + (funcall *log-hook* + log-level + package-keyword + package-level-value)))) + (dolist (stream log-streams) + (write-sequence logline (if (eq stream t) + cl:*standard-output* + stream)) + (cl:finish-output stream)))))) + +(defmacro define-level (name level-value) + "Define a log level." + (let ((macro-name (intern (format nil "LOG-~a" (string name)))) + (log-sym (intern (string name)))) + `(progn + (setf (getf *levels* ,name) ,level-value) + (defmacro ,macro-name (format-str &rest args) + ,(format nil "Log output to the ~s log level (~a)" name level-value) + (let ((pkg (intern (package-name *package*) :keyword))) + `(do-log ,,name ,,level-value ,pkg ,format-str ,@args))) + (setf (documentation ',log-sym 'cl:function) (documentation ',macro-name 'cl:function)) + (setf (macro-function ',log-sym) (macro-function ',macro-name)) + (setf *max-level-name-length* (max *max-level-name-length* + (length (string ,name))))))) + +(define-level :emerg 1) +(define-level :alert 2) +(define-level :crit 3) +(define-level :error 4) +(define-level :warn 5) +(define-level :notice 6) +(define-level :info 7) +(define-level :debug 8) +(define-level :debug1 9) +(define-level :debug2 10) +(define-level :debug3 11) +(define-level :debug4 12) + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/.gitignore b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/.gitignore new file mode 100644 index 0000000..df0e0a3 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/.gitignore @@ -0,0 +1 @@ +*.*f*sl diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/.pre-release.sh b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/.pre-release.sh new file mode 100644 index 0000000..32d1ce7 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/.pre-release.sh @@ -0,0 +1 @@ +sh render-doc.sh diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/CHANGELOG b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/CHANGELOG new file mode 100644 index 0000000..157d6cf --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/CHANGELOG @@ -0,0 +1,28 @@ +Version 0.7.6 +2016-01-26 +Revert Rick's changes for alist/plist behavior (Hans Huebner) + +Version 0.7.5 +2015-06-14 +Fixed release script (Hans Huebner) + +Version 0.7.4 +2015-06-14 +Remove post-release.sh that updated c-l.net (Hans Huebner) + +Version 0.7.3 +2015-06-14 +Fix #28 Add ENCODE-OBJECT-SLOTS (Thayne McCombs) +Update html documentation (Hans Huebner) +update documentation link (Hans Huebner) +Documentation work (Hans Huebner) + +Version 0.7.2 +2014-12-05 +Avoid using e notation because Lisp, JS and JSON numeral syntaxes are incompatible. (Grim Schjetne) +readd encode-object/encode-slots API with proper documentation (Philipp Matthias Schaefer) + +Version 0.7.1 +2014-11-04 +Remove unused ENCODE-SLOTS and ENCODE-OBJECT stubs + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/LICENSE b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/LICENSE new file mode 100644 index 0000000..244beda --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2008-2019 Hans Huebner and contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + - Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + - Neither the name BKNR nor the names of its contributors may be + used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/README.md b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/README.md new file mode 100644 index 0000000..7d0a880 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/README.md @@ -0,0 +1,13 @@ +YASON +===== + +> YASON is a Common Lisp library for encoding and decoding data in the +> [JSON](https://raw.github.com/phmarek/clixdoc/master/clixdoc.xsl) +> interchange format. JSON is used as a lightweight alternative to +> XML. YASON has the sole purpose of encoding and decoding data and +> does not impose any object model on the Common Lisp application that +> uses it. + +Please proceed to the [Documentation](http://phmarek.github.io/yason) + +This project was maintained by https://github.com/hanshuebner/ until 2019. diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/clixdoc.xsl b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/clixdoc.xsl new file mode 100644 index 0000000..308a20c --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/clixdoc.xsl @@ -0,0 +1,411 @@ + + + + + + + + + + + + + + + <xsl:value-of select="clix:title"/> + + + + + + + + + + +

+ + + + +

+ + [Generic function] + [Method] + [Macro] + [Function] + +
+ + + + + + + + + => + + + +

+ +
+

+ + + +

+ + [Generic reader] + [Specialized reader] + [Reader] + +
+ + + + + + + + + => + + + +

+ +
+

+ + + +

+ + [Generic writer] + [Specialized writer] + [Writer] + +
+ + + + + (setf ( + + ) new-value) + + => + + + +

+ +
+

+ + + +

+ + [Generic accessor] + [Specialized accessor] + [Accessor] + +
+ + + + + + + + => + +
+ (setf ( + + ) new-value) + +

+ +
+

+ + + +

+ [Special variable]
+ + + + + + +

+ +
+

+ + + +

+ [Standard class]
+ + + + + + +

+ +
+

+ + + +

+ [Condition type]
+ + + + + + +

+ +
+

+ + + +

+ [Symbol]
+ + + + + + +

+ +
+

+ + + +

+ [Constant]
+ + + + + + +

+ +
+

+ + + + + + + +
+ + + + +

+ [Constants]
+ +

+ +
+

+ + + +

+ [Logical Pathname Host]
+ + + + + + +

+ +
+

+ + + + + + + + + + & + + + + + + + + + + + + + + # + + + + + + + + + + + + + + + http://www.lispworks.com/documentation/HyperSpec/Body/ + + + + + +

+ + + + +

+ + + + +

+ + + + +

+ + + + +

Abstract

+
+ +
+ + + +

Contents

+
    + +
  1. + + # + + + +
      + +
    1. + + # + + +
      2. +       +
    +     +
    2. +     +
+ + + +
    + + +
  • + + + +
    • +     +
+ + + + + + + + + + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/doc.xml b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/doc.xml new file mode 100644 index 0000000..b426bb4 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/doc.xml @@ -0,0 +1,748 @@ + + + + + + YASON - A JSON encoder/decoder for Common Lisp + + + YASON is a JSON encoding and decoding library for Common Lisp. It + provides for functions to read JSON strings into Lisp data + structures and for serializing Lisp data structures as JSON + strings. + + + + YASON is a Common Lisp library for encoding and decoding data in + the JSON interchange format. JSON + is used as a lightweight alternative to XML. YASON has the sole + purpose of encoding and decoding data and does not impose any + object model on the Common Lisp application that uses it. + + + + + +

+ JSON is an established + alternative to XML as a data interchange format for web + applications. YASON implements reading and writing of JSON + formatted data in Common Lisp. It does not attempt to provide a + mapping between CLOS objects and YASON, but can be used to + implement such mappings. +

+

+ CL-JSON is + another Common Lisp package that can be used to work with JSON + encoded data. It takes a more integrated approach, providing + for library internal mappings between JSON objects and CLOS + objects. YASON was created as a lightweight, documented + alternative with a minimalistic approach and extensibilty. +

+ + + +

+ YASON has its permanent home at GitHub. + It can be obtained by downloading the release + tarball. The current release is . +

+

+ You may also check out the current development version from its + git + repository. If you have suggestions regarding YASON, please + email me at hans.huebner@gmail.com. +

+

+ YASON is written in ANSI Common Lisp. It depends on UNIT-TEST, + TRIVIAL-GRAY-STREAMS and ALEXANDRIA open source libraries. The + recommended way to install YASON and its dependencies is through + the excellent Quicklisp + library management system. +

+

+ YASON lives in the :yason package and creates a package + nickname :json. Applications will not normally + :use this package, but rather use qualified names to + access YASON's symbols. For that reason, YASON's symbols do not + contain the string "JSON" themselves. See below for usage + samples. +

+ + + + Versions of YASON preceding the v0.6.0 release provided a package + nickname "JSON" for the "YASON" package. This made it impossible + to load both YASON and CL-JSON into the same image, because + CL-JSON uses the "JSON" package name as well. + +

+ As CL-JSON's use of "JSON" as package name has a much longer + history and loading of both CL-JSON and YASON into the same + image has become more common, the "JSON" nickname was removed + from the YASON package with the v0.6.0 release. Users will need + to change their applications so that the "JSON" nickname is no + longer used to refer to the "YASON" package. It is understood + that this is a disruptive change, but as there is no + all-encompassing workaround, this step was felt to be the right + one to make +

+ + + + By default, YASON performs the following mappings between JSON and + CL datatypes: + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
JSON
datatype		CL
datatype		Notes
objecthash-table
:test #'equal		 + Keys are strings by default (see + *parse-object-key-fn*). Set + *parse-object-as* to :alist in + order to have YASON parse objects as alists or to + :plist to parse them as plists. When using plists, + you probably want to also set + *parse-object-key-fn* to a function + that interns the object's keys to symbols. +
arraylist + Can be changed to read to vectors (see + *parse-json-arrays-as-vectors*). +
stringstring + JSON escape characters are recognized upon reading. Upon + writing, known escape characters are used, but non-ASCII + Unicode characters are written as is. +
numbernumber + Parsed with READ, printed with PRINC. This is not a + faithful implementation of the specification. +
truet + Can be changed to read as TRUE (see + *parse-json-booleans-as-symbols*). +
falsenil + Can be changed to read as FALSE (see + *parse-json-booleans-as-symbols*). +
nullnil
+ + + +

+ JSON data is always completely parsed into an equivalent + in-memory representation. Upon reading, some translations are + performed by default to make it easier for the Common Lisp + program to work with the data; see mapping + for details. If desired, the parser can be configured to + preserve the full semantics of the JSON data read. +

+ + For example + + 
CL-USER> (defvar *json-string* "[{\"foo\":1,\"bar\":[7,8,9]},2,3,4,[5,6,7],true,null]")
+*JSON-STRING*
+CL-USER> (let* ((result (yason:parse *json-string*)))
+           (print result)
+           (alexandria:hash-table-plist (first result)))
+
+(#<HASH-TABLE :TEST EQUAL :COUNT 2 {5A4420F1}> 2 3 4 (5 6 7) T NIL)
+("bar" (7 8 9) "foo" 1)
+CL-USER> (defun maybe-convert-to-keyword (js-name)
+           (or (find-symbol (string-upcase js-name) :keyword)
+               js-name))
+MAYBE-CONVERT-TO-KEYWORD
+CL-USER> :FOO ; intern the :FOO keyword
+:FOO
+CL-USER> (let* ((yason:*parse-json-arrays-as-vectors* t)
+                (yason:*parse-json-booleans-as-symbols* t)
+                (yason:*parse-object-key-fn* #'maybe-convert-to-keyword)
+                (result (yason:parse *json-string*)))
+           (print result)
+           (alexandria:hash-table-plist (aref result 0)))
+
+#(#<HASH-TABLE :TEST EQUAL :COUNT 2 {59B4EAD1}> 2 3 4 #(5 6 7) YASON:TRUE NIL)
+("bar" #(7 8 9) :FOO 1)
+ +

+ The second example modifies the parser's behaviour so that JSON + arrays are read as CL vectors, JSON booleans will be read as the + symbols TRUE and FALSE and JSON object keys will be looked up in + the :keyword package. Interning strings coming from an + external source is not recommended practice. +

+ + + + input &key (object-key-fn + *parse-object-as-key-fn*) (object-as *parse-object-as*) + (json-arrays-as-vectors *parse-json-arrays-as-vectors*) + (json-booleans-as-symbols *parse-json-booleans-as-symbols*) + (json-nulls-as-keyword *parse-json-null-as-keyword*) + object + + Parse input, which must be a string or + a stream, as JSON. Returns the Lisp representation of the + JSON structure parsed. +

+ The keyword arguments object-key-fn, + object-as, + json-arrays-as-vectors, + json-booleans-as-symbols, and + json-null-as-keyword may be used + to specify different values for the parsing parameters + from the current bindings of the respective special + variables. +

+ + + + + + If set to a true value, JSON arrays will be parsed as + vectors, not as lists. NIL is the default. + + + + + + Can be set to :hash-table to parse objects as hash + tables, :alist to parse them as alists or + :plist to parse them as plists. :hash-table + is the default. + + + + + + If set to a true value, JSON booleans will be read as the + symbols TRUE and FALSE instead of T and NIL, respectively. + NIL is the default. + + + + + + If set to a true value, JSON null will be read as the + keyword :NULL, instead of NIL. + NIL is the default. + + + + + + Function to call to convert a key string in a JSON object to + a key in the CL hash produced. IDENTITY is the default. + + + + + + + + YASON provides two distinct modes to encode JSON data: + applications can either create an in-memory representation of the + data to be serialized, then have YASON convert it to JSON in one + go, or they can use a set of macros to serialze the JSON data + element-by-element, allowing fine-grained control over the layout + of the generated data. + +

+ Optionally, the JSON that is produced can be indented. + Indentation requires the use of a + JSON-OUTPUT-STREAM as serialization target. + With the stream serializer, such a stream is automatically used. + If indentation is desired with the DOM serializer, such a stream + can be obtained by calling the + MAKE-JSON-OUTPUT-STREAM function with the + target output string as argument. Please be aware that indented + output not requires more space, but is also slower and should + not be enabled in performance critical applications. +

+ + +

+ In this mode, an in-memory structure is encoded in JSON + format. The structure must consist of objects that are + serializable using the ENCODE function. + YASON defines a number of encoders for standard data types + (see MAPPING), but the application can + define additional methods (e.g. for encoding CLOS objects). +

+ For example: + 
CL-USER> (yason:encode
+          (list (alexandria:plist-hash-table
+                 '("foo" 1 "bar" (7 8 9))
+                 :test #'equal)
+                2 3 4
+                '(5 6 7)
+                t nil)
+          *standard-output*)
+[{"foo":1,"bar":[7,8,9]},2,3,4,[5,6,7],true,null]
+(#<HASH-TABLE :TEST EQUAL :COUNT 2 {59942D21}> 2 3 4 (5 6 7) T NIL)
+ + + + object &optional + stream + object + + Encode object in JSON format and + write to stream. May be specialized + by applications to perform specific rendering. Stream + defaults to *STANDARD-OUTPUT*. + + + + + object &optional (stream + *standard-output*) + object + + Encodes object, an alist, in JSON + format and write to stream. + + + + + object &optional (stream + *standard-output*) + object + + Encodes object, a plist, in JSON + format and write to stream. + + + + + stream &key (indent t) + stream + + Creates a json-output-stream instance + that wraps the supplied stream and + optionally performs indentation of the generated JSON + data. The indent argument is + described in WITH-OUTPUT. Note that + if the indent argument is NIL, the + original stream is returned in order to avoid the + performance penalty of the indentation algorithm. + + + + + + Function to call to translate a CL list into JSON data. + 'YASON:ENCODE-PLAIN-LIST-TO-ARRAY is the default; + 'YASON:ENCODE-PLIST and + 'YASON:ENCODE-ALIST are available to produce + JSON objects. +

+ This is useful to translate a deeply recursive structure in a single + YASON:ENCODE call. +

+ + + + + + + Defines the policy to encode symbols as keys (eg. in hash tables). + The default is to error out, to provide backwards-compatible behaviour. +

+ A useful function that can be bound to this variable is + YASON:ENCODE-SYMBOL-AS-LOWERCASE. +

+ + + + + + +

+ In this mode, the JSON structure is generated in a stream. + The application makes explicit calls to the encoding library + in order to generate the JSON structure. It provides for more + control over the generated output, and can be used to generate + arbitary JSON without requiring that there exists a directly + matching Lisp data structure. The streaming API uses the + encode function, so it is possible to + intermix the two (see app-encoders for an + example). +

+ For example: + 
CL-USER> (yason:with-output (*standard-output*)
+           (yason:with-array ()
+             (dotimes (i 3)
+               (yason:encode-array-element i))))
+[0,1,2]
+NIL
+CL-USER> (yason:with-output (*standard-output*)
+           (yason:with-object ()
+             (yason:encode-object-element "hello" "hu hu")
+             (yason:with-object-element ("harr")
+               (yason:with-array ()
+                 (dotimes (i 3)
+                   (yason:encode-array-element i))))))
+{"hello":"hu hu","harr":[0,1,2]}
+NIL
+ + + + (stream &key indent) &body body + result* + + Set up a JSON streaming encoder context on + stream, then evaluate + body. indent + can be set to T to enable indentation with a default + indentation width or to an integer specifying the desired + indentation width. By default, indentation is switched + off. + + + + + (&key indent stream-symbol) &body body + result* + + Set up a JSON streaming encoder context on + stream-symbol (by default + a gensym), then evaluate + body. Return a string with the + generated JSON output. See + WITH-OUTPUT for the description of + the indent keyword argument. + + + + + + This condition is signalled when one of the stream + encoding functions is used outside the dynamic context of + a WITH-OUTPUT or + WITH-OUTPUT-TO-STRING* body. + + + + + () &body body + result* + + Open a JSON array, then run body. + Inside the body, ENCODE-ARRAY-ELEMENT + must be called to encode elements to the opened array. + Must be called within an existing JSON encoder context + (see WITH-OUTPUT and + WITH-OUTPUT-TO-STRING*). + + + + + object + object + + Encode object as next array element to + the last JSON array opened + with WITH-ARRAY in the dynamic + context. object is encoded using the + ENCODE generic function, so it must be of + a type for which an ENCODE method is + defined. + + + + + &rest objects + result* + + Encode objects, a series of JSON + encodable objects, as the next array elements in a JSON + array opened with + WITH-ARRAY. ENCODE-ARRAY-ELEMENTS + uses ENCODE-ARRAY-ELEMENT, which must + be applicable to each object in the list + (i.e. ENCODE must be defined for each + object type). Additionally, this must be called within a + valid stream context. + + + + + () &body body + result* + + Open a JSON object, then run body. + Inside the body, + ENCODE-OBJECT-ELEMENT or + WITH-OBJECT-ELEMENT must be called to + encode elements to the object. Must be called within an + existing JSON encoder + WITH-OUTPUT and + WITH-OUTPUT-TO-STRING*. + + + + + (key) &body body + result* + + Open a new encoding context to encode a JSON object + element. key is the key of the + element. The value will be whatever + body serializes to the current JSON + output context using one of the stream encoding functions. + This can be used to stream out nested object structures. + + + + + key value + value + + Encode key and + value as object element to the last + JSON object opened with WITH-OBJECT + in the dynamic context. key and + value are encoded using the + ENCODE generic function, so they both + must be of a type for which an ENCODE + method is defined. + + + + + &rest elements + result* + + Encodes the parameters into JSON in the last object opened + with WITH-OBJECT using + ENCODE-OBJECT-ELEMENT. The parameters + should consist of alternating key/value pairs, and this + must be called within a valid stream context. + + + + + object slots + result* + + Encodes each slot in SLOTS for OBJECT in the last object + opened with WITH-OBJECT using + ENCODE-OBJECT-ELEMENT. The key is the + slot name, and the value is the slot value for the slot on + OBJECT. It is equivalent to + 
(loop for slot in slots
+    do (encode-object-element (string slot)
+                              (slot-value object slot)))
+
+ + + + + object + result* + + Generic function to encode object slots. There is no default + implementation. + It should be called in an object encoding context. It uses + PROGN combinatation with MOST-SPECIFIC-LAST order, so that + base class slots are encoded before derived class slots. + + + + + object + result* + + Generic function to encode an object. The default implementation + opens a new object encoding context and calls + ENCODE-SLOTS on the argument. + + + + + + Instances of this class are used to wrap an output stream + that is used as a serialization target in the stream + encoder and optionally in the DOM encoder if indentation + is desired. The class name is not exported, use + make-json-output-stream to create a + wrapper stream if required. + + + + + + + + Suppose your application uses structs to represent its data and + you want to encode these structs using JSON in order to send + them to a client application. Suppose further that your structs + also include internal information that you do not want to send. + Here is some code that illustrates how one could implement a + serialization function: + + 
CL-USER> (defstruct user name age password)
+USER
+CL-USER> (defmethod yason:encode ((user user) &optional (stream *standard-output*))
+           (yason:with-output (stream)
+             (yason:with-object ()
+               (yason:encode-object-element "name" (user-name user))
+               (yason:encode-object-element "age" (user-age user)))))
+#<STANDARD-METHOD YASON:ENCODE (USER) {5B40A591}>
+CL-USER> (yason:encode (list (make-user :name "horst" :age 27 :password "puppy")
+                            (make-user :name "uschi" :age 28 :password "kitten")))
+[{"name":"horst","age":27},{"name":"uschi","age":28}]
+(#S(USER :NAME "horst" :AGE 27 :PASSWORD "puppy")
+ #S(USER :NAME "uschi" :AGE 28 :PASSWORD "kitten"))
+ + As you can see, the streaming API and the DOM encoder can be + used together. ENCODE invokes itself + recursively, so any application defined method will be called + while encoding in-memory objects as appropriate. + +

For an example of the interplay between + ENCODE-OBJECT and + ENCODE-SLOTS, suppose you have the following + CLOS class heirarchy: + + 

(defclass shape ()
+  ((color :reader color)))
+
+(defclass square (shape)
+  ((side-length :reader side-length)))
+
+(defclass circle (shape)
+  ((radius :reader radius)))
+ + In order to implement encoding of circles and squares without + duplicating code you can specialize + ENCODE-SLOTS for all three classes + + 
(defmethod yason:encode-slots progn ((shape shape))
+  (yason:encode-object-element "color" (color shape)))
+
+(defmethod yason:encode-slots progn ((square square))
+  (yason:encode-object-element "side-length" (side-length square)))
+
+(defmethod yason:encode-slots progn ((circle circle))
+  (yason:encode-object-element "radius" (radius circle)))
+ + and then use ENCODE-OBJECT: + + 
CL-USER> (yason:with-output-to-string* ()
+           (yason:encode-object (make-instance 'square :color "red" :side-length 3)))
+"{\"color\":\"red\",\"side-length\":3}"
+CL-USER> (yason:with-output-to-string* ()
+           (yason:encode-object (make-instance 'circle :color "blue" :side-length 5)))
+"{\"color\":\"blue\",\"radius\":5}"
+

+

Alternatively, you can use the shortcut ENCODE-OBJECT-SLOTS + if you want the keys to be the slot names. For example: + 

(defclass person ()
+  ((name :reader name :initarg :name)
+   (address :reader address :initarg :address)
+   (phone-number :reader phone-number :initarg :phone)
+   (favorite-color :reader favorite-color :initarg :color)))
+
+(defmethod yason:encode-slots progn ((person person))
+  (yason:encode-object-slots person '(name address phone-number favorite-color)))
+ and then: + + 
CL-USER> (yason:with-output-to-string* ()
+       (yason:encode-object (make-instance 'person :name "John Doe"
+                                                   :address "123 Main St."
+                                                   :phone "(123)-456-7890"
+                                                   :color "blue")))
+"{\"NAME\":\"John Doe\",\"ADDRESS\":\"123 Main St.\",\"PHONE-NUMBER\":\"(123)-456-7890\",
+\"FAVORITE-COLOR\":\"blue\"}"
+

+ + + + + + + + + 
Copyright (c) 2008-2014 Hans Hübner and contributors
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+  - Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+  - Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution.
+
+  - Neither the name BKNR nor the names of its contributors may be
+    used to endorse or promote products derived from this software
+    without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+ + + + Thanks go to Edi Weitz for being a great inspiration. This + documentation as been generated with a hacked-up version of his DOCUMENTATION-TEMPLATE + software. Thanks to David Lichteblau for coining YASON's name. + + + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/encode.lisp b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/encode.lisp new file mode 100644 index 0000000..6c7f902 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/encode.lisp @@ -0,0 +1,388 @@ +;; This file is part of yason, a Common Lisp JSON parser/encoder +;; +;; Copyright (c) 2008-2014 Hans Huebner and contributors +;; All rights reserved. +;; +;; Please see the file LICENSE in the distribution. + +(in-package :yason) + +(defvar *json-output*) + +(defparameter *default-indent* nil + "Set to T or an numeric indentation width in order to have YASON + indent its output by default.") + +(defparameter *default-indent-width* 2 + "Default indentation width for output if indentation is selected + with no indentation width specified.") + +(defparameter *list-encoder* 'encode-plain-list-to-array + "The actual function used to encode a LIST. + Can be changed to encode ALISTs or PLISTs as dictionaries by + setting it to ENCODE-ALIST or ENCODE-PLIST.") + +(defparameter *symbol-key-encoder* 'encode-symbol-key-error + "The actual function used to encode a SYMBOL when seen as a key. + You might want ENCODE-SYMBOL-AS-LOWERCASE here.") + + +(defgeneric encode (object &optional stream) + + (:documentation "Encode OBJECT to STREAM in JSON format. May be + specialized by applications to perform specific rendering. STREAM + defaults to *STANDARD-OUTPUT*.")) + +(defparameter *char-replacements* + (alexandria:plist-hash-table + '(#\\ "\\\\" + #\" "\\\"" + #\Backspace "\\b" + #\Page "\\f" + #\Newline "\\n" + #\Return "\\r" + #\Tab "\\t"))) + +(defun unicode-code (char) + (char-code char)) + +(defun unicode-char (code) + (code-char code)) + +(defun write-surrogate-pair-escape (code stream) + (let ((upper (+ (ldb (byte 10 10) (- code #x10000)) + #xD800)) + (lower (+ (ldb (byte 10 0) (- code #x10000)) + #xDC00))) + (format stream "\\u~4,'0X\\u~4,'0X" upper lower))) + +(defmethod encode ((string string) &optional (stream *standard-output*)) + (write-char #\" stream) + (dotimes (i (length string)) + (let* ((char (aref string i)) + (replacement (gethash char *char-replacements*))) + (cond + (replacement (write-string replacement stream)) + ;; Control characters (U+0000 - U+001F) must be escaped. + ((<= #x0000 (unicode-code char) #x001F) + (format stream "\\u~4,'0X" (unicode-code char))) + ;; Non-BMP characters must be escaped as a UTF-16 surrogate pair. + ((<= #x010000 (unicode-code char) #x10FFFF) + (write-surrogate-pair-escape (unicode-code char) stream)) + (t (write-char char stream))))) + (write-char #\" stream) + string) + +(defmethod encode ((object ratio) &optional (stream *standard-output*)) + (encode (coerce object 'double-float) stream) + object) + +(defmethod encode ((object float) &optional (stream *standard-output*)) + (let ((*read-default-float-format* 'double-float)) + (format stream "~F" (coerce object 'double-float))) + object) + +(defmethod encode ((object integer) &optional (stream *standard-output*)) + (princ object stream)) + +(defmacro with-aggregate/object ((stream opening-char closing-char) &body body) + "Set up serialization context for aggregate serialization with the + object encoder." + (alexandria:with-gensyms (printed) + `(progn + (write-delimiter ,opening-char ,stream) + (change-indentation ,stream #'+) + (prog1 + (let (,printed) + (macrolet ((with-element-output (() &body body) + `(progn + (cond + (,',printed + (write-delimiter #\, ,',stream)) + (t + (setf ,',printed t))) + (write-indentation ,',stream) + ,@body))) + ,@body)) + (change-indentation ,stream #'-) + (write-indentation ,stream) + (write-delimiter ,closing-char ,stream))))) + +(defun encode-key/value (key value stream) + (encode key stream) + (write-char #\: stream) + (encode value stream)) + +(defmethod encode ((object hash-table) &optional (stream *standard-output*)) + (with-aggregate/object (stream #\{ #\}) + (maphash (lambda (key value) + (with-element-output () + (encode-key/value key value stream))) + object) + object)) + +(defmethod encode ((object vector) &optional (stream *standard-output*)) + (with-aggregate/object (stream #\[ #\]) + (loop for value across object + do (with-element-output () + (encode value stream))) + object)) + +(defun encode-plain-list-to-array (object stream) + (with-aggregate/object (stream #\[ #\]) + (dolist (value object) + (with-element-output () + (encode value stream))) + object)) + +(defmethod encode ((object list) &optional (stream *standard-output*)) + (funcall *list-encoder* object stream)) + + +(defun encode-symbol-key-error (key) + (error "No policy for symbols as keys defined. ~ + Please check YASON:*SYMBOL-KEY-ENCODER*.")) + +(defun encode-symbol-as-lowercase (key) + "Encodes a symbol KEY as a lowercase string. + Ensure that there's no intentional lower-case character lost." + (let ((name (symbol-name key))) + (assert (notany #'lower-case-p name)) + (string-downcase name))) + +(defun encode-assoc-key/value (key value stream) + ;; Checking (EVERY #'UPPER-CASE-P name) breaks with non-alpha characters like #\- + (let ((string (if (symbolp key) + (funcall *symbol-key-encoder* key) + (string key)))) + (encode-key/value string value stream))) + +(defun encode-alist (object &optional (stream *standard-output*)) + ;; Failsafe in case this here is not an ALIST but a normal list + (if (consp (first object)) + (with-aggregate/object (stream #\{ #\}) + (loop for (key . value) in object + do (with-element-output () + (encode-assoc-key/value key value stream))) + object) + ;; We can't call *LIST-ENCODER* again, that would be an unlimited recursion + (encode-plain-list-to-array object stream))) + +(defun encode-plist (object &optional (stream *standard-output*)) + (with-aggregate/object (stream #\{ #\}) + (loop for (key value) on object by #'cddr + do (with-element-output () + (encode-assoc-key/value key value stream))) + object)) + +(defmethod encode ((object (eql 'true)) &optional (stream *standard-output*)) + (write-string "true" stream) + object) + +(defmethod encode ((object (eql 'false)) &optional (stream *standard-output*)) + (write-string "false" stream) + object) + +(defmethod encode ((object (eql :null)) &optional (stream *standard-output*)) + (write-string "null" stream) + object) + +(defmethod encode ((object (eql t)) &optional (stream *standard-output*)) + (write-string "true" stream) + object) + +(defmethod encode ((object (eql nil)) &optional (stream *standard-output*)) + (write-string "null" stream) + object) + +(defclass json-output-stream (trivial-gray-streams:fundamental-character-output-stream) + ((output-stream :reader output-stream + :initarg :output-stream) + (stack :accessor stack + :initform nil) + (indent :initarg :indent + :reader indent + :accessor indent%) + (indent-string :initform "" + :accessor indent-string)) + (:default-initargs :indent *default-indent*) + (:documentation "Objects of this class capture the state of a JSON stream encoder.")) + +(defmethod initialize-instance :after ((stream json-output-stream) &key indent) + (when (eq indent t) + (setf (indent% stream) *default-indent-width*))) + +(defgeneric make-json-output-stream (stream &key indent)) + +(defmethod make-json-output-stream (stream &key (indent t)) + "Create a JSON output stream with indentation enabled." + (if indent + (make-instance 'json-output-stream :output-stream stream :indent indent) + stream)) + +(defmethod trivial-gray-streams:stream-write-char ((stream json-output-stream) char) + (write-char char (output-stream stream))) + +(defgeneric write-indentation (stream) + (:method ((stream t)) + nil) + (:method ((stream json-output-stream)) + (when (indent stream) + (fresh-line (output-stream stream)) + (write-string (indent-string stream) (output-stream stream))))) + +(defgeneric write-delimiter (char stream) + (:method (char stream) + (write-char char stream)) + (:method (char (stream json-output-stream)) + (write-char char (output-stream stream)))) + +(defgeneric change-indentation (stream operator) + (:method ((stream t) (operator t)) + nil) + (:method ((stream json-output-stream) operator) + (when (indent stream) + (setf (indent-string stream) (make-string (funcall operator (length (indent-string stream)) + (indent stream)) + :initial-element #\Space))))) + +(defun next-aggregate-element () + (if (car (stack *json-output*)) + (write-char (car (stack *json-output*)) (output-stream *json-output*)) + (setf (car (stack *json-output*)) #\,))) + +(defmacro with-output ((stream &rest args &key indent) &body body) + (declare (ignore indent)) + "Set up a JSON streaming encoder context on STREAM, then evaluate BODY." + `(let ((*json-output* (make-instance 'json-output-stream :output-stream ,stream ,@args))) + ,@body)) + +(defmacro with-output-to-string* ((&rest args &key indent stream-symbol) &body body) + "Set up a JSON streaming encoder context, then evaluate BODY. + Return a string with the generated JSON output." + (declare (ignore indent)) + (let ((stream (or stream-symbol (gensym "STREAM")))) + (remf args :stream-symbol) + `(with-output-to-string (,stream) + (with-output (,stream ,@args) + ,@body)))) + +(define-condition no-json-output-context (error) + () + (:report "No JSON output context is active") + (:documentation "This condition is signalled when one of the stream + encoding function is used outside the dynamic context of a + WITH-OUTPUT or WITH-OUTPUT-TO-STRING* body.")) + +(defmacro with-aggregate/stream ((begin-char end-char) &body body) + "Set up context for aggregate serialization for the stream encoder." + `(progn + (unless (boundp '*json-output*) + (error 'no-json-output-context)) + (when (stack *json-output*) + (next-aggregate-element)) + (write-indentation *json-output*) + (write-delimiter ,begin-char *json-output*) + (change-indentation *json-output* #'+) + (push nil (stack *json-output*)) + (prog1 + (progn ,@body) + (pop (stack *json-output*)) + (change-indentation *json-output* #'-) + (write-indentation *json-output*) + (write-delimiter ,end-char *json-output*)))) + +(defmacro with-array (() &body body) + "Open a JSON array, then run BODY. Inside the body, +ENCODE-ARRAY-ELEMENT must be called to encode elements to the opened +array. Must be called within an existing JSON encoder context, see +WITH-OUTPUT and WITH-OUTPUT-TO-STRING*." + `(with-aggregate/stream (#\[ #\]) ,@body)) + +(defmacro with-object (() &body body) + "Open a JSON object, then run BODY. Inside the body, +ENCODE-OBJECT-ELEMENT or WITH-OBJECT-ELEMENT must be called to encode +elements to the object. Must be called within an existing JSON +encoder context, see WITH-OUTPUT and WITH-OUTPUT-TO-STRING*." + `(with-aggregate/stream (#\{ #\}) ,@body)) + +(defun encode-array-element (object) + "Encode OBJECT as next array element to the last JSON array opened +with WITH-ARRAY in the dynamic context. OBJECT is encoded using the +ENCODE generic function, so it must be of a type for which an ENCODE +method is defined." + (next-aggregate-element) + (write-indentation *json-output*) + (encode object (output-stream *json-output*))) + +(defun encode-array-elements (&rest objects) + "Encode OBJECTS, a list of JSON encodable objects, as array elements." + (dolist (object objects) + (encode-array-element object))) + +(defun encode-object-element (key value) + "Encode KEY and VALUE as object element to the last JSON object +opened with WITH-OBJECT in the dynamic context. KEY and VALUE are +encoded using the ENCODE generic function, so they both must be of a +type for which an ENCODE method is defined." + (next-aggregate-element) + (write-indentation *json-output*) + (encode-key/value key value (output-stream *json-output*)) + value) + +(defun encode-object-elements (&rest elements) + "Encode plist ELEMENTS as object elements." + (loop for (key value) on elements by #'cddr + do (encode-object-element key value))) + +(defun encode-object-slots (object slots) + "For each slot in SLOTS, encode that slot on OBJECT as an object element. +Equivalent to calling ENCODE-OBJECT-ELEMENT for each slot where the +key is the slot name, and the value is the (SLOT-VALUE OBJECT slot)" + (loop for slot in slots + do (encode-object-element (string slot) + (slot-value object slot)))) + +(define-compiler-macro encode-object-slots (&whole form &environment env object raw-slots) + "Compiler macro to allow open-coding with encode-object-slots when slots are literal list." + (let ((slots (macroexpand raw-slots env))) + (cond + ((null slots) nil) + ((eq (car slots) 'quote) + (setf slots (cadr slots)) ; Get the quoted list + `(with-slots ,slots ,object + ,@(loop for slot in slots + collect `(encode-object-element ,(string slot) ,slot)))) + (t form)))) + +(defmacro with-object-element ((key) &body body) + "Open a new encoding context to encode a JSON object element. KEY + is the key of the element. The value will be whatever BODY + serializes to the current JSON output context using one of the + stream encoding functions. This can be used to stream out nested + object structures." + `(progn + (next-aggregate-element) + (write-indentation *json-output*) + (encode ,key (output-stream *json-output*)) + (setf (car (stack *json-output*)) #\:) + (unwind-protect + (progn ,@body) + (setf (car (stack *json-output*)) #\,)))) + +(defgeneric encode-slots (object) + (:documentation + "Generic function to encode object slots. It should be called in an + object encoding context. It uses PROGN combinatation with + MOST-SPECIFIC-LAST order, so that base class slots are encoded + before derived class slots.") + (:method-combination progn :most-specific-last)) + +(defgeneric encode-object (object) + (:documentation + "Generic function to encode an object. The default implementation + opens a new object encoding context and calls ENCODE-SLOTS on + the argument.") + (:method (object) + (with-object () + (yason:encode-slots object)))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/index.html b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/index.html new file mode 100644 index 0000000..9f09709 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/index.html @@ -0,0 +1,764 @@ + +YASON - A JSON encoder/decoder for Common Lisp + +

YASON - A JSON encoder/decoder for Common Lisp

+ + + +

Abstract

+
+ YASON is a Common Lisp library for encoding and decoding data in + the JSON interchange format. JSON + is used as a lightweight alternative to XML. YASON has the sole + purpose of encoding and decoding data and does not impose any + object model on the Common Lisp application that uses it. +
+ +

Contents

+
    +
  1. Introduction
    2. +
  2. Download and Installation
    3. +
  3. Using JSON as package name
    4. +
  4. Mapping between JSON and CL datatypes
    5. +
  5. +Parsing JSON data
    1. Parser dictionary
    +
    6. +
  6. +Encoding JSON data
      +
    1. Encoding a JSON DOM
      2. +
    2. Encoding JSON in streaming mode
      3. +
    3. Application specific encoders
      4. +
    +
    7. +
  7. Symbol index
    8. +
  8. License
    9. +
  9. Acknowledgements
    10. +
+ +

Introduction

+

+ JSON is an established + alternative to XML as a data interchange format for web + applications. YASON implements reading and writing of JSON + formatted data in Common Lisp. It does not attempt to provide a + mapping between CLOS objects and YASON, but can be used to + implement such mappings. +

+

+ CL-JSON is + another Common Lisp package that can be used to work with JSON + encoded data. It takes a more integrated approach, providing + for library internal mappings between JSON objects and CLOS + objects. YASON was created as a lightweight, documented + alternative with a minimalistic approach and extensibilty. +

+ + +

Download and Installation

+

+ YASON has its permanent home at GitHub. + It can be obtained by downloading the release + tarball. The current release is 0.7.6. +

+

+ You may also check out the current development version from its + git + repository. If you have suggestions regarding YASON, please + email me at hans.huebner@gmail.com. +

+

+ YASON is written in ANSI Common Lisp. It depends on UNIT-TEST, + TRIVIAL-GRAY-STREAMS and ALEXANDRIA open source libraries. The + recommended way to install YASON and its dependencies is through + the excellent Quicklisp + library management system. +

+

+ YASON lives in the :yason package and creates a package + nickname :json. Applications will not normally + :use this package, but rather use qualified names to + access YASON's symbols. For that reason, YASON's symbols do not + contain the string "JSON" themselves. See below for usage + samples. +

+ + +

Using JSON as package name

+ Versions of YASON preceding the v0.6.0 release provided a package + nickname "JSON" for the "YASON" package. This made it impossible + to load both YASON and CL-JSON into the same image, because + CL-JSON uses the "JSON" package name as well. + +

+ As CL-JSON's use of "JSON" as package name has a much longer + history and loading of both CL-JSON and YASON into the same + image has become more common, the "JSON" nickname was removed + from the YASON package with the v0.6.0 release. Users will need + to change their applications so that the "JSON" nickname is no + longer used to refer to the "YASON" package. It is understood + that this is a disruptive change, but as there is no + all-encompassing workaround, this step was felt to be the right + one to make +

+ + +

Mapping between JSON and CL datatypes

+ By default, YASON performs the following mappings between JSON and + CL datatypes: + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
JSON

datatype		CL

datatype		Notes
objecthash-table

:test #'equal		 + Keys are strings by default (see + *parse-object-key-fn*). Set + *parse-object-as* to :alist in + order to have YASON parse objects as alists or to + :plist to parse them as plists. When using plists, + you probably want to also set + *parse-object-key-fn* to a function + that interns the object's keys to symbols. +
arraylist + Can be changed to read to vectors (see + *parse-json-arrays-as-vectors*). +
stringstring + JSON escape characters are recognized upon reading. Upon + writing, known escape characters are used, but non-ASCII + Unicode characters are written as is. +
numbernumber + Parsed with READ, printed with PRINC. This is not a + faithful implementation of the specification. +
truet + Can be changed to read as TRUE (see + *parse-json-booleans-as-symbols*). +
falsenil + Can be changed to read as FALSE (see + *parse-json-booleans-as-symbols*). +
nullnil
+ + +

Parsing JSON data

+

+ JSON data is always completely parsed into an equivalent + in-memory representation. Upon reading, some translations are + performed by default to make it easier for the Common Lisp + program to work with the data; see mapping + for details. If desired, the parser can be configured to + preserve the full semantics of the JSON data read. +

+ + For example + + 
CL-USER> (defvar *json-string* "[{\"foo\":1,\"bar\":[7,8,9]},2,3,4,[5,6,7],true,null]")
+*JSON-STRING*
+CL-USER> (let* ((result (yason:parse *json-string*)))
+           (print result)
+           (alexandria:hash-table-plist (first result)))
+
+(#<HASH-TABLE :TEST EQUAL :COUNT 2 {5A4420F1}> 2 3 4 (5 6 7) T NIL)
+("bar" (7 8 9) "foo" 1)
+CL-USER> (defun maybe-convert-to-keyword (js-name)
+           (or (find-symbol (string-upcase js-name) :keyword)
+               js-name))
+MAYBE-CONVERT-TO-KEYWORD
+CL-USER> :FOO ; intern the :FOO keyword
+:FOO
+CL-USER> (let* ((yason:*parse-json-arrays-as-vectors* t)
+                (yason:*parse-json-booleans-as-symbols* t)
+                (yason:*parse-object-key-fn* #'maybe-convert-to-keyword)
+                (result (yason:parse *json-string*)))
+           (print result)
+           (alexandria:hash-table-plist (aref result 0)))
+
+#(#<HASH-TABLE :TEST EQUAL :COUNT 2 {59B4EAD1}> 2 3 4 #(5 6 7) YASON:TRUE NIL)
+("bar" #(7 8 9) :FOO 1)
+ +

+ The second example modifies the parser's behaviour so that JSON + arrays are read as CL vectors, JSON booleans will be read as the + symbols TRUE and FALSE and JSON object keys will be looked up in + the :keyword package. Interning strings coming from an + external source is not recommended practice. +

+ +

Parser dictionary

+

[Function]
parse input &key (object-key-fn + *parse-object-as-key-fn*) (object-as *parse-object-as*) + (json-arrays-as-vectors *parse-json-arrays-as-vectors*) + (json-booleans-as-symbols *parse-json-booleans-as-symbols*) + (json-nulls-as-keyword *parse-json-null-as-keyword*) + => + object

+ Parse input, which must be a string or + a stream, as JSON. Returns the Lisp representation of the + JSON structure parsed. +

+ The keyword arguments object-key-fn, + object-as, + json-arrays-as-vectors, + json-booleans-as-symbols, and + json-null-as-keyword may be used + to specify different values for the parsing parameters + from the current bindings of the respective special + variables. +

+

+ +

+ [Special variable]
*parse-json-arrays-as-vectors*

+ If set to a true value, JSON arrays will be parsed as + vectors, not as lists. NIL is the default. +

+ +

+ [Special variable]
*parse-object-as*

+ Can be set to :hash-table to parse objects as hash + tables, :alist to parse them as alists or + :plist to parse them as plists. :hash-table + is the default. +

+ +

+ [Special variable]
*parse-json-booleans-as-symbols*

+ If set to a true value, JSON booleans will be read as the + symbols TRUE and FALSE instead of T and NIL, respectively. + NIL is the default. +

+ +

+ [Special variable]
*parse-json-null-as-keyword*

+ If set to a true value, JSON null will be read as the + keyword :NULL, instead of NIL. + NIL is the default. +

+ +

+ [Special variable]
*parse-object-key-fn*

+ Function to call to convert a key string in a JSON object to + a key in the CL hash produced. IDENTITY is the default. +

+ + + + +

Encoding JSON data

+ YASON provides two distinct modes to encode JSON data: + applications can either create an in-memory representation of the + data to be serialized, then have YASON convert it to JSON in one + go, or they can use a set of macros to serialze the JSON data + element-by-element, allowing fine-grained control over the layout + of the generated data. + +

+ Optionally, the JSON that is produced can be indented. + Indentation requires the use of a + JSON-OUTPUT-STREAM as serialization target. + With the stream serializer, such a stream is automatically used. + If indentation is desired with the DOM serializer, such a stream + can be obtained by calling the + MAKE-JSON-OUTPUT-STREAM function with the + target output string as argument. Please be aware that indented + output not requires more space, but is also slower and should + not be enabled in performance critical applications. +

+ +

Encoding a JSON DOM

+

+ In this mode, an in-memory structure is encoded in JSON + format. The structure must consist of objects that are + serializable using the ENCODE function. + YASON defines a number of encoders for standard data types + (see MAPPING), but the application can + define additional methods (e.g. for encoding CLOS objects). +

+ For example: + 
CL-USER> (yason:encode
+          (list (alexandria:plist-hash-table
+                 '("foo" 1 "bar" (7 8 9))
+                 :test #'equal)
+                2 3 4
+                '(5 6 7)
+                t nil)
+          *standard-output*)
+[{"foo":1,"bar":[7,8,9]},2,3,4,[5,6,7],true,null]
+(#<HASH-TABLE :TEST EQUAL :COUNT 2 {59942D21}> 2 3 4 (5 6 7) T NIL)
+ +

DOM encoder dictionary

+

[Generic function]
encode object &optional + stream + => + object

+ Encode object in JSON format and + write to stream. May be specialized + by applications to perform specific rendering. Stream + defaults to *STANDARD-OUTPUT*. +

+ +

[Function]
encode-alist object &optional (stream + *standard-output*) + => + object

+ Encodes object, an alist, in JSON + format and write to stream. +

+ +

[Function]
encode-plist object &optional (stream + *standard-output*) + => + object

+ Encodes object, a plist, in JSON + format and write to stream. +

+ +

[Function]
make-json-output-stream stream &key (indent t) + => + stream

+ Creates a json-output-stream instance + that wraps the supplied stream and + optionally performs indentation of the generated JSON + data. The indent argument is + described in WITH-OUTPUT. Note that + if the indent argument is NIL, the + original stream is returned in order to avoid the + performance penalty of the indentation algorithm. +

+ +

+ [Special variable]
*list-encoder*

+ Function to call to translate a CL list into JSON data. + 'YASON:ENCODE-PLAIN-LIST-TO-ARRAY is the default; + 'YASON:ENCODE-PLIST and + 'YASON:ENCODE-ALIST are available to produce + JSON objects. +

+ This is useful to translate a deeply recursive structure in a single + YASON:ENCODE call. +

+

+ + +

+ [Special variable]
*symbol-key-encoder*

+ Defines the policy to encode symbols as keys (eg. in hash tables). + The default is to error out, to provide backwards-compatible behaviour. +

+ A useful function that can be bound to this variable is + YASON:ENCODE-SYMBOL-AS-LOWERCASE. +

+

+ + + +

Encoding JSON in streaming mode

+

+ In this mode, the JSON structure is generated in a stream. + The application makes explicit calls to the encoding library + in order to generate the JSON structure. It provides for more + control over the generated output, and can be used to generate + arbitary JSON without requiring that there exists a directly + matching Lisp data structure. The streaming API uses the + encode function, so it is possible to + intermix the two (see app-encoders for an + example). +

+ For example: + 
CL-USER> (yason:with-output (*standard-output*)
+           (yason:with-array ()
+             (dotimes (i 3)
+               (yason:encode-array-element i))))
+[0,1,2]
+NIL
+CL-USER> (yason:with-output (*standard-output*)
+           (yason:with-object ()
+             (yason:encode-object-element "hello" "hu hu")
+             (yason:with-object-element ("harr")
+               (yason:with-array ()
+                 (dotimes (i 3)
+                   (yason:encode-array-element i))))))
+{"hello":"hu hu","harr":[0,1,2]}
+NIL
+ +

Streaming encoder dictionary

+

[Macro]
with-output (stream &key indent) &body body + => + result*

+ Set up a JSON streaming encoder context on + stream, then evaluate + body. indent + can be set to T to enable indentation with a default + indentation width or to an integer specifying the desired + indentation width. By default, indentation is switched + off. +

+ +

[Macro]
with-output-to-string* (&key indent stream-symbol) &body body + => + result*

+ Set up a JSON streaming encoder context on + stream-symbol (by default + a gensym), then evaluate + body. Return a string with the + generated JSON output. See + WITH-OUTPUT for the description of + the indent keyword argument. +

+ +

+ [Condition type]
no-json-output-context

+ This condition is signalled when one of the stream + encoding functions is used outside the dynamic context of + a WITH-OUTPUT or + WITH-OUTPUT-TO-STRING* body. +

+ +

[Macro]
with-array () &body body + => + result*

+ Open a JSON array, then run body. + Inside the body, ENCODE-ARRAY-ELEMENT + must be called to encode elements to the opened array. + Must be called within an existing JSON encoder context + (see WITH-OUTPUT and + WITH-OUTPUT-TO-STRING*). +

+ +

[Function]
encode-array-element object + => + object

+ Encode object as next array element to + the last JSON array opened + with WITH-ARRAY in the dynamic + context. object is encoded using the + ENCODE generic function, so it must be of + a type for which an ENCODE method is + defined. +

+ +

[Function]
encode-array-elements &rest objects + => + result*

+ Encode objects, a series of JSON + encodable objects, as the next array elements in a JSON + array opened with + WITH-ARRAY. ENCODE-ARRAY-ELEMENTS + uses ENCODE-ARRAY-ELEMENT, which must + be applicable to each object in the list + (i.e. ENCODE must be defined for each + object type). Additionally, this must be called within a + valid stream context. +

+ +

[Macro]
with-object () &body body + => + result*

+ Open a JSON object, then run body. + Inside the body, + ENCODE-OBJECT-ELEMENT or + WITH-OBJECT-ELEMENT must be called to + encode elements to the object. Must be called within an + existing JSON encoder + WITH-OUTPUT and + WITH-OUTPUT-TO-STRING*. +

+ +

[Macro]
with-object-element (key) &body body + => + result*

+ Open a new encoding context to encode a JSON object + element. key is the key of the + element. The value will be whatever + body serializes to the current JSON + output context using one of the stream encoding functions. + This can be used to stream out nested object structures. +

+ +

[Function]
encode-object-element key value + => + value

+ Encode key and + value as object element to the last + JSON object opened with WITH-OBJECT + in the dynamic context. key and + value are encoded using the + ENCODE generic function, so they both + must be of a type for which an ENCODE + method is defined. +

+ +

[Function]
encode-object-elements &rest elements + => + result*

+ Encodes the parameters into JSON in the last object opened + with WITH-OBJECT using + ENCODE-OBJECT-ELEMENT. The parameters + should consist of alternating key/value pairs, and this + must be called within a valid stream context. +

+ +

[Function]
encode-object-slots object slots + => + result*

+ Encodes each slot in SLOTS for OBJECT in the last object + opened with WITH-OBJECT using + ENCODE-OBJECT-ELEMENT. The key is the + slot name, and the value is the slot value for the slot on + OBJECT. It is equivalent to + 
(loop for slot in slots
+    do (encode-object-element (string slot)
+                              (slot-value object slot)))
+
+

+ +

[Function]
encode-slots object + => + result*

+ Generic function to encode object slots. There is no default + implementation. + It should be called in an object encoding context. It uses + PROGN combinatation with MOST-SPECIFIC-LAST order, so that + base class slots are encoded before derived class slots. +

+ +

[Function]
encode-object object + => + result*

+ Generic function to encode an object. The default implementation + opens a new object encoding context and calls + ENCODE-SLOTS on the argument. +

+ +

+ [Standard class]
json-output-stream

+ Instances of this class are used to wrap an output stream + that is used as a serialization target in the stream + encoder and optionally in the DOM encoder if indentation + is desired. The class name is not exported, use + make-json-output-stream to create a + wrapper stream if required. +

+ + + +

Application specific encoders

+ + Suppose your application uses structs to represent its data and + you want to encode these structs using JSON in order to send + them to a client application. Suppose further that your structs + also include internal information that you do not want to send. + Here is some code that illustrates how one could implement a + serialization function: + + 
CL-USER> (defstruct user name age password)
+USER
+CL-USER> (defmethod yason:encode ((user user) &optional (stream *standard-output*))
+           (yason:with-output (stream)
+             (yason:with-object ()
+               (yason:encode-object-element "name" (user-name user))
+               (yason:encode-object-element "age" (user-age user)))))
+#<STANDARD-METHOD YASON:ENCODE (USER) {5B40A591}>
+CL-USER> (yason:encode (list (make-user :name "horst" :age 27 :password "puppy")
+                            (make-user :name "uschi" :age 28 :password "kitten")))
+[{"name":"horst","age":27},{"name":"uschi","age":28}]
+(#S(USER :NAME "horst" :AGE 27 :PASSWORD "puppy")
+ #S(USER :NAME "uschi" :AGE 28 :PASSWORD "kitten"))
+ + As you can see, the streaming API and the DOM encoder can be + used together. ENCODE invokes itself + recursively, so any application defined method will be called + while encoding in-memory objects as appropriate. + +

For an example of the interplay between + ENCODE-OBJECT and + ENCODE-SLOTS, suppose you have the following + CLOS class heirarchy: + + 

(defclass shape ()
+  ((color :reader color)))
+
+(defclass square (shape)
+  ((side-length :reader side-length)))
+
+(defclass circle (shape)
+  ((radius :reader radius)))
+ + In order to implement encoding of circles and squares without + duplicating code you can specialize + ENCODE-SLOTS for all three classes + + 
(defmethod yason:encode-slots progn ((shape shape))
+  (yason:encode-object-element "color" (color shape)))
+
+(defmethod yason:encode-slots progn ((square square))
+  (yason:encode-object-element "side-length" (side-length square)))
+
+(defmethod yason:encode-slots progn ((circle circle))
+  (yason:encode-object-element "radius" (radius circle)))
+ + and then use ENCODE-OBJECT: + + 
CL-USER> (yason:with-output-to-string* ()
+           (yason:encode-object (make-instance 'square :color "red" :side-length 3)))
+"{\"color\":\"red\",\"side-length\":3}"
+CL-USER> (yason:with-output-to-string* ()
+           (yason:encode-object (make-instance 'circle :color "blue" :side-length 5)))
+"{\"color\":\"blue\",\"radius\":5}"
+

+

Alternatively, you can use the shortcut ENCODE-OBJECT-SLOTS + if you want the keys to be the slot names. For example: + 

(defclass person ()
+  ((name :reader name :initarg :name)
+   (address :reader address :initarg :address)
+   (phone-number :reader phone-number :initarg :phone)
+   (favorite-color :reader favorite-color :initarg :color)))
+
+(defmethod yason:encode-slots progn ((person person))
+  (yason:encode-object-slots person '(name address phone-number favorite-color)))
+ and then: + + 
CL-USER> (yason:with-output-to-string* ()
+       (yason:encode-object (make-instance 'person :name "John Doe"
+                                                   :address "123 Main St."
+                                                   :phone "(123)-456-7890"
+                                                   :color "blue")))
+"{\"NAME\":\"John Doe\",\"ADDRESS\":\"123 Main St.\",\"PHONE-NUMBER\":\"(123)-456-7890\",
+\"FAVORITE-COLOR\":\"blue\"}"
+

+ + + +

Symbol index

+ + + +

License

+ 
Copyright (c) 2008-2014 Hans Hübner and contributors
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+  - Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+  - Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution.
+
+  - Neither the name BKNR nor the names of its contributors may be
+    used to endorse or promote products derived from this software
+    without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+ + +

Acknowledgements

+ Thanks go to Edi Weitz for being a great inspiration. This + documentation as been generated with a hacked-up version of his DOCUMENTATION-TEMPLATE + software. Thanks to David Lichteblau for coining YASON's name. + + + diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/package.lisp b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/package.lisp new file mode 100644 index 0000000..0140304 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/package.lisp @@ -0,0 +1,50 @@ +;; This file is part of yason, a Common Lisp JSON parser/encoder +;; +;; Copyright (c) 2008-2019 Hans Huebner and contributors +;; All rights reserved. +;; +;; Please see the file LICENSE in the distribution. + +(defpackage :yason + + (:use :cl) + + (:export + ;; Parser + #:parse + #:*parse-object-key-fn* + #:*parse-object-as* + #:*parse-object-as-alist* ; deprecated + #:*parse-json-arrays-as-vectors* + #:*parse-json-booleans-as-symbols* + #:*parse-json-null-as-keyword* + + #:true + #:false + #:null + + ;; Basic encoder interface + #:encode + #:encode-slots + #:encode-object + #:encode-plist + #:encode-alist + #:encode-plain-list-to-array + #:*list-encoder* + #:*symbol-key-encoder* + #:encode-symbol-as-lowercase + + #:make-json-output-stream + + ;; Streaming encoder interface + #:with-output + #:with-output-to-string* + #:no-json-output-context + #:with-array + #:encode-array-element + #:encode-array-elements + #:with-object + #:encode-object-element + #:encode-object-elements + #:encode-object-slots + #:with-object-element)) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/parse.lisp b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/parse.lisp new file mode 100644 index 0000000..b7542bc --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/parse.lisp @@ -0,0 +1,258 @@ +;; This file is part of yason, a Common Lisp JSON parser/encoder +;; +;; Copyright (c) 2008-2014 Hans Huebner and contributors +;; All rights reserved. +;; +;; Please see the file LICENSE in the distribution. + +(in-package :yason) + +(defconstant +default-string-length+ 20 + "Default length of strings that are created while reading json input.") + +(defvar *parse-object-key-fn* #'identity + "Function to call to convert a key string in a JSON array to a key + in the CL hash produced.") + +(defvar *parse-json-arrays-as-vectors* nil + "If set to a true value, JSON arrays will be parsed as vectors, not + as lists.") + +(defvar *parse-json-booleans-as-symbols* nil + "If set to a true value, JSON booleans will be read as the symbols + TRUE and FALSE, not as T and NIL, respectively.") + +(defvar *parse-json-null-as-keyword* nil + "If set to a true value, JSON nulls will be read as the keyword :NULL, not as NIL.") + +(defvar *parse-object-as* :hash-table + "Set to either :hash-table, :plist or :alist to determine the data + structure that objects are parsed to.") + +(defvar *parse-object-as-alist* nil + "DEPRECATED, provided for backward compatibility") + +(defun make-adjustable-string () + "Return an adjustable empty string, usable as a buffer for parsing strings and numbers." + (make-array +default-string-length+ + :adjustable t :fill-pointer 0 :element-type 'character)) + +(defun parse-number (input) + ;; would be + ;; (cl-ppcre:scan-to-strings "^-?(?:0|[1-9][0-9]*)(?:\\.[0-9]+|)(?:[eE][-+]?[0-9]+|)" buffer) + ;; but we want to operate on streams + (let ((buffer (make-adjustable-string))) + (loop while (position (peek-char nil input nil) ".0123456789+-Ee") + do (vector-push-extend (read-char input) buffer)) + (values (read-from-string buffer)))) + +(defun parse-unicode-escape (input) + (let ((char-code (let ((buffer (make-string 4))) + (read-sequence buffer input) + (parse-integer buffer :radix 16)))) + (if (and (>= char-code #xd800) + (<= char-code #xdbff)) + (let ((buffer (make-string 6))) + (read-sequence buffer input) + (when (not (string= buffer "\\u" :end1 2)) + (error "Lead Surrogate without Tail Surrogate")) + (let ((tail-code (parse-integer buffer :radix 16 :start 2))) + (when (not (and (>= tail-code #xdc00) + (<= tail-code #xdfff))) + (error "Lead Surrogate without Tail Surrogate")) + (code-char (+ #x010000 + (ash (- char-code #xd800) 10) + (- tail-code #xdc00))))) + (code-char char-code)))) + +(defun parse-string (input) + (let ((output (make-adjustable-string))) + (labels ((outc (c) + (vector-push-extend c output)) + (next () + (read-char input)) + (peek () + (peek-char nil input))) + (let* ((starting-symbol (next)) + (string-quoted (equal starting-symbol #\"))) + (unless string-quoted + (outc starting-symbol)) + (loop + (cond + ((eql (peek) #\") + (next) + (return-from parse-string output)) + ((eql (peek) #\\) + (next) + (ecase (next) + (#\" (outc #\")) + (#\\ (outc #\\)) + (#\/ (outc #\/)) + (#\b (outc #\Backspace)) + (#\f (outc #\Page)) + (#\n (outc #\Newline)) + (#\r (outc #\Return)) + (#\t (outc #\Tab)) + (#\u (outc (parse-unicode-escape input))))) + ((and (or (whitespace-p (peek)) + (eql (peek) #\:)) + (not string-quoted)) + (return-from parse-string output)) + (t + (outc (next))))))))) + +(defun whitespace-p (char) + (member char '(#\Space #\Newline #\Tab #\Linefeed #\Return))) + +(defun skip-whitespace (input) + (loop for c = (peek-char nil input nil nil) + while (and c (whitespace-p c)) + do (read-char input))) + +(defun peek-char-skipping-whitespace (input &optional (eof-error-p t)) + (skip-whitespace input) + (peek-char nil input eof-error-p)) + +(defun parse-constant (input) + (destructuring-bind (expected-string return-value) + (find (peek-char nil input nil) + `(("true" ,(if *parse-json-booleans-as-symbols* 'true t)) + ("false" ,(if *parse-json-booleans-as-symbols* 'false nil)) + ("null" ,(if *parse-json-null-as-keyword* :null nil))) + :key (lambda (entry) (aref (car entry) 0)) + :test #'eql) + (loop for char across expected-string + unless (eql (read-char input nil) char) + do (error "invalid constant")) + return-value)) + +(define-condition cannot-convert-key (error) + ((key-string :initarg :key-string + :reader key-string)) + (:report (lambda (c stream) + (format stream "cannot convert key ~S used in JSON object to hash table key" + (key-string c))))) + +(defun create-container () + (ecase *parse-object-as* + ((:plist :alist) + nil) + (:hash-table + (make-hash-table :test #'equal)))) + +(defun add-attribute (to key value) + (ecase *parse-object-as* + (:plist + (append to (list key value))) + (:alist + (acons key value to)) + (:hash-table + (setf (gethash key to) value) + to))) + +(define-condition expected-colon (error) + ((key-string :initarg :key-string + :reader key-string)) + (:report (lambda (c stream) + (format stream "expected colon to follow key ~S used in JSON object" + (key-string c))))) + +(defun parse-object (input) + (let ((return-value (create-container))) + (read-char input) + (loop + (when (eql (peek-char-skipping-whitespace input) + #\}) + (return)) + (skip-whitespace input) + (setf return-value + (add-attribute return-value + (let ((key-string (parse-string input))) + (prog1 + (or (funcall *parse-object-key-fn* key-string) + (error 'cannot-convert-key :key-string key-string)) + (skip-whitespace input) + (unless (eql #\: (read-char input)) + (error 'expected-colon :key-string key-string)) + (skip-whitespace input))) + (parse input))) + (ecase (peek-char-skipping-whitespace input) + (#\, (read-char input)) + (#\} nil))) + (read-char input) + return-value)) + +(defconstant +initial-array-size+ 20 + "Initial size of JSON arrays read, they will grow as needed.") + +(defun %parse-array (input add-element-function) + "Parse JSON array from input, calling ADD-ELEMENT-FUNCTION for each array element parsed." + (read-char input) + (loop + (when (eql (peek-char-skipping-whitespace input) + #\]) + (return)) + (funcall add-element-function (parse input)) + (ecase (peek-char-skipping-whitespace input) + (#\, (read-char input)) + (#\] nil))) + (read-char input)) + +(defun parse-array (input) + (if *parse-json-arrays-as-vectors* + (let ((return-value (make-array +initial-array-size+ :adjustable t :fill-pointer 0))) + (%parse-array input + (lambda (element) + (vector-push-extend element return-value))) + return-value) + (let (return-value) + (%parse-array input + (lambda (element) + (push element return-value))) + (nreverse return-value)))) + +(defgeneric parse% (input) + (:method ((input stream)) + ;; backward compatibility code + (assert (or (not *parse-object-as-alist*) + (eq *parse-object-as* :hash-table)) + () "unexpected combination of *parse-object-as* and *parse-object-as-alist*, please use *parse-object-as* exclusively") + (let ((*parse-object-as* (if *parse-object-as-alist* + :alist + *parse-object-as*))) + ;; end of backward compatibility code + (check-type *parse-object-as* (member :hash-table :alist :plist)) + (ecase (peek-char-skipping-whitespace input) + (#\" + (parse-string input)) + ((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (parse-number input)) + (#\{ + (parse-object input)) + (#\[ + (parse-array input)) + ((#\t #\f #\n) + (parse-constant input))))) + (:method ((input pathname)) + (with-open-file (stream input) + (parse stream))) + (:method ((input string)) + (parse (make-string-input-stream input)))) + +(defun parse (input + &key + (object-key-fn *parse-object-key-fn*) + (object-as *parse-object-as*) + (json-arrays-as-vectors *parse-json-arrays-as-vectors*) + (json-booleans-as-symbols *parse-json-booleans-as-symbols*) + (json-nulls-as-keyword *parse-json-null-as-keyword*)) + "Parse INPUT, which needs to be a string or a stream, as JSON. + Returns the lisp representation of the JSON structure parsed. The + keyword arguments can be used to override the parser settings as + defined by the respective special variables." + (let ((*parse-object-key-fn* object-key-fn) + (*parse-object-as* object-as) + (*parse-json-arrays-as-vectors* json-arrays-as-vectors) + (*parse-json-booleans-as-symbols* json-booleans-as-symbols) + (*parse-json-null-as-keyword* json-nulls-as-keyword)) + (parse% input))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/render-doc.sh b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/render-doc.sh new file mode 100644 index 0000000..07fb104 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/render-doc.sh @@ -0,0 +1,5 @@ +#!/bin/sh + +xmllint --noout doc.xml +[ -f clixdoc.xsl ] || wget -q https://raw.github.com/hanshuebner/clixdoc/master/clixdoc.xsl +xsltproc --stringparam current-release `perl -ne 'if (/^ *:version +"(.*)"/) { print "$1\n" }' yason.asd` -o index.html clixdoc.xsl doc.xml diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/test.lisp b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/test.lisp new file mode 100644 index 0000000..7001609 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/test.lisp @@ -0,0 +1,116 @@ +(defpackage :yason-test + (:use :cl :unit-test)) + +(in-package :yason-test) + +(defparameter *basic-test-json-string* "[{\"foo\":1,\"bar\":[7,8,9]},2,3,4,[5,6,7],true,null]") +(defparameter *basic-test-json-string-indented* " +[ + {\"foo\":1, + \"bar\":[7,8,9] + }, + 2, 3, 4, [5, 6, 7], true, null +]") +(defparameter *basic-test-json-dom* (list (alexandria:plist-hash-table + '("foo" 1 "bar" (7 8 9)) + :test #'equal) + 2 3 4 + '(5 6 7) + t nil)) + + +(deftest :yason "parser.basic" + (let ((result (yason:parse *basic-test-json-string*))) + (test-equal (first *basic-test-json-dom*) (first result) :test #'equalp) + (test-equal (rest *basic-test-json-dom*) (rest result)))) + +(deftest :yason "parser.basic-with-whitespace" + (let ((result (yason:parse *basic-test-json-string-indented*))) + (test-equal (first *basic-test-json-dom*) (first result) :test #'equalp) + (test-equal (rest *basic-test-json-dom*) (rest result)))) + +(deftest :yason "dom-encoder.basic" + (let ((result (yason:parse + (with-output-to-string (s) + (yason:encode *basic-test-json-dom* s))))) + (test-equal (first *basic-test-json-dom*) (first result) :test #'equalp) + (test-equal (rest *basic-test-json-dom*) (rest result)))) + +(defun whitespace-char-p (char) + (member char '(#\space #\tab #\return #\newline #\linefeed))) + +(deftest :yason "dom-encoder.indentation" + (test-equal "[ + 1, + 2, + 3 +]" + (with-output-to-string (s) + (yason:encode '(1 2 3) (yason:make-json-output-stream s :indent 10)))) + (dolist (indentation-arg '(nil t 2 20)) + (test-equal "[1,2,3]" (remove-if #'whitespace-char-p + (with-output-to-string (s) + (yason:encode '(1 2 3) + (yason:make-json-output-stream s :indent indentation-arg))))))) + +(deftest :yason "stream-encoder.basic-array" + (test-equal "[0,1,2]" + (with-output-to-string (s) + (yason:with-output (s) + (yason:with-array () + (dotimes (i 3) + (yason:encode-array-element i))))))) + +(deftest :yason "stream-encoder.basic-object" + (test-equal "{\"hello\":\"hu hu\",\"harr\":[0,1,2]}" + (with-output-to-string (s) + (yason:with-output (s) + (yason:with-object () + (yason:encode-object-element "hello" "hu hu") + (yason:with-object-element ("harr") + (yason:with-array () + (dotimes (i 3) + (yason:encode-array-element i))))))))) + +(deftest :yason "stream-encode.unicode-string" + (test-equal "\"ab\\u0002 cde \\uD834\\uDD1E\"" + (with-output-to-string (s) + (yason:encode (format nil "ab~C cde ~C" (code-char #x02) (code-char #x1d11e)) s)))) + +(defstruct user name age password) + +(defmethod yason:encode ((user user) &optional (stream *standard-output*)) + (yason:with-output (stream) + (yason:with-object () + (yason:encode-object-element "name" (user-name user)) + (yason:encode-object-element "age" (user-age user))))) + +(deftest :yason "stream-encoder.application-struct" + (test-equal "[{\"name\":\"horst\",\"age\":27},{\"name\":\"uschi\",\"age\":28}]" + (with-output-to-string (s) + (yason:encode (list (make-user :name "horst" :age 27 :password "puppy") + (make-user :name "uschi" :age 28 :password "kitten")) + s)))) + +(deftest :yason "recursive-alist-encode" + (test-equal "{\"a\":3,\"b\":[1,2,{\"c\":4,\"d\":[6]}]}" + (yason:with-output-to-string* (:stream-symbol s) + (let ((yason:*list-encoder* #'yason:encode-alist)) + (yason:encode + `(("a" . 3) ("b" . #(1 2 (("c" . 4) ("d" . #(6)))))) + s))))) + +(deftest :yason "symbols-as-keys" + (test-condition + (yason:with-output-to-string* (:stream-symbol s) + (let ((yason:*symbol-key-encoder* #'yason:encode-symbol-as-lowercase)) + (yason:encode-alist + `((:|abC| . 3)) + s))) + 'error) + (test-equal "{\"a\":3}" + (yason:with-output-to-string* (:stream-symbol s) + (let ((yason:*symbol-key-encoder* #'yason:encode-symbol-as-lowercase)) + (yason:encode-alist + `((:a . 3)) + s))))) diff --git a/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/yason.asd b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/yason.asd new file mode 100644 index 0000000..5609413 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/software/yason-v0.7.8/yason.asd @@ -0,0 +1,33 @@ +;;;; -*- Mode: Lisp -*- + +;; This file is part of yason, a Common Lisp JSON parser/encoder +;; +;; Copyright (c) 2008-2014 Hans Huebner and contributors +;; All rights reserved. +;; +;; Please see the file LICENSE in the distribution. + +(in-package :cl-user) + +(defpackage :yason.system + (:use :cl :asdf)) + +(in-package :yason.system) + +(defsystem :yason + :name "YASON" + :author "Hans Huebner " + :version "0.7.6" + :maintainer "Hans Huebner " + :licence "BSD" + :description "JSON parser/encoder" + :long-description "YASON is a Common Lisp library for encoding and + decoding data in the JSON interchange format. JSON is used as a + lightweight alternative to XML. YASON has the sole purpose of + encoding and decoding data and does not impose any object model on + the Common Lisp application that uses it." + + :depends-on (:alexandria :trivial-gray-streams) + :components ((:file "package") + (:file "encode" :depends-on ("package")) + (:file "parse" :depends-on ("package")))) diff --git a/sbcl/.quicklisp/dists/quicklisp/systems.cdb b/sbcl/.quicklisp/dists/quicklisp/systems.cdb new file mode 100644 index 0000000..49191e1 Binary files /dev/null and b/sbcl/.quicklisp/dists/quicklisp/systems.cdb differ diff --git a/sbcl/.quicklisp/dists/quicklisp/systems.txt b/sbcl/.quicklisp/dists/quicklisp/systems.txt new file mode 100644 index 0000000..67d31c2 --- /dev/null +++ b/sbcl/.quicklisp/dists/quicklisp/systems.txt @@ -0,0 +1,4335 @@ +# project system-file system-name [dependency1..dependencyN] +1am 1am 1am +3b-bmfont 3b-bmfont 3b-bmfont alexandria asdf split-sequence +3b-bmfont 3b-bmfont 3b-bmfont/common alexandria split-sequence +3b-bmfont 3b-bmfont 3b-bmfont/json alexandria jsown split-sequence +3b-bmfont 3b-bmfont 3b-bmfont/text alexandria split-sequence +3b-bmfont 3b-bmfont 3b-bmfont/xml alexandria cxml flexi-streams split-sequence +3b-swf 3b-swf 3b-swf alexandria chipz cl-jpeg cxml flexi-streams ieee-floats salza2 vecto zpng +3b-swf 3b-swf-swc 3b-swf-swc 3b-swf cxml zip +3bgl-shader 3bgl-shader 3bgl-shader alexandria asdf bordeaux-threads cl-opengl +3bgl-shader 3bgl-shader-example 3bgl-shader-example 3bgl-shader asdf cl-glu cl-glut mathkit +3bmd 3bmd 3bmd alexandria esrap split-sequence +3bmd 3bmd-ext-code-blocks 3bmd-ext-code-blocks 3bmd alexandria colorize +3bmd 3bmd-ext-definition-lists 3bmd-ext-definition-lists 3bmd alexandria colorize +3bmd 3bmd-ext-tables 3bmd-ext-tables 3bmd +3bmd 3bmd-ext-wiki-links 3bmd-ext-wiki-links 3bmd +3bmd 3bmd-youtube 3bmd-youtube 3bmd esrap +3bmd 3bmd-youtube-tests 3bmd-youtube-tests 3bmd-youtube fiasco +3bz 3bz 3bz alexandria asdf cffi mmap nibbles +3d-matrices 3d-matrices 3d-matrices 3d-vectors asdf documentation-utils +3d-matrices 3d-matrices-test 3d-matrices-test 3d-matrices asdf parachute +3d-vectors 3d-vectors 3d-vectors asdf documentation-utils +3d-vectors 3d-vectors-test 3d-vectors-test 3d-vectors asdf parachute +a-cl-logger a-cl-logger a-cl-logger alexandria asdf cl-interpol cl-json closer-mop iterate local-time osicat symbol-munger +a-cl-logger a-cl-logger-logstash a-cl-logger-logstash a-cl-logger asdf cl-json zmq +a-cl-logger a-cl-logger a-cl-logger-tests a-cl-logger lisp-unit2 +able able able cl-fad ltk trivial-gray-streams +access access access alexandria anaphora cl-interpol closer-mop iterate +access access access-test access lisp-unit2 +acclimation acclimation acclimation asdf +acclimation acclimation-temperature acclimation-temperature asdf +adopt adopt adopt asdf bobbin split-sequence +adopt adopt adopt/test 1am adopt +advanced-readtable advanced-readtable advanced-readtable named-readtables +adw-charting adw-charting adw-charting iterate +adw-charting adw-charting-google adw-charting-google adw-charting drakma +adw-charting adw-charting-vecto adw-charting-vecto adw-charting vecto +agnostic-lizard agnostic-lizard agnostic-lizard asdf +agnostic-lizard agnostic-lizard-debugger-prototype agnostic-lizard-debugger-prototype agnostic-lizard asdf bordeaux-threads +agutil agutil agutil alexandria asdf trivia +ahungry-fleece ahungry-fleece ahungry-fleece archive asdf chipz cl-json cl-yaml md5 split-sequence +ahungry-fleece skeleton skeleton ahungry-fleece asdf +alexa alexa alexa alexandria asdf cl-ppcre +alexa alexa-tests alexa-tests alexa asdf fiasco uiop +alexandria alexandria alexandria asdf +alexandria alexandria-tests alexandria-tests alexandria asdf +algebraic-data-library algebraic-data-library algebraic-data-library asdf cl-algebraic-data-type +also-alsa also-alsa also-alsa asdf cffi +amazon-ecs amazon-ecs amazon-ecs alexandria bordeaux-threads cl-ppcre drakma hunchentoot ironclad net-telent-date parse-number trivial-http xml-mop +anaphora anaphora anaphora asdf +anaphora anaphora anaphora/test anaphora rt +anaphoric-variants anaphoric-variants anaphoric-variants map-bind +antik antik antik asdf gsll physical-dimension +antik antik-base antik-base alexandria asdf cl-ppcre iterate lisp-unit metabang-bind named-readtables split-sequence +antik foreign-array foreign-array antik-base asdf cffi cffi-grovel static-vectors trivial-garbage +antik physical-dimension physical-dimension asdf fare-utils foreign-array trivial-utf-8 +antik science-data science-data asdf drakma physical-dimension +apply-argv apply-argv apply-argv alexandria +apply-argv apply-argv apply-argv-tests apply-argv fiveam +april aplesque aplesque alexandria array-operations asdf parse-number symbol-munger +april april april alexandria aplesque array-operations asdf cl-ppcre decimals parse-number prove simple-date-time symbol-munger vex +april vex vex alexandria array-operations asdf cl-ppcre maxpc prove symbol-munger +arc-compat arc-compat arc-compat asdf babel bordeaux-threads cl-fad fiveam ironclad named-readtables +architecture.builder-protocol architecture.builder-protocol architecture.builder-protocol alexandria asdf +architecture.builder-protocol architecture.builder-protocol.json architecture.builder-protocol.json alexandria architecture.builder-protocol asdf cl-json +architecture.builder-protocol architecture.builder-protocol.json architecture.builder-protocol.json/test alexandria architecture.builder-protocol architecture.builder-protocol.json fiveam +architecture.builder-protocol architecture.builder-protocol.universal-builder architecture.builder-protocol.universal-builder alexandria architecture.builder-protocol asdf closer-mop +architecture.builder-protocol architecture.builder-protocol.universal-builder architecture.builder-protocol.universal-builder/test alexandria architecture.builder-protocol architecture.builder-protocol.universal-builder fiveam +architecture.builder-protocol architecture.builder-protocol.xpath architecture.builder-protocol.xpath alexandria architecture.builder-protocol asdf xpath +architecture.builder-protocol architecture.builder-protocol.xpath architecture.builder-protocol.xpath/test alexandria architecture.builder-protocol.xpath fiveam +architecture.builder-protocol architecture.builder-protocol architecture.builder-protocol/test alexandria architecture.builder-protocol fiveam +architecture.hooks cl-hooks cl-hooks alexandria asdf closer-mop let-plus trivial-garbage +architecture.hooks cl-hooks cl-hooks/test cl-hooks fiveam +architecture.service-provider architecture.service-provider architecture.service-provider alexandria asdf let-plus more-conditions utilities.print-items +architecture.service-provider architecture.service-provider-and-hooks architecture.service-provider-and-hooks architecture.service-provider asdf cl-hooks +architecture.service-provider architecture.service-provider-and-hooks architecture.service-provider-and-hooks/test alexandria architecture.service-provider architecture.service-provider-and-hooks fiveam let-plus more-conditions +architecture.service-provider architecture.service-provider architecture.service-provider/test alexandria architecture.service-provider fiveam let-plus more-conditions +archive archive archive cl-fad trivial-gray-streams +arnesi arnesi arnesi collectors +arnesi arnesi arnesi/cl-ppcre-extras arnesi cl-ppcre +arnesi arnesi arnesi/slime-extras arnesi swank +array-operations array-operations array-operations asdf let-plus +array-operations array-operations array-operations/tests alexandria array-operations clunit +array-utils array-utils array-utils asdf +array-utils array-utils-test array-utils-test array-utils asdf parachute +arrival arrival arrival alexandria asdf iterate log4cl trivia trivia.quasiquote +arrow-macros arrow-macros arrow-macros hu.dwim.walker +arrow-macros arrow-macros-test arrow-macros-test arrow-macros fiveam +arrows arrows arrows asdf +arrows arrows arrows/test arrows hu.dwim.stefil +asd-generator asd-generator asd-generator alexandria asdf cl-fad iterate trivia +asd-generator asd-generator-test asd-generator-test alexandria asdf cl-fad iterate +asdf-dependency-grovel asdf-dependency-grovel asdf-dependency-grovel asdf +asdf-dependency-grovel test-serial-system test-serial-system +asdf-encodings asdf-encodings asdf-encodings asdf +asdf-encodings asdf-encodings asdf-encodings/test asdf-encodings fare-utils hu.dwim.stefil +asdf-finalizers asdf-finalizers asdf-finalizers asdf +asdf-finalizers asdf-finalizers-test asdf-finalizers-test asdf-finalizers fare-utils hu.dwim.stefil list-of +asdf-finalizers asdf-finalizers-test asdf-finalizers-test/1 asdf-finalizers fare-utils hu.dwim.stefil list-of +asdf-finalizers asdf-finalizers-test asdf-finalizers-test/2 asdf-finalizers fare-utils hu.dwim.stefil list-of +asdf-finalizers list-of list-of asdf-finalizers +asdf-flv net.didierverna.asdf-flv net.didierverna.asdf-flv +asdf-linguist asdf-linguist asdf-linguist asdf inferior-shell parenscript +asdf-manager asdf-manager asdf-manager trivial-download trivial-extract uiop +asdf-manager asdf-manager-test asdf-manager-test asdf-manager fiveam +asdf-package-system asdf-package-system asdf-package-system asdf +asdf-system-connections asdf-system-connections asdf-system-connections +asdf-viz asdf-viz asdf-viz asdf cl-dot closer-mop iterate swank trivia +aserve zaserve zaserve asdf zacl +assert-p assert-p assert-p asdf assertion-error simplet-asdf +assert-p assert-p assert-p/test assert-p simplet simplet-asdf +assertion-error assertion-error assertion-error asdf dissect +assertion-error assertion-error assertion-error/test assertion-error +assoc-utils assoc-utils assoc-utils asdf +assoc-utils assoc-utils-test assoc-utils-test asdf assoc-utils prove prove-asdf +asteroids asteroids asteroids asdf lispbuilder-sdl lispbuilder-sdl-gfx lispbuilder-sdl-mixer +async-process async-process async-process asdf cffi +atdoc atdoc atdoc cl-ppcre closer-mop cxml split-sequence swank xuriella +atdoc blocks-world blocks-world +atomics atomics atomics asdf documentation-utils +atomics atomics-test atomics-test asdf atomics parachute +authenticated-encryption authenticated-encryption authenticated-encryption asdf ironclad +authenticated-encryption authenticated-encryption-test authenticated-encryption-test 1am asdf authenticated-encryption +avatar-api avatar-api avatar-api cl-json crypto-shortcuts drakma +avatar-api avatar-api-test avatar-api-test avatar-api fiveam +aws-foundation aws-foundation aws-foundation asdf babel cl-json cl-json-helper dexador ironclad local-time +aws-sign4 aws-sign4 aws-sign4 asdf cl-ppcre flexi-streams ironclad local-time secret-values split-sequence +aws-sign4 aws-sign4 aws-sign4-example aws-sign4 drakma +aws-sign4 aws-sign4 aws-sign4-tests aws-sign4 +ayah-captcha ayah-captcha ayah-captcha asdf cl-json drakma +ayah-captcha ayah-captcha-demo ayah-captcha-demo asdf ayah-captcha cl-who hunchentoot +babel babel babel alexandria asdf trivial-features +babel babel-streams babel-streams alexandria asdf babel trivial-gray-streams +babel babel-tests babel-tests asdf babel hu.dwim.stefil +base-blobs base-blobs base-blobs asdf bodge-blobs-support trivial-features +base64 base64 base64 asdf +basic-binary-ipc basic-binary-ipc basic-binary-ipc cffi-grovel +basic-binary-ipc basic-binary-ipc-tests basic-binary-ipc-tests basic-binary-ipc bordeaux-threads lisp-unit +bdef bdef bdef alexandria asdf eager-future2 parse-float split-sequence +bdef bdef bdef/cl-collider bdef cl-collider +bdef bdef bdef/cl-patterns bdef cl-patterns +beast beast beast asdf +beast beast-test beast-test 1am asdf beast +beirc beirc beirc cl-fad cl-irc cl-ppcre mcclim split-sequence +big-string big-string big-string asdf +bike bike bike alexandria asdf bike-internals bordeaux-threads cffi cl-ppcre flexi-streams split-sequence trivial-features trivial-garbage uiop +bike bike-examples bike-examples asdf bike +bike bike-internals bike-internals alexandria asdf bordeaux-threads cffi cl-ppcre flexi-streams split-sequence trivial-features trivial-garbage uiop +bike bike-tests bike-tests asdf bike fiveam +binary-io binary-io binary-io alexandria asdf ieee-floats +binary-io binary-io binary-io/test 1am binary-io +binary-types binary-types binary-types +binascii binascii binascii +binascii binascii binascii-tests binascii +binfix binfix binfix asdf +binfix binfix binfix/5am binfix fiveam +binomial-heap binomial-heap binomial-heap +binpack binpack binpack alexandria asdf +birch birch birch alexandria flexi-streams split-sequence usocket +birch birch.test birch.test birch flexi-streams prove +bit-ops bit-ops bit-ops alexandria asdf immutable-struct iterate lisp-namespace trivia +bit-ops bit-ops.test bit-ops.test asdf bit-ops fiveam +bit-smasher bit-smasher bit-smasher asdf cl-base58 cl-base64 +bitfield-schema bitfield-schema bitfield-schema iterate +bitio bitio bitio fast-io +bk-tree bk-tree bk-tree +bknr-datastore bknr.data.impex bknr.data.impex asdf bknr.datastore bknr.impex bknr.indices bknr.utils cl-interpol unit-test +bknr-datastore bknr.datastore bknr.datastore alexandria asdf bknr.indices bknr.utils cl-interpol closer-mop trivial-utf-8 unit-test yason +bknr-datastore bknr.impex bknr.impex asdf bknr.indices bknr.utils bknr.xml cl-interpol closer-mop cxml +bknr-datastore bknr.indices bknr.indices asdf bknr.skip-list bknr.utils cl-interpol closer-mop +bknr-datastore bknr.skip-list bknr.skip-list asdf +bknr-datastore bknr.skip-list bknr.skip-list.test bknr.skip-list unit-test +bknr-datastore bknr.utils bknr.utils alexandria asdf bordeaux-threads cl-interpol cl-ppcre flexi-streams md5 +bknr-datastore bknr.xml bknr.xml asdf cl-interpol cxml +bknr-web bknr.modules bknr.modules bknr.utils bknr.web cl-gd cl-interpol cl-ppcre cl-smtp closer-mop cxml md5 parenscript puri stem unit-test +bknr-web bknr.web bknr.web alexandria bknr.data.impex bknr.datastore bknr.utils bknr.xml cl-gd cl-interpol cl-ppcre cxml drakma hunchentoot md5 parenscript puri unit-test usocket xhtmlgen yason +bknr-web html-match html-match cl-ppcre unit-test +bknr-web html-match html-match.test html-match unit-test +bknr-web leech leech aserve unit-test +black-tie black-tie black-tie asdf +blackbird blackbird blackbird vom +blackbird blackbird-test blackbird-test blackbird cl-async fiveam +bobbin bobbin bobbin asdf split-sequence +bobbin bobbin bobbin/test 1am bobbin +bodge-blobs-support bodge-blobs-support bodge-blobs-support alexandria asdf cffi trivial-features uiop +bodge-chipmunk bodge-chipmunk bodge-chipmunk alexandria asdf cffi claw +bodge-glad bodge-glad bodge-glad alexandria asdf cffi +bodge-glfw bodge-glfw bodge-glfw alexandria asdf cffi claw +bodge-glfw bodge-glfw bodge-glfw/example bodge-glfw cl-opengl claw glfw-blob +bodge-nanovg bodge-nanovg bodge-nanovg alexandria asdf cffi claw uiop +bodge-nanovg bodge-nanovg bodge-nanovg/example bodge-glad bodge-glfw bodge-nanovg cl-opengl claw glad-blob glfw-blob nanovg-blob trivial-main-thread +bodge-nuklear bodge-nuklear bodge-nuklear alexandria asdf cffi claw +bodge-nuklear bodge-nuklear bodge-nuklear/example alexandria bodge-nuklear cffi cl-opengl claw clutz nuklear-blob +bodge-ode bodge-ode bodge-ode alexandria asdf cffi claw +bodge-ode bodge-ode bodge-ode/example bodge-ode claw ode-blob +bodge-openal bodge-openal bodge-openal alexandria asdf cffi claw +bodge-openal bodge-openal bodge-openal/example alexandria bodge-openal claw openal-blob static-vectors +bodge-sndfile bodge-sndfile bodge-sndfile alexandria asdf cffi claw static-vectors +bodge-sndfile bodge-sndfile bodge-sndfile/example bodge-sndfile sndfile-blob +bordeaux-fft bordeaux-fft bordeaux-fft +bordeaux-threads bordeaux-threads bordeaux-threads alexandria asdf +bordeaux-threads bordeaux-threads bordeaux-threads/test bordeaux-threads fiveam +bourbaki bourbaki bourbaki +bp bp bp asdf aserve cffi ironclad jsown +bp bp bp/tests bp fiveam +bst bst bst asdf +bst bst bst/test alexandria bst fiveam +bt-semaphore bt-semaphore bt-semaphore asdf bordeaux-threads +bt-semaphore bt-semaphore-test bt-semaphore-test asdf bt-semaphore clunit +btrie btrie btrie arnesi lift split-sequence +btrie btrie btrie-tests btrie lift metabang-bind +bubble-operator-upwards bubble-operator-upwards bubble-operator-upwards +buildapp buildapp buildapp +buildnode buildnode buildnode alexandria cl-interpol cl-ppcre closure-html collectors cxml flexi-streams iterate split-sequence swank symbol-munger +buildnode buildnode-excel buildnode-excel buildnode +buildnode buildnode-html5 buildnode-html5 buildnode +buildnode buildnode-kml buildnode-kml buildnode +buildnode buildnode buildnode-test buildnode buildnode-xhtml lisp-unit2 +buildnode buildnode-xhtml buildnode-xhtml buildnode +buildnode buildnode-xul buildnode-xul buildnode +burgled-batteries burgled-batteries burgled-batteries alexandria cffi cffi-grovel cl-fad parse-declarations-1.0 trivial-garbage +burgled-batteries burgled-batteries-tests burgled-batteries-tests burgled-batteries cl-quickcheck lift +burgled-batteries.syntax burgled-batteries.syntax burgled-batteries.syntax burgled-batteries esrap named-readtables +burgled-batteries.syntax burgled-batteries.syntax-test burgled-batteries.syntax-test burgled-batteries.syntax lift +bytecurry.asdf-ext bytecurry.asdf-ext bytecurry.asdf-ext asdf asdf-package-system +bytecurry.mocks bytecurry.mocks bytecurry.mocks asdf asdf-package-system bytecurry.asdf-ext +bytecurry.mocks bytecurry.mocks bytecurry.mocks/test bytecurry.mocks fiveam +cacau cacau cacau asdf assertion-error eventbus +cacau cacau-asdf cacau-asdf asdf +cacau cacau-examples-asdf-integration cacau-examples-asdf-integration asdf +cacau cacau-examples-asdf-integration-test cacau-examples-asdf-integration-test asdf assert-p cacau cacau-asdf cacau-examples-asdf-integration +cacau cacau-test cacau-test asdf assert-p cacau cacau-asdf +cacle cacle cacle asdf bordeaux-threads +calispel calispel calispel bordeaux-threads jpl-queues jpl-util +calispel calispel calispel-test calispel eager-future2 +cambl cambl cambl alexandria asdf cl-containers fprog local-time periods +cambl cambl-test cambl-test asdf cambl uiop xlunit +cambl fprog fprog asdf +can can can asdf +can can-test can-test alexandria asdf can mito prove prove-asdf +caramel caramel caramel alexandria buildnode closure-html css-selectors cxml cxml-dom iterate +cardiogram cardiogram cardiogram asdf +cari3s cari3s cari3s asdf cffi closer-mop documentation-utils drakma pango-markup usocket yason +carrier carrier carrier alexandria asdf babel blackbird cl-async cl-async-ssl cl-cookie fast-http fast-io quri +cartesian-product-switch cartesian-product-switch cartesian-product-switch map-bind +caveman caveman caveman anaphora asdf cl-emb cl-ppcre cl-project cl-syntax cl-syntax-annot clack-v1-compat do-urlencode local-time myway +caveman caveman-middleware-dbimanager caveman-middleware-dbimanager asdf clack-v1-compat dbi +caveman caveman-test caveman-test asdf caveman cl-test-more dexador uiop usocket +caveman caveman2 caveman2 asdf cl-project cl-syntax-annot dbi lack-request lack-response myway ningle quri +caveman caveman2-db caveman2-db asdf caveman-middleware-dbimanager dbi sxql +caveman caveman2-test caveman2-test asdf caveman2 dexador lack-component prove prove-asdf trivial-types uiop usocket +caveman2-widgets caveman2-widgets caveman2-widgets asdf caveman2 moptilities trivial-garbage +caveman2-widgets caveman2-widgets-test caveman2-widgets-test asdf caveman2-widgets prove prove-asdf +caveman2-widgets-bootstrap caveman2-widgets-bootstrap caveman2-widgets-bootstrap asdf caveman2 caveman2-widgets +caveman2-widgets-bootstrap caveman2-widgets-bootstrap-test caveman2-widgets-bootstrap-test asdf caveman2-widgets-bootstrap prove prove-asdf +ccl-compat ccl-compat ccl-compat alexandria bordeaux-threads closer-mop +ccldoc ccldoc ccldoc alexandria asdf ccl-compat cl-who s-xml split-sequence +ccldoc ccldoc-libraries ccldoc-libraries alexandria asdf s-xml split-sequence +cells cells cells asdf utils-kt +cells cells-test cells-test asdf cells +cepl cepl cepl alexandria asdf bordeaux-threads cepl.build cffi cl-opengl cl-ppcre documentation-utils ieee-floats split-sequence uiop varjo +cepl cepl.build cepl.build alexandria asdf +cepl.camera cepl.camera cepl.camera asdf cepl cepl.spaces rtg-math +cepl.devil cepl.devil cepl.devil asdf cepl cl-devil +cepl.drm-gbm cepl.drm-gbm cepl.drm-gbm asdf cepl cl-drm cl-egl cl-gbm osicat +cepl.glop cepl.glop cepl.glop asdf cepl glop +cepl.sdl2 cepl.sdl2 cepl.sdl2 asdf cepl sdl2 +cepl.sdl2-image cepl.sdl2-image cepl.sdl2-image asdf cepl sdl2 sdl2-image +cepl.sdl2-ttf cepl.sdl2-ttf cepl.sdl2-ttf asdf cepl.sdl2 rtg-math sdl2-ttf +cepl.skitter cepl.skitter.glop cepl.skitter.glop asdf cepl.glop skitter.glop +cepl.skitter cepl.skitter.sdl2 cepl.skitter.sdl2 asdf cepl.sdl2 skitter.sdl2 +cepl.spaces cepl.spaces cepl.spaces asdf cepl documentation-utils fn rtg-math rtg-math.vari varjo +ceramic ceramic ceramic asdf cl-json clack-handler-hunchentoot copy-directory electron-tools external-program remote-js trivial-build trivial-compress trivial-download trivial-exe trivial-extract uiop uuid +ceramic ceramic-hello-world ceramic-hello-world asdf ceramic lucerne +ceramic ceramic-test-app ceramic-test-app asdf ceramic drakma +cerberus cerberus cerberus alexandria asdf babel flexi-streams glass ironclad nibbles usocket +cerberus cerberus cerberus-kdc cerberus frpc pounds +cesdi cesdi cesdi asdf closer-mop +cesdi cesdi_tests cesdi_tests asdf cesdi parachute +cffi cffi cffi alexandria asdf babel trivial-features uiop +cffi cffi-examples cffi-examples asdf cffi +cffi cffi-grovel cffi-grovel alexandria asdf cffi cffi-toolchain +cffi cffi-libffi cffi-libffi asdf cffi cffi-grovel trivial-features +cffi cffi-tests cffi-tests asdf bordeaux-threads cffi-grovel cffi-libffi rt trivial-features +cffi cffi-tests cffi-tests/example cffi-grovel +cffi cffi-toolchain cffi-toolchain asdf cffi +cffi cffi-uffi-compat cffi-uffi-compat asdf cffi +cffi cffi cffi/c2ffi alexandria cffi +cffi cffi cffi/c2ffi-generator alexandria cffi cl-json cl-ppcre +chameleon chameleon chameleon alexandria asdf trivia +chameleon chameleon chameleon/tests chameleon rove +chancery chancery chancery asdf named-readtables +chancery chancery.test chancery.test 1am asdf chancery +changed-stream changed-stream changed-stream +changed-stream changed-stream.test changed-stream.test changed-stream +chanl chanl chanl asdf bordeaux-threads +chanl chanl chanl/examples chanl +chanl chanl chanl/tests chanl fiveam +cheat-js cheat-js cheat-js cl-uglify-js fiveam +check-it check-it check-it alexandria closer-mop optima +check-it check-it check-it-test check-it stefil +checkl checkl checkl asdf marshal +checkl checkl-docs checkl-docs asdf checkl cl-gendoc +checkl checkl-test checkl-test asdf checkl fiveam +chemical-compounds chemical-compounds chemical-compounds periodic-table +chillax chillax chillax chillax.core chillax.yason +chillax chillax.core chillax.core alexandria drakma flexi-streams +chillax chillax.jsown chillax.jsown chillax.core jsown +chillax chillax.view-server chillax.view-server alexandria yason +chillax chillax.yason chillax.yason chillax.core yason +chipmunk-blob chipmunk-blob chipmunk-blob asdf bodge-blobs-support trivial-features +chipz chipz chipz asdf +chirp chirp chirp asdf chirp-drakma +chirp chirp-core chirp-core alexandria asdf babel cl-base64 cl-ppcre flexi-streams ironclad local-time split-sequence uuid yason +chirp chirp-dexador chirp-dexador asdf chirp-core dexador +chirp chirp-drakma chirp-drakma asdf chirp-core drakma +chrome-native-messaging chrome-native-messaging chrome-native-messaging trivial-utf-8 +chronicity chronicity chronicity asdf cl-interpol cl-ppcre local-time +chronicity chronicity-test chronicity-test asdf chronicity lisp-unit +chtml-matcher chtml-matcher chtml-matcher cl-ppcre closure-html f-underscore stdutils +chunga chunga chunga asdf trivial-gray-streams +ci-utils ci-utils ci-utils asdf ci-utils-features +ci-utils ci-utils-features ci-utils-features asdf +ci-utils ci-utils ci-utils/coveralls ci-utils ci-utils-features split-sequence +ci-utils ci-utils ci-utils/test ci-utils ci-utils-features fiveam split-sequence +circular-streams circular-streams circular-streams fast-io trivial-gray-streams +circular-streams circular-streams-test circular-streams-test circular-streams cl-test-more flexi-streams +city-hash city-hash city-hash com.google.base nibbles swap-bytes +city-hash city-hash-test city-hash-test city-hash hu.dwim.stefil +cl+ssl cl+ssl cl+ssl alexandria asdf bordeaux-threads cffi flexi-streams trivial-features trivial-garbage trivial-gray-streams uiop +cl+ssl cl+ssl.test cl+ssl.test asdf cl+ssl cl-coveralls fiveam usocket +cl-6502 cl-6502 cl-6502 alexandria cl-ppcre +cl-6502 cl-6502 cl-6502-test cl-6502 fiveam +cl-abnf abnf abnf asdf cl-ppcre esrap +cl-abstract-classes abstract-classes abstract-classes asdf closer-mop +cl-abstract-classes singleton-classes singleton-classes asdf closer-mop +cl-acronyms cl-acronyms cl-acronyms alexandria split-sequence +cl-algebraic-data-type cl-algebraic-data-type cl-algebraic-data-type alexandria asdf global-vars +cl-all cl-all cl-all asdf +cl-amqp cl-amqp cl-amqp alexandria asdf cl-interpol collectors fast-io local-time log4cl nibbles trivial-utf-8 wu-decimal +cl-amqp cl-amqp.test cl-amqp.test asdf cl-amqp cl-interpol log4cl mw-equiv prove prove-asdf +cl-ana cl-ana cl-ana asdf cl-ana.binary-tree cl-ana.calculus cl-ana.clos-utils cl-ana.columnar-table cl-ana.csv-table cl-ana.error-propogation cl-ana.file-utils cl-ana.fitting cl-ana.generic-math cl-ana.hash-table-utils cl-ana.hdf-table cl-ana.histogram cl-ana.int-char cl-ana.linear-algebra cl-ana.lorentz cl-ana.makeres cl-ana.makeres-block cl-ana.makeres-branch cl-ana.makeres-graphviz cl-ana.makeres-macro cl-ana.makeres-progress cl-ana.makeres-table cl-ana.makeres-utils cl-ana.map cl-ana.math-functions cl-ana.ntuple-table cl-ana.package-utils cl-ana.pathname-utils cl-ana.plotting cl-ana.quantity cl-ana.reusable-table cl-ana.serialization cl-ana.statistical-learning cl-ana.statistics cl-ana.table cl-ana.table-utils cl-ana.table-viewing cl-ana.tensor +cl-ana cl-ana.binary-tree cl-ana.binary-tree asdf cl-ana.functional-utils cl-ana.list-utils cl-ana.macro-utils +cl-ana cl-ana.calculus cl-ana.calculus asdf cl-ana.generic-math +cl-ana cl-ana.clos-utils cl-ana.clos-utils asdf cl-ana.list-utils cl-ana.symbol-utils cl-ana.tensor closer-mop +cl-ana cl-ana.columnar-table cl-ana.columnar-table asdf cl-ana.reusable-table cl-ana.table +cl-ana cl-ana.csv-table cl-ana.csv-table alexandria antik asdf cl-ana.list-utils cl-ana.table cl-csv iterate +cl-ana cl-ana.error-propogation cl-ana.error-propogation asdf cl-ana.generic-math cl-ana.math-functions +cl-ana cl-ana.file-utils cl-ana.file-utils asdf external-program split-sequence +cl-ana cl-ana.fitting cl-ana.fitting alexandria asdf cl-ana.error-propogation cl-ana.generic-math cl-ana.map cl-ana.math-functions gsll +cl-ana cl-ana.functional-utils cl-ana.functional-utils asdf +cl-ana cl-ana.generic-math cl-ana.generic-math asdf cl-ana.list-utils cl-ana.package-utils +cl-ana cl-ana.gnuplot-interface cl-ana.gnuplot-interface asdf external-program +cl-ana cl-ana.gsl-cffi cl-ana.gsl-cffi asdf cffi +cl-ana cl-ana.hash-table-utils cl-ana.hash-table-utils asdf +cl-ana cl-ana.hdf-cffi cl-ana.hdf-cffi asdf cffi +cl-ana cl-ana.hdf-table cl-ana.hdf-table alexandria asdf cl-ana.binary-tree cl-ana.hdf-cffi cl-ana.hdf-typespec cl-ana.hdf-utils cl-ana.list-utils cl-ana.memoization cl-ana.table cl-ana.typed-table cl-ana.typespec +cl-ana cl-ana.hdf-typespec cl-ana.hdf-typespec alexandria asdf cffi cl-ana.hdf-cffi cl-ana.list-utils cl-ana.memoization cl-ana.string-utils cl-ana.symbol-utils cl-ana.typespec +cl-ana cl-ana.hdf-utils cl-ana.hdf-utils alexandria asdf cffi cl-ana.hdf-cffi cl-ana.hdf-typespec cl-ana.macro-utils cl-ana.memoization cl-ana.pathname-utils cl-ana.string-utils cl-ana.typespec +cl-ana cl-ana.histogram cl-ana.histogram alexandria asdf cl-ana.binary-tree cl-ana.clos-utils cl-ana.fitting cl-ana.functional-utils cl-ana.generic-math cl-ana.hash-table-utils cl-ana.list-utils cl-ana.macro-utils cl-ana.map cl-ana.symbol-utils cl-ana.tensor iterate +cl-ana cl-ana.int-char cl-ana.int-char asdf +cl-ana cl-ana.linear-algebra cl-ana.linear-algebra asdf cl-ana.generic-math cl-ana.list-utils cl-ana.math-functions cl-ana.tensor gsll +cl-ana cl-ana.list-utils cl-ana.list-utils alexandria asdf cl-ana.functional-utils cl-ana.string-utils +cl-ana cl-ana.lorentz cl-ana.lorentz asdf cl-ana.generic-math cl-ana.linear-algebra cl-ana.tensor iterate +cl-ana cl-ana.macro-utils cl-ana.macro-utils alexandria asdf cl-ana.list-utils cl-ana.string-utils cl-ana.symbol-utils split-sequence +cl-ana cl-ana.makeres cl-ana.makeres alexandria asdf cl-ana.error-propogation cl-ana.file-utils cl-ana.functional-utils cl-ana.generic-math cl-ana.hash-table-utils cl-ana.hdf-utils cl-ana.histogram cl-ana.list-utils cl-ana.macro-utils cl-ana.map cl-ana.memoization cl-ana.pathname-utils cl-ana.plotting cl-ana.reusable-table cl-ana.serialization cl-ana.string-utils cl-ana.symbol-utils cl-ana.table cl-fad external-program uiop +cl-ana cl-ana.makeres-block cl-ana.makeres-block alexandria asdf cl-ana.list-utils cl-ana.macro-utils cl-ana.makeres +cl-ana cl-ana.makeres-branch cl-ana.makeres-branch alexandria asdf cl-ana.generic-math cl-ana.hash-table-utils cl-ana.list-utils cl-ana.makeres cl-ana.map +cl-ana cl-ana.makeres-graphviz cl-ana.makeres-graphviz asdf cl-ana.makeres external-program +cl-ana cl-ana.makeres-macro cl-ana.makeres-macro asdf cl-ana.list-utils cl-ana.makeres +cl-ana cl-ana.makeres-progress cl-ana.makeres-progress alexandria asdf cl-ana.generic-math cl-ana.makeres +cl-ana cl-ana.makeres-table cl-ana.makeres-table asdf cl-ana.csv-table cl-ana.hash-table-utils cl-ana.hdf-table cl-ana.hdf-utils cl-ana.list-utils cl-ana.macro-utils cl-ana.makeres cl-ana.makeres-macro cl-ana.memoization cl-ana.ntuple-table cl-ana.reusable-table cl-ana.string-utils cl-ana.table +cl-ana cl-ana.makeres-utils cl-ana.makeres-utils alexandria asdf cl-ana.file-utils cl-ana.fitting cl-ana.functional-utils cl-ana.generic-math cl-ana.histogram cl-ana.list-utils cl-ana.macro-utils cl-ana.makeres cl-ana.map cl-ana.pathname-utils cl-ana.plotting cl-ana.reusable-table cl-ana.string-utils cl-ana.symbol-utils cl-ana.table +cl-ana cl-ana.map cl-ana.map asdf cl-ana.hash-table-utils +cl-ana cl-ana.math-functions cl-ana.math-functions asdf cl-ana.generic-math gsll +cl-ana cl-ana.memoization cl-ana.memoization alexandria asdf +cl-ana cl-ana.ntuple-table cl-ana.ntuple-table alexandria asdf cffi cl-ana.gsl-cffi cl-ana.list-utils cl-ana.table cl-ana.typed-table cl-ana.typespec gsll +cl-ana cl-ana.package-utils cl-ana.package-utils alexandria asdf +cl-ana cl-ana.pathname-utils cl-ana.pathname-utils asdf +cl-ana cl-ana.plotting cl-ana.plotting alexandria asdf cl-ana.error-propogation cl-ana.functional-utils cl-ana.generic-math cl-ana.gnuplot-interface cl-ana.histogram cl-ana.list-utils cl-ana.macro-utils cl-ana.map cl-ana.math-functions cl-ana.pathname-utils cl-ana.string-utils cl-ana.tensor external-program split-sequence uiop +cl-ana cl-ana.quantity cl-ana.quantity alexandria asdf cl-ana.error-propogation cl-ana.generic-math cl-ana.list-utils cl-ana.macro-utils cl-ana.symbol-utils +cl-ana cl-ana.reusable-table cl-ana.reusable-table alexandria asdf cl-ana.table +cl-ana cl-ana.serialization cl-ana.serialization asdf cl-ana.error-propogation cl-ana.hdf-table cl-ana.hdf-utils cl-ana.histogram cl-ana.int-char cl-ana.macro-utils cl-ana.typespec +cl-ana cl-ana.statistical-learning cl-ana.statistical-learning asdf cl-ana.functional-utils cl-ana.generic-math cl-ana.histogram cl-ana.linear-algebra cl-ana.list-utils cl-ana.macro-utils cl-ana.map cl-ana.math-functions cl-ana.statistics +cl-ana cl-ana.statistics cl-ana.statistics asdf cl-ana.generic-math cl-ana.histogram cl-ana.list-utils cl-ana.macro-utils cl-ana.map cl-ana.math-functions +cl-ana cl-ana.string-utils cl-ana.string-utils asdf split-sequence +cl-ana cl-ana.symbol-utils cl-ana.symbol-utils asdf cl-ana.list-utils +cl-ana cl-ana.table cl-ana.table alexandria asdf cl-ana.functional-utils cl-ana.list-utils cl-ana.macro-utils cl-ana.string-utils cl-ana.symbol-utils +cl-ana cl-ana.table-utils cl-ana.table-utils asdf cl-ana.generic-math cl-ana.hash-table-utils cl-ana.statistics cl-ana.string-utils cl-ana.symbol-utils cl-ana.table +cl-ana cl-ana.table-viewing cl-ana.table-viewing alexandria asdf cl-ana.generic-math cl-ana.histogram cl-ana.macro-utils cl-ana.plotting cl-ana.string-utils cl-ana.table +cl-ana cl-ana.tensor cl-ana.tensor alexandria asdf cl-ana.generic-math cl-ana.list-utils cl-ana.macro-utils cl-ana.symbol-utils +cl-ana cl-ana.typed-table cl-ana.typed-table alexandria asdf cl-ana.list-utils cl-ana.string-utils cl-ana.symbol-utils cl-ana.table cl-ana.typespec +cl-ana cl-ana.typespec cl-ana.typespec alexandria asdf cffi cl-ana.int-char cl-ana.list-utils cl-ana.memoization cl-ana.string-utils cl-ana.symbol-utils cl-ana.tensor +cl-annot cl-annot cl-annot alexandria +cl-annot-prove cl-annot-prove cl-annot-prove cl-fad cl-ppcre cl-syntax cl-syntax-annot prove trivial-types +cl-annot-prove cl-annot-prove-test cl-annot-prove-test cl-annot-prove prove prove-asdf +cl-anonfun cl-anonfun cl-anonfun +cl-ansi-term cl-ansi-term cl-ansi-term alexandria anaphora asdf +cl-ansi-text cl-ansi-text cl-ansi-text alexandria cl-colors +cl-ansi-text cl-ansi-text-test cl-ansi-text-test alexandria cl-ansi-text cl-colors fiveam +cl-apple-plist cl-apple-plist cl-apple-plist html-encode +cl-arff-parser cl-arff-parser cl-arff-parser +cl-argparse cl-argparse cl-argparse asdf +cl-arrows cl-arrows cl-arrows +cl-arrows cl-arrows cl-arrows-test cl-arrows hu.dwim.stefil +cl-arxiv-api cl-arxiv-api cl-arxiv-api cl-interpol cl-ppcre cxml iterate trivial-http +cl-ascii-art cl-ascii-art cl-ascii-art alexandria cl-ansi-text cl-ppcre inferior-shell iterate split-sequence +cl-ascii-table cl-ascii-table cl-ascii-table +cl-association-rules cl-association-rules cl-association-rules +cl-association-rules cl-association-rules cl-association-rules-tests cl-association-rules prove +cl-async cl-async cl-async asdf babel cffi cl-async-base cl-async-util cl-libuv cl-ppcre static-vectors trivial-features trivial-gray-streams uiop +cl-async cl-async cl-async-base bordeaux-threads cffi cl-libuv +cl-async cl-async-repl cl-async-repl asdf bordeaux-threads cl-async +cl-async cl-async-ssl cl-async-ssl asdf cffi cl-async vom +cl-async cl-async-test cl-async-test asdf bordeaux-threads cffi cl-async cl-async-ssl fiveam flexi-streams ironclad usocket +cl-async cl-async cl-async-util cffi cl-async-base cl-libuv cl-ppcre fast-io vom +cl-async-future cl-async-future cl-async-future blackbird +cl-autorepo cl-autorepo cl-autorepo asdf +cl-autowrap cl-autowrap cl-autowrap alexandria asdf cffi cl-json cl-ppcre defpackage-plus trivial-features uiop +cl-autowrap cl-autowrap-test cl-autowrap-test asdf cl-autowrap +cl-autowrap cl-autowrap cl-autowrap/libffi cl-autowrap cl-plus-c +cl-autowrap cl-plus-c cl-plus-c asdf cl-autowrap +cl-azure cl-azure cl-azure babel cl-base64 cl-json cl-ppcre cxml drakma ironclad puri rt +cl-base32 cl-base32 cl-base32 +cl-base32 cl-base32 cl-base32-tests cl-base32 lisp-unit +cl-base58 cl-base58 cl-base58 +cl-base58 cl-base58-test cl-base58-test cl-base58 cl-test-more +cl-base64 cl-base64 cl-base64 +cl-base64 cl-base64 cl-base64-tests cl-base64 kmrcl ptester +cl-batis batis batis asdf cl-dbi cl-dbi-connection-pool cl-ppcre cl-syntax cl-syntax-annot +cl-batis batis-test batis-test asdf batis prove prove-asdf +cl-batis cl-batis cl-batis asdf batis +cl-bayesnet cl-bayesnet cl-bayesnet cffi s-xml trivial-shell +cl-beanstalk cl-beanstalk cl-beanstalk flexi-streams split-sequence usocket +cl-bencode bencode bencode asdf flexi-streams +cl-bencode bencode bencode-test bencode check-it hu.dwim.stefil +cl-bert bert bert alexandria erlang-term +cl-bibtex bibtex bibtex asdf split-sequence +cl-bip39 cl-bip39 cl-bip39 asdf ironclad secure-random split-sequence trivial-utf-8 +cl-bloom cl-bloom cl-bloom asdf cl-murmurhash static-vectors +cl-bnf cl-bnf cl-bnf asdf +cl-bnf cl-bnf-examples cl-bnf-examples asdf cl-bnf +cl-bnf cl-bnf-tests cl-bnf-tests asdf cl-bnf fiveam +cl-bootstrap cl-bootstrap cl-bootstrap asdf cl-who parenscript +cl-bootstrap cl-bootstrap-demo cl-bootstrap-demo asdf cl-bootstrap cl-who hunchentoot parenscript +cl-bootstrap cl-bootstrap-test cl-bootstrap-test asdf cl-bootstrap fiveam +cl-bplustree cl-bplustree cl-bplustree asdf +cl-bplustree cl-bplustree cl-bplustree-test cl-bplustree +cl-bson cl-bson cl-bson arrow-macros babel cl-intbytes fast-io ieee-floats let-over-lambda local-time named-readtables rutils trivial-shell +cl-bson cl-bson-test cl-bson-test cl-bson prove prove-asdf +cl-buchberger cl-buchberger cl-buchberger +cl-bunny cl-bunny cl-bunny alexandria blackbird cl-amqp cl-events eventfd iolib log4cl lparallel quri safe-queue string-case trivial-backtrace +cl-bunny cl-bunny.examples cl-bunny.examples cl-bunny log4cl +cl-bunny cl-bunny.test cl-bunny.test cl-bunny cl-interpol log4cl mw-equiv prove prove-asdf +cl-ca cl-ca cl-ca +cl-cache-tables cl-cache-tables cl-cache-tables +cl-cache-tables cl-cache-tables cl-cache-tables-tests cl-cache-tables prove +cl-cairo2 a-cl-cairo2-loader a-cl-cairo2-loader cl-cairo2 +cl-cairo2 cl-cairo2 cl-cairo2 cffi cl-colors cl-utilities metabang-bind trivial-features trivial-garbage +cl-cairo2 cl-cairo2-demos cl-cairo2-demos cl-cairo2 +cl-cairo2 cl-cairo2-gtk2 cl-cairo2-gtk2 cl-cairo2 cl-cairo2-xlib cl-gtk2-cairo +cl-cairo2 cl-cairo2-xlib cl-cairo2-xlib cl-cairo2 cl-freetype2 +cl-case-control cl-case-control cl-case-control trivial-types +cl-cffi-gtk cl-cffi-gtk cl-cffi-gtk alexandria asdf bordeaux-threads cffi cl-cffi-gtk-cairo cl-cffi-gtk-gdk cl-cffi-gtk-gdk-pixbuf cl-cffi-gtk-gio cl-cffi-gtk-glib cl-cffi-gtk-gobject cl-cffi-gtk-pango iterate trivial-features +cl-cffi-gtk cl-cffi-gtk-cairo cl-cffi-gtk-cairo asdf cffi cl-cffi-gtk-glib iterate +cl-cffi-gtk cl-cffi-gtk-demo-cairo cl-cffi-gtk-demo-cairo asdf cl-cffi-gtk +cl-cffi-gtk cl-cffi-gtk-demo-glib cl-cffi-gtk-demo-glib asdf cl-cffi-gtk +cl-cffi-gtk cl-cffi-gtk-demo-gobject cl-cffi-gtk-demo-gobject asdf cl-cffi-gtk-gobject +cl-cffi-gtk cl-cffi-gtk-example-gtk cl-cffi-gtk-example-gtk asdf cl-cffi-gtk +cl-cffi-gtk cl-cffi-gtk-gdk cl-cffi-gtk-gdk asdf cffi cl-cffi-gtk-cairo cl-cffi-gtk-gdk-pixbuf cl-cffi-gtk-gio cl-cffi-gtk-glib cl-cffi-gtk-gobject cl-cffi-gtk-pango +cl-cffi-gtk cl-cffi-gtk-gdk-pixbuf cl-cffi-gtk-gdk-pixbuf asdf cffi cl-cffi-gtk-glib cl-cffi-gtk-gobject +cl-cffi-gtk cl-cffi-gtk-gio cl-cffi-gtk-gio asdf cl-cffi-gtk-glib cl-cffi-gtk-gobject +cl-cffi-gtk cl-cffi-gtk-glib cl-cffi-gtk-glib alexandria asdf cffi iterate trivial-features +cl-cffi-gtk cl-cffi-gtk-gobject cl-cffi-gtk-gobject alexandria asdf bordeaux-threads cffi cl-cffi-gtk-glib closer-mop iterate trivial-garbage +cl-cffi-gtk cl-cffi-gtk-opengl-demo cl-cffi-gtk-opengl-demo asdf cl-cffi-gtk cl-opengl +cl-cffi-gtk cl-cffi-gtk-pango cl-cffi-gtk-pango asdf cl-cffi-gtk-cairo cl-cffi-gtk-glib cl-cffi-gtk-gobject iterate +cl-change-case cl-change-case cl-change-case asdf cl-ppcre cl-ppcre-unicode +cl-change-case cl-change-case-test cl-change-case-test asdf cl-change-case fiveam +cl-charms cl-charms cl-charms alexandria asdf cffi cffi-grovel +cl-charms cl-charms-paint cl-charms-paint asdf cl-charms +cl-charms cl-charms-timer cl-charms-timer asdf cl-charms +cl-cheshire-cat cl-cheshire-cat cl-cheshire-cat alexandria cl-fad cl-ppcre cl-store hunchentoot split-sequence usocket +cl-clblas cl-clblas cl-clblas asdf cffi +cl-clblas cl-clblas-test cl-clblas-test asdf cffi cl-clblas cl-oclapi prove prove-asdf +cl-cli cl-cli cl-cli split-sequence +cl-cli-parser cli-parser cli-parser +cl-clon net.didierverna.clon net.didierverna.clon asdf net.didierverna.clon.core net.didierverna.clon.setup +cl-clon net.didierverna.clon.core net.didierverna.clon.core asdf net.didierverna.clon.setup +cl-clon net.didierverna.clon.setup net.didierverna.clon.setup asdf +cl-clon net.didierverna.clon.setup net.didierverna.clon.setup/termio net.didierverna.clon.setup +cl-clon net.didierverna.clon.termio net.didierverna.clon.termio asdf net.didierverna.clon.core net.didierverna.clon.setup +cl-closure-template closure-template closure-template alexandria babel closer-mop esrap iterate parse-number split-sequence +cl-closure-template closure-template closure-template-test closure-template lift +cl-clsparse cl-clsparse cl-clsparse asdf cffi cffi-libffi +cl-cognito cl-cognito cl-cognito asdf aws-foundation cl-base64 cl-json-helper ironclad local-time +cl-collider cl-collider cl-collider alexandria asdf bordeaux-threads cffi flexi-streams named-readtables pileup sc-osc simple-inferiors split-sequence +cl-collider sc-osc sc-osc alexandria asdf bordeaux-threads ieee-floats osc usocket +cl-colors cl-colors cl-colors alexandria asdf let-plus +cl-colors cl-colors cl-colors-tests cl-colors lift +cl-colors2 cl-colors2 cl-colors2 alexandria asdf cl-ppcre +cl-colors2 cl-colors2 cl-colors2/tests cl-colors2 clunit2 +cl-conllu cl-conllu cl-conllu alexandria asdf cl-log cl-markup cl-ppcre lispbuilder-lexer split-sequence uuid wilbur xmls yason +cl-conspack cl-conspack cl-conspack alexandria closer-mop fast-io ieee-floats trivial-garbage trivial-utf-8 +cl-conspack cl-conspack-test cl-conspack-test checkl cl-conspack fiveam +cl-cont cl-cont cl-cont alexandria closer-mop +cl-cont cl-cont-test cl-cont-test cl-cont rt +cl-containers cl-containers cl-containers asdf-system-connections metatilities-base +cl-containers cl-containers-test cl-containers-test cl-containers lift +cl-containers cl-containers cl-containers/with-moptilities cl-containers moptilities +cl-containers cl-containers cl-containers/with-utilities cl-containers metatilities-base +cl-cookie cl-cookie cl-cookie alexandria asdf cl-ppcre local-time proc-parse quri +cl-cookie cl-cookie-test cl-cookie-test asdf cl-cookie prove prove-asdf +cl-coroutine cl-coroutine cl-coroutine alexandria cl-cont +cl-coroutine cl-coroutine-test cl-coroutine-test cl-coroutine cl-test-more +cl-coveralls cl-coveralls cl-coveralls alexandria asdf cl-ppcre dexador flexi-streams ironclad jonathan lquery split-sequence uiop +cl-coveralls cl-coveralls-test cl-coveralls-test asdf cl-coveralls prove prove-asdf +cl-cpus cl-cpus cl-cpus asdf cffi +cl-crc64 cl-crc64 cl-crc64 +cl-creditcard cl-authorize-net cl-authorize-net alexandria cl-creditcard drakma split-sequence symbol-munger +cl-creditcard cl-authorize-net cl-authorize-net-tests alexandria cl-authorize-net lisp-unit +cl-creditcard cl-creditcard cl-creditcard iterate +cl-cron cl-cron cl-cron asdf bordeaux-threads +cl-crypt crypt crypt +cl-css cl-css cl-css +cl-csv cl-csv cl-csv alexandria asdf cl-interpol iterate +cl-csv cl-csv-clsql cl-csv-clsql asdf cl-csv clsql-helper data-table-clsql +cl-csv cl-csv-data-table cl-csv-data-table asdf cl-csv data-table +cl-csv cl-csv cl-csv/speed-test cl-csv lisp-unit2 +cl-csv cl-csv cl-csv/test cl-csv lisp-unit2 +cl-cuda cl-cuda cl-cuda alexandria asdf cffi cffi-grovel cl-pattern cl-ppcre cl-reexport external-program osicat split-sequence +cl-cuda cl-cuda-examples cl-cuda-examples asdf cl-cuda imago +cl-cuda cl-cuda-interop cl-cuda-interop asdf cl-cuda cl-glu cl-glut cl-opengl +cl-cuda cl-cuda-interop-examples cl-cuda-interop-examples asdf cl-cuda-interop +cl-cuda cl-cuda-misc cl-cuda-misc asdf cl-emb local-time +cl-custom-hash-table cl-custom-hash-table cl-custom-hash-table +cl-custom-hash-table cl-custom-hash-table-test cl-custom-hash-table-test cl-custom-hash-table hu.dwim.stefil +cl-cut cl-cut cl-cut asdf +cl-cut cl-cut.test cl-cut.test asdf cl-cut prove prove-asdf +cl-cxx cxx cxx asdf cffi trivial-garbage +cl-cxx cxx-test cxx-test asdf cxx prove prove-asdf +cl-darksky cl-darksky cl-darksky alexandria asdf dexador jonathan +cl-darksky cl-darksky-test cl-darksky-test asdf cl-darksky prove prove-asdf +cl-data-format-validation data-format-validation data-format-validation cl-ppcre +cl-data-frame cl-data-frame cl-data-frame alexandria anaphora array-operations cl-num-utils cl-slice let-plus +cl-data-frame cl-data-frame cl-data-frame-tests cl-data-frame clunit +cl-date-time-parser cl-date-time-parser cl-date-time-parser alexandria anaphora cl-ppcre local-time parse-float split-sequence +cl-db3 db3 db3 asdf +cl-dbi cl-dbi cl-dbi asdf dbi +cl-dbi dbd-mysql dbd-mysql asdf cl-mysql cl-syntax cl-syntax-annot dbi +cl-dbi dbd-postgres dbd-postgres asdf cl-postgres cl-syntax cl-syntax-annot dbi trivial-garbage +cl-dbi dbd-sqlite3 dbd-sqlite3 asdf cl-syntax cl-syntax-annot dbi sqlite trivial-garbage uiop +cl-dbi dbi dbi asdf bordeaux-threads cl-syntax cl-syntax-annot closer-mop split-sequence +cl-dbi dbi-test dbi-test asdf cl-syntax cl-syntax-annot closer-mop dbi prove trivial-types +cl-dbi-connection-pool cl-dbi-connection-pool cl-dbi-connection-pool asdf dbi-cp +cl-dbi-connection-pool dbi-cp dbi-cp asdf bt-semaphore cl-dbi cl-syntax cl-syntax-annot +cl-dbi-connection-pool dbi-cp-test dbi-cp-test asdf dbi-cp prove prove-asdf +cl-dct dct dct alexandria asdf +cl-dct dct-test dct-test asdf babel cl-coveralls dct lisp-unit trivial-features +cl-decimals decimals decimals asdf +cl-devil cl-devil cl-devil alexandria cffi +cl-devil cl-ilu cl-ilu alexandria cffi cl-devil +cl-devil cl-ilut cl-ilut alexandria cffi cl-devil +cl-diceware cl-diceware cl-diceware +cl-difflib cl-difflib cl-difflib +cl-difflib cl-difflib-tests cl-difflib-tests cl-difflib +cl-digraph cl-digraph cl-digraph asdf +cl-digraph cl-digraph.dot cl-digraph.dot asdf cl-digraph cl-dot +cl-digraph cl-digraph.test cl-digraph.test 1am asdf cl-digraph +cl-diskspace cl-diskspace cl-diskspace asdf cffi cffi-grovel cl-ppcre uiop +cl-disque cl-disque cl-disque babel cl-ppcre flexi-streams rutils usocket +cl-disque cl-disque-test cl-disque-test cl-disque prove prove-asdf +cl-docutils docutils docutils cl-ppcre data-format-validation trivial-gray-streams +cl-dot cl-dot cl-dot asdf uiop +cl-dotenv cl-dotenv cl-dotenv alexandria asdf serapeum +cl-dotenv cl-dotenv-test cl-dotenv-test asdf cl-dotenv prove prove-asdf +cl-drm cl-drm cl-drm cffi +cl-dropbox cl-dropbox cl-dropbox cl-json cl-oauth cl-ppcre drakma +cl-dsl cl-dsl cl-dsl +cl-dsl cl-dsl cl-dsl-tests cl-dsl eos +cl-durian cl-durian cl-durian +cl-ecma-48 cl-ecma-48 cl-ecma-48 asdf +cl-editdistance edit-distance edit-distance asdf +cl-editdistance edit-distance-test edit-distance-test asdf babel cl-coveralls edit-distance lisp-unit trivial-features +cl-egl cl-egl cl-egl asdf cffi +cl-elastic cl-elastic cl-elastic asdf drakma named-readtables yason +cl-elastic cl-elastic-test cl-elastic-test asdf cl-elastic named-readtables parachute +cl-emacs-if cl-emacs-if cl-emacs-if +cl-emb cl-emb cl-emb asdf cl-ppcre +cl-emoji cl-emoji cl-emoji asdf +cl-emoji cl-emoji-test cl-emoji-test asdf cl-emoji prove prove-asdf +cl-enchant enchant enchant asdf cffi +cl-enchant enchant-autoload enchant-autoload asdf enchant +cl-enumeration enumerations enumerations asdf +cl-env cl-env cl-env asdf +cl-env cl-env cl-env/test cl-env lisp-unit +cl-environments cl-environments cl-environments alexandria anaphora asdf collectors optima prove-asdf +cl-environments cl-environments cl-environments/test cl-environments prove prove-asdf +cl-epmd epmd epmd com.gigamonkeys.binary-data usocket +cl-epmd epmd-test epmd-test epmd fiveam flexi-streams +cl-epoch cl-epoch cl-epoch asdf +cl-erlang-term erlang-term erlang-term alexandria ieee-floats nibbles zlib +cl-erlang-term erlang-term-optima erlang-term-optima erlang-term optima +cl-erlang-term erlang-term-test erlang-term-test erlang-term erlang-term-optima fiveam nibbles +cl-ev ev ev cffi trivial-garbage +cl-events cl-events cl-events alexandria blackbird iterate log4cl lparallel +cl-events cl-events.test cl-events.test cl-events log4cl mw-equiv prove prove-asdf +cl-ewkb cl-ewkb cl-ewkb flexi-streams ieee-floats +cl-ewkb cl-ewkb cl-ewkb-tests cl-ewkb postmodern +cl-factoring cl-factoring cl-factoring asdf cl-primality iterate +cl-factoring cl-factoring-test cl-factoring-test asdf cl-factoring cl-primality iterate stefil +cl-fad cl-fad cl-fad alexandria asdf bordeaux-threads +cl-fad cl-fad cl-fad-test cl-fad cl-ppcre unit-test +cl-fam cl-fam cl-fam cffi cffi-grovel trivial-garbage +cl-fastcgi cl-fastcgi cl-fastcgi asdf cffi usocket +cl-fbclient cl-fbclient cl-fbclient cffi +cl-feedparser cl-feedparser cl-feedparser asdf asdf-package-system +cl-feedparser cl-feedparser-tests cl-feedparser-tests asdf cl-feedparser fiveam fxml local-time +cl-feedparser cl-feedparser cl-feedparser/test cl-feedparser fiveam fxml local-time +cl-fixtures cl-fixtures cl-fixtures alexandria asdf x.let-star +cl-fixtures cl-fixtures-test cl-fixtures-test asdf cl-fixtures incf-cl prove prove-asdf rutils +cl-flac cl-flac cl-flac asdf cffi documentation-utils trivial-features trivial-garbage +cl-flat-tree flat-tree flat-tree asdf +cl-flow cl-flow cl-flow alexandria asdf cl-muth +cl-flow cl-flow cl-flow/tests alexandria cl-flow cl-muth fiveam simple-flow-dispatcher +cl-flowd cl-flowd cl-flowd cl-annot +cl-fluent-logger cl-fluent-logger cl-fluent-logger asdf +cl-fluidinfo cl-fluiddb cl-fluiddb bordeaux-threads cl-json drakma flexi-streams split-sequence +cl-fluidinfo cl-fluiddb-test cl-fluiddb-test cl-fluiddb lift +cl-fluidinfo cl-fluidinfo cl-fluidinfo cl-fluiddb +cl-fond cl-fond cl-fond alexandria asdf cffi cl-opengl documentation-utils trivial-features trivial-garbage +cl-forms cl-forms cl-forms alexandria asdf cl-ppcre clavier fmt hunchentoot ironclad uuid +cl-forms cl-forms.demo cl-forms.demo asdf cl-css cl-forms cl-forms.test cl-forms.who cl-forms.who.bootstrap cl-who hunchentoot +cl-forms cl-forms.djula cl-forms.djula asdf cl-forms cl-forms.who djula +cl-forms cl-forms.test cl-forms.test asdf cl-forms fiveam +cl-forms cl-forms.who cl-forms.who asdf cl-forms cl-who +cl-forms cl-forms.who cl-forms.who.bootstrap cl-forms.who +cl-freeimage cl-freeimage cl-freeimage cffi +cl-freetype2 cl-freetype2 cl-freetype2 alexandria asdf cffi cffi-grovel trivial-garbage +cl-freetype2 cl-freetype2-tests cl-freetype2-tests asdf cl-freetype2 fiveam +cl-fsnotify cl-fsnotify cl-fsnotify cffi cffi-grovel +cl-ftp cl-ftp cl-ftp split-sequence usocket +cl-ftp ftp ftp cl-ftp +cl-fuse cl-fuse cl-fuse asdf bordeaux-threads cffi cffi-grovel cl-utilities iterate trivial-backtrace trivial-utf-8 +cl-fuse-meta-fs cl-fuse-meta-fs cl-fuse-meta-fs asdf bordeaux-threads cl-fuse iterate pcall +cl-fuzz cl-fuzz cl-fuzz alexandria asdf +cl-gambol gambol gambol +cl-gamepad cl-gamepad cl-gamepad asdf cffi documentation-utils trivial-features +cl-gamepad cl-gamepad-visualizer cl-gamepad-visualizer asdf cl-gamepad qtcore qtgui qtools +cl-gap-buffer cl-gap-buffer cl-gap-buffer asdf +cl-gbm cl-gbm cl-gbm asdf cffi +cl-gd cl-gd cl-gd uffi +cl-gd cl-gd-test cl-gd-test cl-gd +cl-gdata cl-gdata cl-gdata alexandria cl-fad cl-json cl-ppcre closer-mop cxml drakma flexi-streams gzip-stream local-time parse-number split-sequence string-case trivial-utf-8 url-rewrite xpath +cl-gearman cl-gearman cl-gearman alexandria babel split-sequence usocket +cl-gearman cl-gearman-test cl-gearman-test cl-gearman cl-test-more +cl-gendoc cl-gendoc cl-gendoc 3bmd 3bmd-ext-code-blocks asdf cl-who +cl-gendoc cl-gendoc cl-gendoc-docs cl-gendoc +cl-gene-searcher cl-gene-searcher cl-gene-searcher clsql-sqlite3 +cl-general-accumulator general-accumulator general-accumulator asdf +cl-generator cl-generator cl-generator asdf cl-cont +cl-generator cl-generator-test cl-generator-test asdf cl-generator lisp-unit +cl-generic-arithmetic cl-generic-arithmetic cl-generic-arithmetic asdf conduit-packages +cl-geocode cl-geocode cl-geocode acl-compat asdf aserve cl-ppcre +cl-geoip cl-geoip cl-geoip cffi +cl-geometry cl-geometry cl-geometry iterate trees +cl-geometry cl-geometry-tests cl-geometry-tests cl-geometry iterate vecto +cl-geos cl-geos cl-geos asdf cffi trivial-garbage uiop xarray +cl-geos cl-geos cl-geos/test cl-geos fiveam +cl-gimei cl-gimei cl-gimei asdf +cl-gimei cl-gimei cl-gimei/test cl-gimei rove +cl-gists cl-gists cl-gists alexandria asdf babel cl-syntax cl-syntax-annot dexador jonathan local-time quri trivial-types uiop +cl-gists cl-gists-test cl-gists-test asdf cl-gists closer-mop prove prove-asdf +cl-git cl-git cl-git alexandria anaphora asdf cffi cffi-grovel cl-fad closer-mop flexi-streams local-time trivial-garbage uiop +cl-git cl-git cl-git/tests alexandria asdf cl-fad cl-git fiveam flexi-streams inferior-shell local-time unix-options +cl-github-v3 cl-github-v3 cl-github-v3 alexandria asdf cl-ppcre drakma yason +cl-glfw cl-glfw cl-glfw cffi cl-glfw-types +cl-glfw cl-glfw-ftgl cl-glfw-ftgl cffi +cl-glfw cl-glfw-glu cl-glfw-glu cffi cl-glfw-types +cl-glfw cl-glfw-opengl-3dfx_multisample cl-glfw-opengl-3dfx_multisample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-3dfx_tbuffer cl-glfw-opengl-3dfx_tbuffer cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-3dfx_texture_compression_fxt1 cl-glfw-opengl-3dfx_texture_compression_fxt1 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-amd_blend_minmax_factor cl-glfw-opengl-amd_blend_minmax_factor cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-amd_depth_clamp_separate cl-glfw-opengl-amd_depth_clamp_separate cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-amd_draw_buffers_blend cl-glfw-opengl-amd_draw_buffers_blend cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-amd_multi_draw_indirect cl-glfw-opengl-amd_multi_draw_indirect cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-amd_name_gen_delete cl-glfw-opengl-amd_name_gen_delete cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-amd_performance_monitor cl-glfw-opengl-amd_performance_monitor cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-amd_sample_positions cl-glfw-opengl-amd_sample_positions cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-amd_seamless_cubemap_per_texture cl-glfw-opengl-amd_seamless_cubemap_per_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-amd_vertex_shader_tesselator cl-glfw-opengl-amd_vertex_shader_tesselator cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_aux_depth_stencil cl-glfw-opengl-apple_aux_depth_stencil cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_client_storage cl-glfw-opengl-apple_client_storage cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_element_array cl-glfw-opengl-apple_element_array cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_fence cl-glfw-opengl-apple_fence cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_float_pixels cl-glfw-opengl-apple_float_pixels cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_flush_buffer_range cl-glfw-opengl-apple_flush_buffer_range cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_object_purgeable cl-glfw-opengl-apple_object_purgeable cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_rgb_422 cl-glfw-opengl-apple_rgb_422 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_row_bytes cl-glfw-opengl-apple_row_bytes cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_specular_vector cl-glfw-opengl-apple_specular_vector cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_texture_range cl-glfw-opengl-apple_texture_range cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_transform_hint cl-glfw-opengl-apple_transform_hint cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_vertex_array_object cl-glfw-opengl-apple_vertex_array_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_vertex_array_range cl-glfw-opengl-apple_vertex_array_range cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_vertex_program_evaluators cl-glfw-opengl-apple_vertex_program_evaluators cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-apple_ycbcr_422 cl-glfw-opengl-apple_ycbcr_422 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_blend_func_extended cl-glfw-opengl-arb_blend_func_extended cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_color_buffer_float cl-glfw-opengl-arb_color_buffer_float cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_copy_buffer cl-glfw-opengl-arb_copy_buffer cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_depth_buffer_float cl-glfw-opengl-arb_depth_buffer_float cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_depth_clamp cl-glfw-opengl-arb_depth_clamp cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_depth_texture cl-glfw-opengl-arb_depth_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_draw_buffers cl-glfw-opengl-arb_draw_buffers cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_draw_buffers_blend cl-glfw-opengl-arb_draw_buffers_blend cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_draw_elements_base_vertex cl-glfw-opengl-arb_draw_elements_base_vertex cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_draw_indirect cl-glfw-opengl-arb_draw_indirect cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_draw_instanced cl-glfw-opengl-arb_draw_instanced cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_es2_compatibility cl-glfw-opengl-arb_es2_compatibility cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_fragment_program cl-glfw-opengl-arb_fragment_program cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_fragment_shader cl-glfw-opengl-arb_fragment_shader cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_framebuffer_object cl-glfw-opengl-arb_framebuffer_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_framebuffer_object_deprecated cl-glfw-opengl-arb_framebuffer_object_deprecated cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_framebuffer_srgb cl-glfw-opengl-arb_framebuffer_srgb cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_geometry_shader4 cl-glfw-opengl-arb_geometry_shader4 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_get_program_binary cl-glfw-opengl-arb_get_program_binary cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_gpu_shader5 cl-glfw-opengl-arb_gpu_shader5 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_gpu_shader_fp64 cl-glfw-opengl-arb_gpu_shader_fp64 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_half_float_pixel cl-glfw-opengl-arb_half_float_pixel cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_half_float_vertex cl-glfw-opengl-arb_half_float_vertex cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_imaging cl-glfw-opengl-arb_imaging cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_imaging_deprecated cl-glfw-opengl-arb_imaging_deprecated cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_instanced_arrays cl-glfw-opengl-arb_instanced_arrays cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_map_buffer_range cl-glfw-opengl-arb_map_buffer_range cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_matrix_palette cl-glfw-opengl-arb_matrix_palette cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_multisample cl-glfw-opengl-arb_multisample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_multitexture cl-glfw-opengl-arb_multitexture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_occlusion_query cl-glfw-opengl-arb_occlusion_query cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_occlusion_query2 cl-glfw-opengl-arb_occlusion_query2 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_pixel_buffer_object cl-glfw-opengl-arb_pixel_buffer_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_point_parameters cl-glfw-opengl-arb_point_parameters cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_point_sprite cl-glfw-opengl-arb_point_sprite cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_provoking_vertex cl-glfw-opengl-arb_provoking_vertex cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_robustness cl-glfw-opengl-arb_robustness cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_sample_shading cl-glfw-opengl-arb_sample_shading cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_sampler_objects cl-glfw-opengl-arb_sampler_objects cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_seamless_cube_map cl-glfw-opengl-arb_seamless_cube_map cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_separate_shader_objects cl-glfw-opengl-arb_separate_shader_objects cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_shader_objects cl-glfw-opengl-arb_shader_objects cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_shader_subroutine cl-glfw-opengl-arb_shader_subroutine cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_shading_language_100 cl-glfw-opengl-arb_shading_language_100 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_shading_language_include cl-glfw-opengl-arb_shading_language_include cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_shadow cl-glfw-opengl-arb_shadow cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_shadow_ambient cl-glfw-opengl-arb_shadow_ambient cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_tessellation_shader cl-glfw-opengl-arb_tessellation_shader cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_border_clamp cl-glfw-opengl-arb_texture_border_clamp cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_buffer_object cl-glfw-opengl-arb_texture_buffer_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_buffer_object_rgb32 cl-glfw-opengl-arb_texture_buffer_object_rgb32 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_compression cl-glfw-opengl-arb_texture_compression cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_compression_bptc cl-glfw-opengl-arb_texture_compression_bptc cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_compression_rgtc cl-glfw-opengl-arb_texture_compression_rgtc cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_cube_map cl-glfw-opengl-arb_texture_cube_map cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_cube_map_array cl-glfw-opengl-arb_texture_cube_map_array cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_env_combine cl-glfw-opengl-arb_texture_env_combine cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_env_dot3 cl-glfw-opengl-arb_texture_env_dot3 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_float cl-glfw-opengl-arb_texture_float cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_gather cl-glfw-opengl-arb_texture_gather cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_mirrored_repeat cl-glfw-opengl-arb_texture_mirrored_repeat cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_multisample cl-glfw-opengl-arb_texture_multisample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_rectangle cl-glfw-opengl-arb_texture_rectangle cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_rg cl-glfw-opengl-arb_texture_rg cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_rgb10_a2ui cl-glfw-opengl-arb_texture_rgb10_a2ui cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_texture_swizzle cl-glfw-opengl-arb_texture_swizzle cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_timer_query cl-glfw-opengl-arb_timer_query cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_transform_feedback2 cl-glfw-opengl-arb_transform_feedback2 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_transpose_matrix cl-glfw-opengl-arb_transpose_matrix cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_uniform_buffer_object cl-glfw-opengl-arb_uniform_buffer_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_vertex_array_bgra cl-glfw-opengl-arb_vertex_array_bgra cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_vertex_array_object cl-glfw-opengl-arb_vertex_array_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_vertex_attrib_64bit cl-glfw-opengl-arb_vertex_attrib_64bit cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_vertex_blend cl-glfw-opengl-arb_vertex_blend cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_vertex_buffer_object cl-glfw-opengl-arb_vertex_buffer_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_vertex_program cl-glfw-opengl-arb_vertex_program cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_vertex_shader cl-glfw-opengl-arb_vertex_shader cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_vertex_type_2_10_10_10_rev cl-glfw-opengl-arb_vertex_type_2_10_10_10_rev cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_viewport_array cl-glfw-opengl-arb_viewport_array cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-arb_window_pos cl-glfw-opengl-arb_window_pos cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_draw_buffers cl-glfw-opengl-ati_draw_buffers cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_element_array cl-glfw-opengl-ati_element_array cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_envmap_bumpmap cl-glfw-opengl-ati_envmap_bumpmap cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_fragment_shader cl-glfw-opengl-ati_fragment_shader cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_map_object_buffer cl-glfw-opengl-ati_map_object_buffer cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_meminfo cl-glfw-opengl-ati_meminfo cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_pixel_format_float cl-glfw-opengl-ati_pixel_format_float cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_pn_triangles cl-glfw-opengl-ati_pn_triangles cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_separate_stencil cl-glfw-opengl-ati_separate_stencil cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_text_fragment_shader cl-glfw-opengl-ati_text_fragment_shader cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_texture_env_combine3 cl-glfw-opengl-ati_texture_env_combine3 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_texture_float cl-glfw-opengl-ati_texture_float cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_texture_mirror_once cl-glfw-opengl-ati_texture_mirror_once cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_vertex_array_object cl-glfw-opengl-ati_vertex_array_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_vertex_attrib_array_object cl-glfw-opengl-ati_vertex_attrib_array_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ati_vertex_streams cl-glfw-opengl-ati_vertex_streams cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-core cl-glfw-opengl-core cffi cl-glfw-types +cl-glfw cl-glfw-opengl-ext_422_pixels cl-glfw-opengl-ext_422_pixels cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_abgr cl-glfw-opengl-ext_abgr cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_bgra cl-glfw-opengl-ext_bgra cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_bindable_uniform cl-glfw-opengl-ext_bindable_uniform cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_blend_color cl-glfw-opengl-ext_blend_color cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_blend_equation_separate cl-glfw-opengl-ext_blend_equation_separate cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_blend_func_separate cl-glfw-opengl-ext_blend_func_separate cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_blend_minmax cl-glfw-opengl-ext_blend_minmax cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_blend_subtract cl-glfw-opengl-ext_blend_subtract cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_clip_volume_hint cl-glfw-opengl-ext_clip_volume_hint cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_cmyka cl-glfw-opengl-ext_cmyka cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_color_subtable cl-glfw-opengl-ext_color_subtable cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_compiled_vertex_array cl-glfw-opengl-ext_compiled_vertex_array cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_convolution cl-glfw-opengl-ext_convolution cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_coordinate_frame cl-glfw-opengl-ext_coordinate_frame cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_copy_texture cl-glfw-opengl-ext_copy_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_cull_vertex cl-glfw-opengl-ext_cull_vertex cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_depth_bounds_test cl-glfw-opengl-ext_depth_bounds_test cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_direct_state_access cl-glfw-opengl-ext_direct_state_access cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_draw_buffers2 cl-glfw-opengl-ext_draw_buffers2 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_draw_instanced cl-glfw-opengl-ext_draw_instanced cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_draw_range_elements cl-glfw-opengl-ext_draw_range_elements cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_fog_coord cl-glfw-opengl-ext_fog_coord cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_framebuffer_blit cl-glfw-opengl-ext_framebuffer_blit cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_framebuffer_multisample cl-glfw-opengl-ext_framebuffer_multisample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_framebuffer_object cl-glfw-opengl-ext_framebuffer_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_framebuffer_srgb cl-glfw-opengl-ext_framebuffer_srgb cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_geometry_shader4 cl-glfw-opengl-ext_geometry_shader4 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_gpu_program_parameters cl-glfw-opengl-ext_gpu_program_parameters cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_gpu_shader4 cl-glfw-opengl-ext_gpu_shader4 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_histogram cl-glfw-opengl-ext_histogram cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_index_array_formats cl-glfw-opengl-ext_index_array_formats cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_index_func cl-glfw-opengl-ext_index_func cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_index_material cl-glfw-opengl-ext_index_material cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_light_texture cl-glfw-opengl-ext_light_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_multi_draw_arrays cl-glfw-opengl-ext_multi_draw_arrays cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_multisample cl-glfw-opengl-ext_multisample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_packed_depth_stencil cl-glfw-opengl-ext_packed_depth_stencil cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_packed_float cl-glfw-opengl-ext_packed_float cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_packed_pixels cl-glfw-opengl-ext_packed_pixels cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_paletted_texture cl-glfw-opengl-ext_paletted_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_pixel_buffer_object cl-glfw-opengl-ext_pixel_buffer_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_pixel_transform cl-glfw-opengl-ext_pixel_transform cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_point_parameters cl-glfw-opengl-ext_point_parameters cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_polygon_offset cl-glfw-opengl-ext_polygon_offset cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_provoking_vertex cl-glfw-opengl-ext_provoking_vertex cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_secondary_color cl-glfw-opengl-ext_secondary_color cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_separate_shader_objects cl-glfw-opengl-ext_separate_shader_objects cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_separate_specular_color cl-glfw-opengl-ext_separate_specular_color cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_shader_image_load_store cl-glfw-opengl-ext_shader_image_load_store cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_stencil_clear_tag cl-glfw-opengl-ext_stencil_clear_tag cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_stencil_two_side cl-glfw-opengl-ext_stencil_two_side cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_stencil_wrap cl-glfw-opengl-ext_stencil_wrap cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_subtexture cl-glfw-opengl-ext_subtexture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture cl-glfw-opengl-ext_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture3d cl-glfw-opengl-ext_texture3d cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_array cl-glfw-opengl-ext_texture_array cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_buffer_object cl-glfw-opengl-ext_texture_buffer_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_compression_latc cl-glfw-opengl-ext_texture_compression_latc cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_compression_rgtc cl-glfw-opengl-ext_texture_compression_rgtc cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_compression_s3tc cl-glfw-opengl-ext_texture_compression_s3tc cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_cube_map cl-glfw-opengl-ext_texture_cube_map cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_env_combine cl-glfw-opengl-ext_texture_env_combine cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_env_dot3 cl-glfw-opengl-ext_texture_env_dot3 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_filter_anisotropic cl-glfw-opengl-ext_texture_filter_anisotropic cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_integer cl-glfw-opengl-ext_texture_integer cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_lod_bias cl-glfw-opengl-ext_texture_lod_bias cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_mirror_clamp cl-glfw-opengl-ext_texture_mirror_clamp cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_object cl-glfw-opengl-ext_texture_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_perturb_normal cl-glfw-opengl-ext_texture_perturb_normal cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_shared_exponent cl-glfw-opengl-ext_texture_shared_exponent cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_snorm cl-glfw-opengl-ext_texture_snorm cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_srgb cl-glfw-opengl-ext_texture_srgb cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_srgb_decode cl-glfw-opengl-ext_texture_srgb_decode cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_texture_swizzle cl-glfw-opengl-ext_texture_swizzle cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_timer_query cl-glfw-opengl-ext_timer_query cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_transform_feedback cl-glfw-opengl-ext_transform_feedback cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_vertex_array cl-glfw-opengl-ext_vertex_array cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_vertex_array_bgra cl-glfw-opengl-ext_vertex_array_bgra cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_vertex_attrib_64bit cl-glfw-opengl-ext_vertex_attrib_64bit cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_vertex_shader cl-glfw-opengl-ext_vertex_shader cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ext_vertex_weighting cl-glfw-opengl-ext_vertex_weighting cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-gremedy_frame_terminator cl-glfw-opengl-gremedy_frame_terminator cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-gremedy_string_marker cl-glfw-opengl-gremedy_string_marker cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-hp_convolution_border_modes cl-glfw-opengl-hp_convolution_border_modes cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-hp_image_transform cl-glfw-opengl-hp_image_transform cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-hp_occlusion_test cl-glfw-opengl-hp_occlusion_test cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-hp_texture_lighting cl-glfw-opengl-hp_texture_lighting cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ibm_cull_vertex cl-glfw-opengl-ibm_cull_vertex cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ibm_multimode_draw_arrays cl-glfw-opengl-ibm_multimode_draw_arrays cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ibm_rasterpos_clip cl-glfw-opengl-ibm_rasterpos_clip cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ibm_texture_mirrored_repeat cl-glfw-opengl-ibm_texture_mirrored_repeat cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ibm_vertex_array_lists cl-glfw-opengl-ibm_vertex_array_lists cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ingr_blend_func_separate cl-glfw-opengl-ingr_blend_func_separate cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ingr_color_clamp cl-glfw-opengl-ingr_color_clamp cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-ingr_interlace_read cl-glfw-opengl-ingr_interlace_read cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-intel_parallel_arrays cl-glfw-opengl-intel_parallel_arrays cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-mesa_pack_invert cl-glfw-opengl-mesa_pack_invert cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-mesa_packed_depth_stencil cl-glfw-opengl-mesa_packed_depth_stencil cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-mesa_program_debug cl-glfw-opengl-mesa_program_debug cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-mesa_resize_buffers cl-glfw-opengl-mesa_resize_buffers cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-mesa_shader_debug cl-glfw-opengl-mesa_shader_debug cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-mesa_trace cl-glfw-opengl-mesa_trace cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-mesa_window_pos cl-glfw-opengl-mesa_window_pos cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-mesa_ycbcr_texture cl-glfw-opengl-mesa_ycbcr_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-mesax_texture_stack cl-glfw-opengl-mesax_texture_stack cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_conditional_render cl-glfw-opengl-nv_conditional_render cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_copy_depth_to_color cl-glfw-opengl-nv_copy_depth_to_color cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_copy_image cl-glfw-opengl-nv_copy_image cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_depth_buffer_float cl-glfw-opengl-nv_depth_buffer_float cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_depth_clamp cl-glfw-opengl-nv_depth_clamp cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_evaluators cl-glfw-opengl-nv_evaluators cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_explicit_multisample cl-glfw-opengl-nv_explicit_multisample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_fence cl-glfw-opengl-nv_fence cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_float_buffer cl-glfw-opengl-nv_float_buffer cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_fog_distance cl-glfw-opengl-nv_fog_distance cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_fragment_program cl-glfw-opengl-nv_fragment_program cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_fragment_program2 cl-glfw-opengl-nv_fragment_program2 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_framebuffer_multisample_coverage cl-glfw-opengl-nv_framebuffer_multisample_coverage cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_geometry_program4 cl-glfw-opengl-nv_geometry_program4 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_gpu_program4 cl-glfw-opengl-nv_gpu_program4 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_gpu_program5 cl-glfw-opengl-nv_gpu_program5 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_gpu_shader5 cl-glfw-opengl-nv_gpu_shader5 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_half_float cl-glfw-opengl-nv_half_float cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_light_max_exponent cl-glfw-opengl-nv_light_max_exponent cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_multisample_coverage cl-glfw-opengl-nv_multisample_coverage cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_multisample_filter_hint cl-glfw-opengl-nv_multisample_filter_hint cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_occlusion_query cl-glfw-opengl-nv_occlusion_query cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_packed_depth_stencil cl-glfw-opengl-nv_packed_depth_stencil cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_parameter_buffer_object cl-glfw-opengl-nv_parameter_buffer_object cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_pixel_data_range cl-glfw-opengl-nv_pixel_data_range cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_point_sprite cl-glfw-opengl-nv_point_sprite cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_present_video cl-glfw-opengl-nv_present_video cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_primitive_restart cl-glfw-opengl-nv_primitive_restart cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_register_combiners cl-glfw-opengl-nv_register_combiners cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_register_combiners2 cl-glfw-opengl-nv_register_combiners2 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_shader_buffer_load cl-glfw-opengl-nv_shader_buffer_load cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_shader_buffer_store cl-glfw-opengl-nv_shader_buffer_store cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_tessellation_program5 cl-glfw-opengl-nv_tessellation_program5 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_texgen_emboss cl-glfw-opengl-nv_texgen_emboss cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_texgen_reflection cl-glfw-opengl-nv_texgen_reflection cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_texture_barrier cl-glfw-opengl-nv_texture_barrier cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_texture_env_combine4 cl-glfw-opengl-nv_texture_env_combine4 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_texture_expand_normal cl-glfw-opengl-nv_texture_expand_normal cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_texture_multisample cl-glfw-opengl-nv_texture_multisample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_texture_rectangle cl-glfw-opengl-nv_texture_rectangle cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_texture_shader cl-glfw-opengl-nv_texture_shader cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_texture_shader2 cl-glfw-opengl-nv_texture_shader2 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_texture_shader3 cl-glfw-opengl-nv_texture_shader3 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_transform_feedback cl-glfw-opengl-nv_transform_feedback cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_transform_feedback2 cl-glfw-opengl-nv_transform_feedback2 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_vertex_array_range cl-glfw-opengl-nv_vertex_array_range cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_vertex_array_range2 cl-glfw-opengl-nv_vertex_array_range2 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_vertex_attrib_integer_64bit cl-glfw-opengl-nv_vertex_attrib_integer_64bit cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_vertex_buffer_unified_memory cl-glfw-opengl-nv_vertex_buffer_unified_memory cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_vertex_program cl-glfw-opengl-nv_vertex_program cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_vertex_program2_option cl-glfw-opengl-nv_vertex_program2_option cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_vertex_program3 cl-glfw-opengl-nv_vertex_program3 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-nv_vertex_program4 cl-glfw-opengl-nv_vertex_program4 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-oes_read_format cl-glfw-opengl-oes_read_format cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-oml_interlace cl-glfw-opengl-oml_interlace cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-oml_resample cl-glfw-opengl-oml_resample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-oml_subsample cl-glfw-opengl-oml_subsample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-pgi_misc_hints cl-glfw-opengl-pgi_misc_hints cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-pgi_vertex_hints cl-glfw-opengl-pgi_vertex_hints cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-rend_screen_coordinates cl-glfw-opengl-rend_screen_coordinates cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-s3_s3tc cl-glfw-opengl-s3_s3tc cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgi_color_table cl-glfw-opengl-sgi_color_table cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgi_depth_pass_instrument cl-glfw-opengl-sgi_depth_pass_instrument cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgis_detail_texture cl-glfw-opengl-sgis_detail_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgis_fog_function cl-glfw-opengl-sgis_fog_function cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgis_multisample cl-glfw-opengl-sgis_multisample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgis_pixel_texture cl-glfw-opengl-sgis_pixel_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgis_point_parameters cl-glfw-opengl-sgis_point_parameters cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgis_sharpen_texture cl-glfw-opengl-sgis_sharpen_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgis_texture4d cl-glfw-opengl-sgis_texture4d cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgis_texture_color_mask cl-glfw-opengl-sgis_texture_color_mask cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgis_texture_filter4 cl-glfw-opengl-sgis_texture_filter4 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgis_texture_select cl-glfw-opengl-sgis_texture_select cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_async cl-glfw-opengl-sgix_async cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_depth_texture cl-glfw-opengl-sgix_depth_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_flush_raster cl-glfw-opengl-sgix_flush_raster cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_fog_scale cl-glfw-opengl-sgix_fog_scale cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_fragment_lighting cl-glfw-opengl-sgix_fragment_lighting cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_framezoom cl-glfw-opengl-sgix_framezoom cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_igloo_interface cl-glfw-opengl-sgix_igloo_interface cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_instruments cl-glfw-opengl-sgix_instruments cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_line_quality_hint cl-glfw-opengl-sgix_line_quality_hint cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_list_priority cl-glfw-opengl-sgix_list_priority cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_pixel_texture cl-glfw-opengl-sgix_pixel_texture cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_polynomial_ffd cl-glfw-opengl-sgix_polynomial_ffd cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_reference_plane cl-glfw-opengl-sgix_reference_plane cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_resample cl-glfw-opengl-sgix_resample cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_scalebias_hint cl-glfw-opengl-sgix_scalebias_hint cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_shadow cl-glfw-opengl-sgix_shadow cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_shadow_ambient cl-glfw-opengl-sgix_shadow_ambient cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_slim cl-glfw-opengl-sgix_slim cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_sprite cl-glfw-opengl-sgix_sprite cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_tag_sample_buffer cl-glfw-opengl-sgix_tag_sample_buffer cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_texture_coordinate_clamp cl-glfw-opengl-sgix_texture_coordinate_clamp cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_texture_lod_bias cl-glfw-opengl-sgix_texture_lod_bias cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_texture_multi_buffer cl-glfw-opengl-sgix_texture_multi_buffer cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sgix_ycrcba cl-glfw-opengl-sgix_ycrcba cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sun_convolution_border_modes cl-glfw-opengl-sun_convolution_border_modes cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sun_global_alpha cl-glfw-opengl-sun_global_alpha cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sun_mesh_array cl-glfw-opengl-sun_mesh_array cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sun_slice_accum cl-glfw-opengl-sun_slice_accum cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sun_triangle_list cl-glfw-opengl-sun_triangle_list cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sun_vertex cl-glfw-opengl-sun_vertex cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-sunx_constant_data cl-glfw-opengl-sunx_constant_data cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-version_1_0 cl-glfw-opengl-version_1_0 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-version_1_1 cl-glfw-opengl-version_1_1 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-version_1_2 cl-glfw-opengl-version_1_2 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-version_1_3 cl-glfw-opengl-version_1_3 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-version_1_4 cl-glfw-opengl-version_1_4 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-version_1_5 cl-glfw-opengl-version_1_5 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-version_2_0 cl-glfw-opengl-version_2_0 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-version_2_1 cl-glfw-opengl-version_2_1 cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-win_phong_shading cl-glfw-opengl-win_phong_shading cl-glfw-opengl-core +cl-glfw cl-glfw-opengl-win_specular_fog cl-glfw-opengl-win_specular_fog cl-glfw-opengl-core +cl-glfw cl-glfw-types cl-glfw-types cffi +cl-glfw3 cl-glfw3 cl-glfw3 alexandria asdf cffi +cl-glfw3 cl-glfw3-examples cl-glfw3-examples asdf cl-glfw3 cl-opengl trivial-main-thread +cl-gobject-introspection cl-gobject-introspection cl-gobject-introspection alexandria asdf cffi iterate trivial-garbage +cl-gopher cl-gopher cl-gopher asdf bordeaux-threads drakma flexi-streams quri split-sequence usocket +cl-gpio cl-gpio cl-gpio asdf cffi documentation-utils +cl-grace cl-grace cl-grace asdf cl-fad +cl-graph cl-graph cl-graph asdf-system-connections cl-containers metabang-bind metatilities-base +cl-graph cl-graph+hu.dwim.graphviz cl-graph+hu.dwim.graphviz cl-graph hu.dwim.graphviz +cl-graph cl-graph cl-graph/with-cl-mathstats cl-graph cl-mathstats +cl-graph cl-graph cl-graph/with-dynamic-classes cl-graph dynamic-classes +cl-graph cl-graph cl-graph/with-metacopy cl-graph metacopy +cl-graph cl-graph cl-graph/with-moptilities cl-graph moptilities +cl-gravatar gravatar gravatar babel cl-json drakma md5 puri +cl-graylog graylog graylog asdf babel cl-json local-time salza2 trivial-backtrace usocket +cl-graylog graylog-log5 graylog-log5 asdf graylog log5 +cl-grnm cl-grnm cl-grnm asdf +cl-groupby groupby groupby +cl-growl cl-growl cl-growl flexi-streams ironclad trivial-utf-8 usocket +cl-gss cl-gss cl-gss asdf cffi cffi-grovel trivial-garbage trivial-utf-8 +cl-gtk2 cl-gtk2-cairo cl-gtk2-cairo cffi cl-cairo2 cl-gtk2-gdk cl-gtk2-glib cl-gtk2-gtk iterate +cl-gtk2 cl-gtk2-gdk cl-gtk2-gdk cffi cl-gtk2-glib cl-gtk2-pango +cl-gtk2 cl-gtk2-glib cl-gtk2-glib bordeaux-threads cffi closer-mop iterate trivial-garbage +cl-gtk2 cl-gtk2-gtk cl-gtk2-gtk bordeaux-threads cffi cl-gtk2-gdk cl-gtk2-glib cl-gtk2-pango iterate +cl-gtk2 cl-gtk2-pango cl-gtk2-pango cl-gtk2-glib iterate +cl-hamcrest hamcrest hamcrest asdf +cl-haml cl-haml cl-haml asdf cl-who +cl-haml cl-haml cl-haml-test cl-haml cl-test-more +cl-hamt cl-hamt cl-hamt cl-murmurhash +cl-hamt cl-hamt-examples cl-hamt-examples cl-hamt cl-ppcre drakma +cl-hamt cl-hamt-test cl-hamt-test cl-hamt fiveam +cl-hash-table-destructuring cl-hash-table-destructuring cl-hash-table-destructuring prove-asdf +cl-hash-table-destructuring cl-hash-table-destructuring cl-hash-table-destructuring-test cl-hash-table-destructuring prove prove-asdf +cl-hash-util cl-hash-util cl-hash-util asdf +cl-hash-util cl-hash-util-test cl-hash-util-test asdf cl-hash-util fiveam +cl-heap cl-heap cl-heap +cl-heap cl-heap-tests cl-heap-tests cl-heap xlunit +cl-heredoc cl-heredoc cl-heredoc +cl-heredoc cl-heredoc-test cl-heredoc-test cl-heredoc stefil +cl-html-diff cl-html-diff cl-html-diff cl-difflib +cl-html-parse cl-html-parse cl-html-parse +cl-html5-parser cl-html5-parser cl-html5-parser asdf cl-ppcre flexi-streams string-case +cl-html5-parser cl-html5-parser-cxml cl-html5-parser-cxml asdf cl-html5-parser cxml +cl-html5-parser cl-html5-parser-tests cl-html5-parser-tests asdf cl-html5-parser json-streams split-sequence stefil +cl-htmlprag cl-htmlprag cl-htmlprag alexandria optima parse-number +cl-httpsqs cl-httpsqs cl-httpsqs asdf drakma +cl-hue cl-hue cl-hue alexandria drakma yason +cl-i18n cl-i18n cl-i18n alexandria asdf babel cl-ppcre-unicode +cl-iconv iconv iconv cffi cffi-grovel +cl-inflector cl-inflector cl-inflector alexandria cl-ppcre +cl-inflector cl-inflector cl-inflector-test cl-inflector lisp-unit2 +cl-influxdb cl-influxdb cl-influxdb asdf cl-annot cl-json do-urlencode drakma flexi-streams usocket +cl-inotify cl-inotify cl-inotify asdf binary-types cffi cffi-grovel iolib iolib.asdf iolib.conf iolib.grovel osicat trivial-utf-8 +cl-inotify cl-inotify-tests cl-inotify-tests asdf cl-inotify fiveam +cl-intbytes cl-intbytes cl-intbytes fast-io +cl-intbytes cl-intbytes-test cl-intbytes-test cl-intbytes prove prove-asdf +cl-interpol cl-interpol cl-interpol asdf cl-unicode named-readtables +cl-interpol cl-interpol cl-interpol-test cl-interpol flexi-streams +cl-ipfs-api2 cl-ipfs-api2 cl-ipfs-api2 arnesi asdf drakma uiop yason +cl-irc cl-irc cl-irc flexi-streams split-sequence usocket +cl-irc cl-irc-test cl-irc-test cl-irc rt split-sequence +cl-irregsexp cl-irregsexp cl-irregsexp alexandria +cl-isaac cl-isaac cl-isaac +cl-iterative cl-iterative cl-iterative alexandria optima +cl-iterative cl-iterative-tests cl-iterative-tests cl-iterative fiveam +cl-itertools cl-itertools cl-itertools alexandria cl-coroutine iterate +cl-itertools cl-itertools cl-itertools-tests cl-itertools fiveam iterate +cl-ixf ixf ixf alexandria asdf babel cl-ppcre ieee-floats local-time md5 split-sequence +cl-jpeg cl-jpeg cl-jpeg +cl-jpl-util jpl-util jpl-util +cl-json cl-json cl-json +cl-json cl-json cl-json.test cl-json fiveam +cl-json-helper cl-json-helper cl-json-helper asdf cl-json +cl-json-pointer cl-json-pointer cl-json-pointer alexandria asdf closer-mop +cl-json-pointer cl-json-pointer cl-json-pointer/core alexandria closer-mop +cl-json-pointer cl-json-pointer cl-json-pointer/st-json-support alexandria closer-mop st-json +cl-json-pointer cl-json-pointer cl-json-pointer/synonyms cl-json-pointer +cl-json-template json-template json-template +cl-jsx cl-jsx cl-jsx cl-who esrap named-readtables +cl-jsx cl-jsx-test cl-jsx-test cl-jsx prove prove-asdf +cl-junit-xml cl-junit-xml cl-junit-xml alexandria cxml iterate +cl-junit-xml cl-junit-xml.lisp-unit cl-junit-xml.lisp-unit alexandria cl-junit-xml cl-ppcre iterate lisp-unit +cl-junit-xml cl-junit-xml.lisp-unit2 cl-junit-xml.lisp-unit2 alexandria cl-junit-xml cl-ppcre iterate lisp-unit2 +cl-junit-xml cl-junit-xml cl-junit-xml.test cl-junit-xml lisp-unit2 +cl-just-getopt-parser just-getopt-parser just-getopt-parser asdf +cl-k8055 cl-k8055 cl-k8055 asdf cffi cl-ppcre documentation-utils trivial-features +cl-kanren cl-kanren cl-kanren alexandria asdf +cl-kanren cl-kanren-test cl-kanren-test alexandria asdf cl-kanren clunit +cl-kanren-trs kanren-trs kanren-trs +cl-kanren-trs kanren-trs-test kanren-trs-test kanren-trs +cl-keycloak cl-keycloak cl-keycloak asdf drakma flexi-streams yason +cl-kraken cl-kraken cl-kraken asdf +cl-ksuid cl-ksuid cl-ksuid babel ironclad prove prove-asdf +cl-ksuid cl-ksuid cl-ksuid-test cl-ksuid prove prove-asdf +cl-kyoto-cabinet cl-kyoto-cabinet cl-kyoto-cabinet asdf cffi +cl-l10n cl-l10n cl-l10n alexandria cl-fad cl-l10n-cldr cl-ppcre closer-mop cxml flexi-streams iterate local-time metabang-bind +cl-l10n cl-l10n cl-l10n/test cl-l10n hu.dwim.stefil parse-number +cl-l10n-cldr cl-l10n-cldr cl-l10n-cldr +cl-langutils langutils langutils s-xml-rpc stdutils +cl-las cl-las cl-las asdf binary-io +cl-lastfm cl-lastfm cl-lastfm cxml-stp drakma trivial-utf-8 url-rewrite +cl-lastfm cl-lastfm-test cl-lastfm-test cl-lastfm lisp-unit +cl-launch cl-launch cl-launch asdf +cl-ledger cl-ledger cl-ledger asdf cambl cl-ppcre local-time periods-series +cl-lex cl-lex cl-lex cl-ppcre +cl-lexer cl-lexer cl-lexer asdf regex +cl-libevent2 cl-libevent2 cl-libevent2 asdf cffi +cl-libevent2 cl-libevent2-ssl cl-libevent2-ssl asdf cffi cl-libevent2 +cl-libfarmhash cl-libfarmhash cl-libfarmhash cffi cffi-libffi +cl-libhoedown cl-libhoedown cl-libhoedown cffi +cl-libiio cl-libiio cl-libiio asdf cffi +cl-libpuzzle cl-libpuzzle cl-libpuzzle cffi +cl-libpuzzle cl-libpuzzle-test cl-libpuzzle-test cl-libpuzzle cl-test-more +cl-libssh2 libssh2 libssh2 babel cffi cffi-grovel cl-fad hu.dwim.logger split-sequence trivial-gray-streams usocket +cl-libssh2 libssh2.test libssh2.test hu.dwim.stefil libssh2 +cl-libsvm cl-liblinear cl-liblinear cffi trivial-garbage +cl-libsvm cl-libsvm cl-libsvm cffi trivial-garbage +cl-libsvm-format cl-libsvm-format cl-libsvm-format alexandria asdf +cl-libsvm-format cl-libsvm-format-test cl-libsvm-format-test asdf cl-libsvm-format prove prove-asdf +cl-libusb cl-libusb cl-libusb asdf libusb-ffi trivial-garbage +cl-libusb libusb-ffi libusb-ffi asdf cffi cffi-grovel static-vectors +cl-libuv cl-libuv cl-libuv alexandria asdf cffi cffi-grovel +cl-libxml2 cl-libxml2 cl-libxml2 alexandria cffi flexi-streams garbage-pools iterate metabang-bind puri +cl-libxml2 cl-libxml2 cl-libxml2-test cl-libxml2 lift +cl-libxml2 xfactory xfactory cl-libxml2 +cl-libxml2 xfactory xfactory-test lift xfactory +cl-libxml2 xoverlay xoverlay cl-libxml2 +cl-libyaml cl-libyaml cl-libyaml cffi +cl-libyaml cl-libyaml-test cl-libyaml-test cl-libyaml fiveam +cl-locale cl-locale cl-locale anaphora arnesi cl-annot cl-syntax cl-syntax-annot +cl-locale cl-locale-syntax cl-locale-syntax cl-locale cl-syntax +cl-locale cl-locale-test cl-locale-test cl-locale cl-syntax flexi-streams prove prove-asdf +cl-locatives cl-locatives cl-locatives asdf +cl-log cl-log cl-log +cl-log cl-log-test cl-log-test cl-log eos +cl-logic cl-logic cl-logic alexandria quine-mccluskey +cl-logic cl-logic quine-mccluskey +cl-ltsv cl-ltsv cl-ltsv +cl-ltsv cl-ltsv-test cl-ltsv-test cl-ltsv cl-test-more +cl-lzlib lzlib lzlib asdf cffi cl-octet-streams +cl-lzlib lzlib-tests lzlib-tests asdf cl-octet-streams fiveam lzlib uiop +cl-lzma cl-lzma cl-lzma asdf cffi cl-autowrap fast-io static-vectors +cl-m4 cl-m4 cl-m4 alexandria cffi cffi-grovel cl-fad cl-ppcre external-program graylex +cl-m4 cl-m4-test cl-m4-test cl-heredoc cl-m4 hu.dwim.stefil +cl-mango cl-mango cl-mango asdf drakma json-mop yason +cl-markdown cl-markdown cl-markdown anaphora asdf cl-containers cl-ppcre dynamic-classes metabang-bind metatilities-base +cl-markdown cl-markdown-comparisons cl-markdown-comparisons asdf cl-html-diff cl-markdown html-encode lift lml2 trivial-shell +cl-markdown cl-markdown-test cl-markdown-test asdf cl-markdown lift trivial-shell +cl-markless cl-markless cl-markless asdf documentation-utils trivial-indent +cl-markless cl-markless-epub cl-markless-epub asdf babel cl-markless-plump trivial-gray-streams trivial-indent trivial-mimes uiop zip +cl-markless cl-markless-markdown cl-markless-markdown 3bmd 3bmd-ext-code-blocks asdf cl-markless +cl-markless cl-markless-plump cl-markless-plump asdf cl-markless plump-dom +cl-markless cl-markless-standalone cl-markless-standalone asdf cl-markless cl-markless-epub cl-markless-markdown cl-markless-plump command-line-arguments +cl-markless cl-markless-test cl-markless-test asdf cl-markless parachute +cl-marklogic cl-marklogic cl-marklogic alexandria drakma fiveam local-time +cl-marklogic ml-dsl ml-dsl cl-marklogic +cl-marklogic ml-optimizer ml-optimizer cl-json cl-marklogic cl-opsresearch hunchentoot +cl-marklogic ml-test ml-test cl-marklogic fiveam ml-optimizer +cl-markup cl-markup cl-markup +cl-markup cl-markup-test cl-markup-test cl-markup cl-test-more +cl-marshal marshal marshal asdf +cl-marshal marshal-tests marshal-tests asdf marshal xlunit +cl-match cl-match cl-match standard-cl +cl-match cl-match-test cl-match-test cl-match pcl-unit-test +cl-match pcl-unit-test pcl-unit-test standard-cl +cl-match standard-cl standard-cl +cl-mathstats cl-mathstats cl-mathstats cl-containers metatilities-base +cl-mathstats cl-mathstats-test cl-mathstats-test cl-mathstats lift +cl-maxsat cl-maxsat cl-maxsat alexandria asdf cl-sat iterate trivia +cl-maxsat cl-maxsat.test cl-maxsat.test asdf cl-maxsat fiveam +cl-mecab cl-mecab cl-mecab asdf cffi split-sequence +cl-mecab cl-mecab-test cl-mecab-test asdf cl-mecab prove prove-asdf +cl-mechanize cl-mechanize cl-mechanize asdf cl-ppcre closure-html cxml-stp drakma puri +cl-mediawiki cl-mediawiki cl-mediawiki alexandria cxml drakma +cl-mediawiki cl-mediawiki-test cl-mediawiki-test cl-mediawiki lisp-unit2 +cl-memcached cl-memcached cl-memcached babel pooler split-sequence usocket +cl-messagepack cl-messagepack cl-messagepack asdf babel closer-mop flexi-streams +cl-messagepack cl-messagepack-tests cl-messagepack-tests asdf cl-json cl-messagepack fiveam +cl-messagepack-rpc cl-messagepack-rpc cl-messagepack-rpc alexandria cffi cl-async cl-libuv cl-messagepack flexi-streams trivial-backtrace +cl-messagepack-rpc cl-messagepack-rpc-tests cl-messagepack-rpc-tests cl-messagepack-rpc fiveam +cl-migrations cl-migrations cl-migrations clsql +cl-mime cl-mime cl-mime cl-base64 cl-ppcre cl-qprint +cl-mixed cl-mixed cl-mixed alexandria asdf cffi documentation-utils trivial-features trivial-garbage +cl-mlep mlep mlep asdf +cl-mlep mlep-add mlep-add asdf cffi cl-num-utils lla mlep +cl-mock cl-mock cl-mock cl-mock-basic optima +cl-mock cl-mock-basic cl-mock-basic alexandria closer-mop +cl-mock cl-mock-tests cl-mock-tests cl-mock cl-mock-tests-basic +cl-mock cl-mock-tests-basic cl-mock-tests-basic cl-mock-basic fiveam +cl-modlisp modlisp modlisp kmrcl +cl-monad-macros cl-monad-macros cl-monad-macros +cl-moneris cl-moneris cl-moneris drakma s-xml +cl-moneris cl-moneris-test cl-moneris-test cl-moneris eos +cl-mongo cl-mongo cl-mongo babel bordeaux-threads documentation-template lisp-unit parenscript split-sequence usocket uuid +cl-mongo-id cl-mongo-id cl-mongo-id asdf bordeaux-threads local-time md5 +cl-monitors cl-monitors cl-monitors asdf cffi documentation-utils trivial-features trivial-garbage +cl-mop cl-mop cl-mop +cl-moss cl-moss cl-moss usocket +cl-mount-info cl-mount-info cl-mount-info alexandria asdf cffi cl-ppcre +cl-mpg123 cl-mpg123 cl-mpg123 asdf cffi documentation-utils trivial-features trivial-garbage +cl-mpg123 cl-mpg123-example cl-mpg123-example asdf cl-mpg123 cl-out123 verbose +cl-mpi cl-mpi cl-mpi alexandria asdf cffi cl-mpi-asdf-integration static-vectors uiop +cl-mpi cl-mpi-asdf-integration cl-mpi-asdf-integration asdf cffi-grovel cffi-toolchain +cl-mpi cl-mpi-examples cl-mpi-examples asdf cl-mpi cl-mpi-asdf-integration uiop +cl-mpi cl-mpi-extensions cl-mpi-extensions asdf cffi cl-conspack cl-mpi +cl-mpi cl-mpi-test-suite cl-mpi-test-suite asdf cffi cl-mpi fiveam +cl-mssql mssql mssql asdf cffi garbage-pools iterate parse-number +cl-mtgnet cl-mtgnet cl-mtgnet asdf blackbird cl-json cl-netstring+ trivial-utf-8 +cl-mtgnet cl-mtgnet-async cl-mtgnet-async asdf cl-async cl-mtgnet +cl-mtgnet cl-mtgnet-sync cl-mtgnet-sync asdf cl-mtgnet usocket +cl-murmurhash cl-murmurhash cl-murmurhash asdf babel +cl-murmurhash cl-murmurhash cl-murmurhash/test cl-murmurhash fiveam +cl-mustache cl-mustache cl-mustache uiop +cl-mustache cl-mustache-test cl-mustache-test cl-mustache prove prove-asdf +cl-muth cl-muth cl-muth alexandria asdf bordeaux-threads trivial-features +cl-mw cl-mw cl-mw alexandria cffi cl-ppcre hu.dwim.serializer iolib +cl-mw cl-mw.examples.argument-processing cl-mw.examples.argument-processing cl-mw +cl-mw cl-mw.examples.hello-world cl-mw.examples.hello-world cl-mw +cl-mw cl-mw.examples.higher-order cl-mw.examples.higher-order cl-mw +cl-mw cl-mw.examples.monte-carlo-pi cl-mw.examples.monte-carlo-pi cl-mw +cl-mw cl-mw.examples.ping cl-mw.examples.ping cl-mw +cl-mw cl-mw.examples.with-task-policy cl-mw.examples.with-task-policy cl-mw +cl-mysql cl-mysql cl-mysql cffi +cl-mysql cl-mysql-test cl-mysql-test cl-mysql stefil +cl-naive-store cl-naive-data-type-defs cl-naive-data-type-defs asdf cl-naive-store +cl-naive-store cl-naive-data-types cl-naive-data-types asdf cl-naive-store +cl-naive-store cl-naive-indexed cl-naive-indexed asdf cl-naive-store +cl-naive-store cl-naive-items cl-naive-items asdf cl-naive-data-type-defs cl-naive-data-types cl-naive-indexed cl-naive-store +cl-naive-store cl-naive-store cl-naive-store asdf cl-fad local-time split-sequence uuid +cl-naive-store cl-naive-store-tests cl-naive-store-tests asdf cl-fad cl-naive-data-type-defs cl-naive-data-types cl-naive-indexed cl-naive-items cl-naive-store +cl-ncurses cl-ncurses cl-ncurses uffi +cl-neo4j cl-neo4j cl-neo4j alexandria anaphora babel cl-json cl-ppcre drakma split-sequence +cl-neo4j cl-neo4j cl-neo4j.tests cl-neo4j fiveam +cl-neovim cl-neovim cl-neovim asdf babel cl-messagepack-rpc form-fiddle split-sequence vom +cl-netpbm cl-netpbm cl-netpbm asdf +cl-netpbm cl-netpbm cl-netpbm/test 1am cl-netpbm external-program +cl-netstring-plus cl-netstring+ cl-netstring+ flexi-streams trivial-utf-8 +cl-netstrings cl-netstrings cl-netstrings arnesi iterate +cl-ntp-client cl-ntp-client cl-ntp-client alexandria asdf usocket +cl-ntriples cl-ntriples cl-ntriples alexandria asdf +cl-num-utils cl-num-utils cl-num-utils alexandria anaphora array-operations cl-slice let-plus +cl-num-utils cl-num-utils cl-num-utils-tests cl-num-utils clunit +cl-nxt nxt nxt babel cffi static-vectors +cl-nxt nxt-proxy nxt-proxy nxt usocket +cl-oauth cl-oauth cl-oauth alexandria anaphora babel cl-base64 closer-mop drakma f-underscore hunchentoot ironclad puri split-sequence trivial-garbage +cl-oauth cl-oauth cl-oauth.tests cl-oauth fiveam +cl-oclapi cl-oclapi cl-oclapi alexandria asdf cffi cl-annot cl-reexport +cl-oclapi cl-oclapi-test cl-oclapi-test asdf cl-annot cl-oclapi prove prove-asdf +cl-octet-streams cl-octet-streams cl-octet-streams asdf trivial-gray-streams +cl-octet-streams cl-octet-streams cl-octet-streams/tests cl-octet-streams fiveam +cl-ode cl-ode cl-ode cffi +cl-odesk odesk odesk alexandria cl-ppcre drakma iterate md5 split-sequence +cl-ohm cl-ohm cl-ohm alexandria asdf cl-redis closer-mop +cl-ohm cl-ohm cl-ohm/test cl-ohm fiveam +cl-olefs cl-olefs cl-olefs +cl-one-time-passwords cl-one-time-passwords cl-one-time-passwords ironclad +cl-one-time-passwords cl-one-time-passwords-test cl-one-time-passwords-test cl-one-time-passwords fiveam +cl-online-learning cl-online-learning cl-online-learning asdf cl-libsvm-format cl-store +cl-online-learning cl-online-learning-test cl-online-learning-test asdf cl-online-learning prove prove-asdf +cl-openal cl-alc cl-alc cffi cl-openal +cl-openal cl-alut cl-alut cffi cl-openal +cl-openal cl-openal cl-openal cffi +cl-openal cl-openal-examples cl-openal-examples cffi cl-alc cl-alut cl-openal +cl-opengl cl-glu cl-glu asdf cffi cl-opengl +cl-opengl cl-glut cl-glut alexandria asdf cffi cl-opengl +cl-opengl cl-glut-examples cl-glut-examples asdf cffi cl-glu cl-glut cl-opengl +cl-opengl cl-opengl cl-opengl alexandria asdf cffi float-features +cl-opengl cl-opengl cl-opengl/es2 alexandria cffi float-features +cl-openstack-client cl-openstack-client cl-openstack-client alexandria asdf cl-json drakma local-time uri-template +cl-openstack-client cl-openstack-client-test cl-openstack-client-test asdf chunga cl-openstack-client cl-ppcre drakma fiveam flexi-streams local-time trivial-gray-streams +cl-opsresearch cl-opsresearch cl-opsresearch cffi +cl-opsresearch or-cluster or-cluster cl-opsresearch drakma hunchentoot +cl-opsresearch or-fann or-fann cffi cl-opsresearch +cl-opsresearch or-glpk or-glpk cffi cl-opsresearch +cl-opsresearch or-gsl or-gsl cffi cl-opsresearch +cl-opsresearch or-test or-test cl-opsresearch fiveam or-fann or-glpk or-gsl +cl-org-mode cl-org-mode cl-org-mode alexandria closer-mop +cl-out123 cl-out123 cl-out123 asdf bordeaux-threads cffi documentation-utils trivial-features trivial-garbage +cl-pack cl-pack cl-pack asdf ieee-floats +cl-pack cl-pack cl-pack-test cl-pack +cl-package-locks cl-package-locks cl-package-locks +cl-pango cl-pango cl-pango cffi cl-cairo2 xmls +cl-parallel cl-parallel cl-parallel bordeaux-threads +cl-parser-combinators parser-combinators parser-combinators alexandria iterate +cl-parser-combinators parser-combinators-cl-ppcre parser-combinators-cl-ppcre alexandria cl-ppcre iterate parser-combinators +cl-parser-combinators parser-combinators-debug parser-combinators-debug cl-containers parser-combinators +cl-parser-combinators parser-combinators-tests parser-combinators-tests alexandria hu.dwim.stefil infix iterate parser-combinators +cl-pass cl-pass cl-pass asdf ironclad split-sequence trivial-utf-8 +cl-pass cl-pass-test cl-pass-test asdf cl-pass fiveam +cl-password-store cl-password-store cl-password-store asdf clsql ironclad +cl-password-store cl-password-store cl-password-store-test cl-password-store fiveam +cl-pattern cl-pattern cl-pattern alexandria cl-annot cl-syntax cl-syntax-annot +cl-pattern cl-pattern-benchmark cl-pattern-benchmark cl-pattern +cl-patterns cl-patterns cl-patterns alexandria asdf bordeaux-threads closer-mop dissect local-time named-readtables split-sequence +cl-patterns cl-patterns cl-patterns/debug cl-patterns +cl-patterns cl-patterns cl-patterns/midifile cl-patterns midi +cl-patterns cl-patterns cl-patterns/supercollider cl-collider cl-patterns +cl-patterns cl-patterns cl-patterns/tests cl-org-mode cl-patterns cl-ppcre fiveam +cl-paymill cl-paymill cl-paymill cl+ssl drakma st-json +cl-paypal cl-paypal cl-paypal cl-ppcre drakma hunchentoot +cl-pcg cl-pcg cl-pcg asdf +cl-pcg cl-pcg.test cl-pcg.test 1am asdf cl-pcg +cl-pdf cl-pdf cl-pdf asdf iterate uiop zpb-ttf +cl-pdf cl-pdf-parser cl-pdf-parser asdf cl-pdf +cl-performance-tuning-helper cl-performance-tuning-helper cl-performance-tuning-helper +cl-performance-tuning-helper cl-performance-tuning-helper-test cl-performance-tuning-helper-test cl-performance-tuning-helper rt +cl-permutation cl-permutation cl-permutation alexandria asdf bordeaux-fft cl-algebraic-data-type closer-mop iterate uiop +cl-permutation cl-permutation-examples cl-permutation-examples alexandria asdf cl-permutation +cl-permutation cl-permutation-tests cl-permutation-tests asdf cl-permutation cl-permutation-examples fiasco +cl-photo cl-photo cl-photo kmrcl +cl-photo cl-photo-tests cl-photo-tests cl-photo rt +cl-piglow cl-piglow cl-piglow asdf osicat +cl-pixman pixman pixman alexandria cffi trivial-garbage +cl-plplot cl-plplot cl-plplot asdf cffi +cl-plplot cl-plplot plplot-examples cl-plplot png +cl-plumbing cl-plumbing cl-plumbing asdf bordeaux-threads iterate trivial-gray-streams +cl-plumbing cl-plumbing-test cl-plumbing-test asdf cl-plumbing iterate stefil +cl-ply cl-ply cl-ply cl-pattern cl-ppcre +cl-ply cl-ply-test cl-ply-test cl-ply prove prove-asdf +cl-png bmp-test bmp-test asdf png +cl-png image-test image-test asdf png +cl-png ops-test ops-test asdf png +cl-png png png asdf cffi cffi-grovel +cl-png png-test png-test asdf png +cl-poker-eval cl-poker-eval cl-poker-eval +cl-pop cl-pop cl-pop cl-ppcre usocket +cl-portaudio cl-portaudio cl-portaudio cffi ffa +cl-portaudio cl-portaudio cl-portaudio/doc atdoc cl-portaudio +cl-portaudio cl-portaudio cl-portaudio/tests cl-portaudio +cl-portmanteau portmanteau portmanteau asdf vom +cl-portmanteau portmanteau-tests portmanteau-tests asdf fiveam portmanteau +cl-postgres-datetime cl-postgres-datetime cl-postgres-datetime asdf cl-postgres local-time simple-date +cl-postgres-plus-uuid cl-postgres-plus-uuid cl-postgres-plus-uuid asdf cl-postgres uuid +cl-ppcre cl-ppcre cl-ppcre asdf +cl-ppcre cl-ppcre cl-ppcre-test cl-ppcre flexi-streams +cl-ppcre cl-ppcre-unicode cl-ppcre-unicode asdf cl-ppcre cl-unicode +cl-ppcre cl-ppcre-unicode cl-ppcre-unicode-test cl-ppcre-test cl-ppcre-unicode +cl-prevalence cl-prevalence cl-prevalence asdf s-sysdeps s-xml +cl-prevalence cl-prevalence-test cl-prevalence-test asdf cl-prevalence fiveam +cl-primality cl-primality cl-primality iterate +cl-primality cl-primality-test cl-primality-test cl-primality iterate stefil +cl-prime-maker cl-prime-maker cl-prime-maker +cl-progress-bar cl-progress-bar cl-progress-bar asdf bordeaux-threads documentation-utils-extensions +cl-proj cl-proj cl-proj asdf cffi cffi-grovel parse-number trivial-garbage +cl-project cl-project cl-project asdf cl-emb cl-ppcre local-time prove uiop +cl-project cl-project-test cl-project-test asdf caveman2 cl-project prove prove-asdf uiop +cl-prolog2 cl-prolog2 cl-prolog2 alexandria asdf external-program trivia trivia.quasiquote trivial-garbage +cl-prolog2 cl-prolog2.bprolog cl-prolog2.bprolog asdf cl-prolog2 +cl-prolog2 cl-prolog2.bprolog.test cl-prolog2.bprolog.test asdf cl-prolog2.bprolog cl-prolog2.test +cl-prolog2 cl-prolog2.gprolog cl-prolog2.gprolog asdf cl-prolog2 +cl-prolog2 cl-prolog2.gprolog.test cl-prolog2.gprolog.test asdf cl-prolog2.gprolog cl-prolog2.test +cl-prolog2 cl-prolog2.swi cl-prolog2.swi asdf cl-prolog2 +cl-prolog2 cl-prolog2.swi.test cl-prolog2.swi.test asdf cl-prolog2.swi cl-prolog2.test +cl-prolog2 cl-prolog2.test cl-prolog2.test asdf cl-prolog2 fiveam iterate +cl-prolog2 cl-prolog2.xsb cl-prolog2.xsb asdf cl-prolog2 +cl-prolog2 cl-prolog2.xsb.test cl-prolog2.xsb.test asdf cl-prolog2.test cl-prolog2.xsb +cl-prolog2 cl-prolog2.yap cl-prolog2.yap asdf cl-prolog2 +cl-prolog2 cl-prolog2.yap.test cl-prolog2.yap.test asdf cl-prolog2.test cl-prolog2.yap +cl-protobufs cl-protobufs cl-protobufs asdf babel closer-mop trivial-garbage +cl-protobufs cl-protobufs-tests cl-protobufs-tests asdf cl-protobufs +cl-pslib cl-pslib cl-pslib alexandria asdf cffi cl-colors2 cl-ppcre-unicode +cl-pslib-barcode cl-pslib-barcode cl-pslib-barcode alexandria asdf cffi cl-colors2 cl-ppcre-unicode cl-pslib +cl-punch cl-punch cl-punch asdf cl-syntax +cl-punch cl-punch-test cl-punch-test asdf cl-punch prove prove-asdf +cl-python clpython clpython asdf cl-fad closer-mop yacc +cl-python clpython clpython/basic closer-mop +cl-python clpython clpython/compiler cl-fad closer-mop yacc +cl-python clpython clpython/contrib cl-fad closer-mop yacc +cl-python clpython clpython/lib cl-fad closer-mop yacc +cl-python clpython clpython/parser closer-mop yacc +cl-python clpython clpython/runtime cl-fad closer-mop +cl-python clpython clpython/test clpython ptester +cl-qprint cl-qprint cl-qprint flexi-streams +cl-qrencode cl-qrencode cl-qrencode asdf zpng +cl-qrencode cl-qrencode-test cl-qrencode-test asdf cl-qrencode lisp-unit +cl-quickcheck cl-quickcheck cl-quickcheck asdf +cl-rabbit cl-rabbit cl-rabbit alexandria asdf babel cffi cffi-grovel cffi-libffi cl-ppcre +cl-rabbit cl-rabbit-tests cl-rabbit-tests asdf cl-rabbit fiveam +cl-rail rail rail +cl-rail rail rail-test fiasco rail +cl-randist cl-randist cl-randist +cl-random cl-random cl-random alexandria anaphora array-operations asdf cl-num-utils cl-rmath cl-slice gsll let-plus lla +cl-random cl-random cl-random-tests cl-random clunit +cl-random-forest cl-random-forest cl-random-forest alexandria asdf cl-libsvm-format cl-online-learning lparallel +cl-random-forest cl-random-forest-test cl-random-forest-test asdf cl-random-forest prove prove-asdf trivial-garbage uiop +cl-rcfiles com.dvlsoft.rcfiles com.dvlsoft.rcfiles +cl-rdfxml cl-rdfxml cl-rdfxml cxml puri +cl-rdkafka cl-rdkafka cl-rdkafka asdf cffi cffi-grovel trivial-garbage +cl-rdkafka cl-rdkafka cl-rdkafka/test 1am babel cl-rdkafka +cl-readline cl-readline cl-readline alexandria asdf cffi +cl-recaptcha cl-recaptcha cl-recaptcha cl-ppcre drakma flexi-streams jsown +cl-reddit cl-reddit cl-reddit asdf drakma yason +cl-redis cl-redis cl-redis asdf babel cl-ppcre flexi-streams rutils usocket +cl-redis cl-redis cl-redis-test bordeaux-threads cl-redis flexi-streams should-test +cl-reexport cl-reexport cl-reexport alexandria +cl-reexport cl-reexport-test cl-reexport-test cl-reexport cl-test-more +cl-rethinkdb cl-rethinkdb cl-rethinkdb blackbird cl-async cl-base64 cl-hash-util cl-ppcre event-glue fast-io jonathan local-time vom +cl-rethinkdb cl-rethinkdb-test cl-rethinkdb-test blackbird cl-async cl-ppcre cl-rethinkdb fiveam +cl-rfc2047 cl-rfc2047 cl-rfc2047 babel cl-base64 +cl-rfc2047 cl-rfc2047-test cl-rfc2047-test cl-ppcre cl-rfc2047 lift +cl-riff cl-riff cl-riff alexandria asdf +cl-rlimit cl-rlimit cl-rlimit cffi cffi-grovel +cl-rmath cl-rmath cl-rmath asdf cffi +cl-routes routes routes iterate puri split-sequence +cl-routes routes routes-test lift routes +cl-rrd cl-rrd cl-rrd cffi +cl-rrt cl-rrt cl-rrt alexandria anaphora cl-syntax-annot iterate +cl-rrt cl-rrt.benchmark cl-rrt.benchmark cl-rrt cl-rrt.rtree cl-rrt.test fiveam vecto +cl-rrt cl-rrt.rtree cl-rrt.rtree alexandria anaphora cl-rrt cl-syntax-annot iterate optima spatial-trees spatial-trees.nns +cl-rrt cl-rrt.test cl-rrt.test cl-rrt cl-rrt.rtree fiveam vecto +cl-rss rss rss aserve kmrcl xmls +cl-rsvg2 cl-rsvg2 cl-rsvg2 cffi cl-cairo2 cl-gtk2-glib trivial-gray-streams +cl-rsvg2 cl-rsvg2-pixbuf cl-rsvg2-pixbuf cl-gtk2-gdk cl-rsvg2 +cl-rsvg2 cl-rsvg2-test cl-rsvg2-test asdf cffi cl-rsvg2 eos +cl-rules cl-rules cl-rules alexandria asdf cl-yaml +cl-rules cl-rules-test cl-rules-test asdf cl-rules prove prove-asdf +cl-s3 cl-s3 cl-s3 ironclad s-base64 s-http-client s-utils s-xml +cl-sam cl-sam cl-sam deoxybyte-gzip deoxybyte-systems deoxybyte-unix +cl-sam cl-sam-test cl-sam-test cl-sam deoxybyte-io lift +cl-sandbox cl-sandbox cl-sandbox asdf +cl-sandbox cl-sandbox cl-sandbox/tests cl-sandbox fiveam +cl-sane sane sane cffi iterate trivial-gray-streams +cl-sanitize sanitize sanitize cl-libxml2 +cl-sanitize sanitize sanitize-test eos sanitize +cl-sasl cl-sasl cl-sasl asdf ironclad +cl-sat cl-sat cl-sat alexandria asdf iterate trivia trivial-features +cl-sat cl-sat.test cl-sat.test asdf cl-sat fiveam +cl-sat.glucose cl-sat.glucose cl-sat.glucose alexandria asdf cl-sat iterate trivia trivial-package-manager +cl-sat.glucose cl-sat.glucose.test cl-sat.glucose.test asdf cl-sat.glucose fiveam +cl-sat.minisat cl-sat.minisat cl-sat.minisat alexandria asdf cl-sat iterate trivia trivial-package-manager +cl-sat.minisat cl-sat.minisat.test cl-sat.minisat.test asdf cl-sat.minisat fiveam +cl-scram cl-scram cl-scram cl-base64 cl-sasl ironclad secure-random split-sequence +cl-scribd cl-scribd cl-scribd cxml drakma ironclad +cl-scripting cl-scripting cl-scripting +cl-scripting cl-scripting cl-scripting/test +cl-scrobbler cl-scrobbler cl-scrobbler arnesi cl-store drakma flexi-streams md5 st-json +cl-scrobbler cl-scrobbler cl-scrobbler-tests cl-scrobbler fiveam +cl-scsu cl-scsu cl-scsu alexandria asdf +cl-scsu cl-scsu-test cl-scsu-test 1am alexandria asdf cl-scsu +cl-sdl2 sdl2 sdl2 alexandria asdf cl-autowrap cl-plus-c cl-ppcre trivial-channels trivial-features +cl-sdl2 sdl2 sdl2/examples cl-opengl sdl2 +cl-sdl2-image sdl2-image sdl2-image alexandria asdf cl-autowrap defpackage-plus sdl2 +cl-sdl2-mixer sdl2-mixer sdl2-mixer alexandria asdf cl-autowrap defpackage-plus sdl2 trivial-garbage +cl-sdl2-ttf sdl2-ttf sdl2-ttf alexandria asdf cffi-libffi cl-autowrap defpackage-plus sdl2 trivial-garbage +cl-sdl2-ttf sdl2-ttf-examples sdl2-ttf-examples alexandria asdf cl-opengl mathkit sdl2 sdl2-ttf +cl-selenium selenium selenium cl-ppcre cxml drakma puri split-sequence +cl-selenium-webdriver cl-selenium cl-selenium alexandria asdf cl-json dexador quri split-sequence +cl-selenium-webdriver cl-selenium-test cl-selenium-test asdf cl-selenium prove prove-asdf +cl-sentiment cl-sentiment cl-sentiment cl-ppcre rt +cl-server-manager cl-server-manager cl-server-manager alexandria hunchentoot prepl swank +cl-shellwords cl-shellwords cl-shellwords cl-ppcre +cl-shellwords cl-shellwords-test cl-shellwords-test cl-shellwords prove +cl-shlex shlex shlex alexandria asdf cl-ppcre cl-unicode serapeum +cl-shlex shlex shlex/test fiveam shlex +cl-simple-concurrent-jobs cl-simple-concurrent-jobs cl-simple-concurrent-jobs bordeaux-threads chanl +cl-simple-fsm finite-state-machine finite-state-machine asdf +cl-simple-table cl-simple-table cl-simple-table +cl-singleton-mixin cl-singleton-mixin cl-singleton-mixin closer-mop metap +cl-singleton-mixin cl-singleton-mixin-test cl-singleton-mixin-test cl-singleton-mixin fiveam +cl-skip-list cl-skip-list cl-skip-list cffi +cl-skkserv cl-skkserv cl-skkserv alexandria asdf babel cl-ppcre drakma esrap flexi-streams jp-numeral named-readtables papyrus yason +cl-skkserv cl-skkserv cl-skkserv/cli alexandria cl-skkserv daemon unix-opts usocket usocket-server +cl-skkserv cl-skkserv cl-skkserv/core alexandria babel esrap named-readtables papyrus +cl-skkserv cl-skkserv cl-skkserv/google-ime alexandria babel drakma esrap flexi-streams named-readtables papyrus yason +cl-skkserv cl-skkserv cl-skkserv/mixed alexandria babel esrap named-readtables papyrus +cl-skkserv cl-skkserv cl-skkserv/skk alexandria babel cl-ppcre esrap jp-numeral named-readtables papyrus +cl-skkserv cl-skkserv cl-skkserv/tests 1am cl-skkserv flexi-streams +cl-sl4a cl-android cl-android cl-json usocket +cl-slice cl-slice cl-slice alexandria anaphora let-plus +cl-slice cl-slice cl-slice-tests cl-slice clunit +cl-slp cl-slp cl-slp cffi +cl-slug cl-slug cl-slug asdf cl-ppcre +cl-slug cl-slug-test cl-slug-test asdf cl-slug prove prove-asdf +cl-smt-lib cl-smt-lib cl-smt-lib asdf named-readtables +cl-smtp cl-smtp cl-smtp asdf cl+ssl cl-base64 flexi-streams trivial-gray-streams usocket +cl-soil cl-soil cl-soil asdf cffi cl-opengl documentation-utils +cl-soloud cl-soloud cl-soloud alexandria asdf cffi cl-mpg123 documentation-utils trivial-features trivial-garbage trivial-indent +cl-sophia cl-sophia cl-sophia alexandria cffi cl-fad +cl-sophia cl-sophia cl-sophia-test alexandria cl-fad cl-sophia lisp-unit +cl-spark cl-spark cl-spark +cl-spark cl-spark-test cl-spark-test cl-spark fiveam +cl-speedy-queue cl-speedy-queue cl-speedy-queue +cl-sphinx sphinx sphinx cl-fad closure-template colorize docutils +cl-spidev cl-spidev cl-spidev asdf cffi documentation-utils trivial-garbage +cl-splicing-macro cl-splicing-macro cl-splicing-macro +cl-sqlite sqlite sqlite asdf cffi iterate +cl-ssdb cl-ssdb cl-ssdb babel cl-ppcre flexi-streams parse-number rutils usocket +cl-ssdb cl-ssdb-test cl-ssdb-test cl-ssdb prove prove-asdf +cl-statsd cl-statsd cl-statsd alexandria bordeaux-threads cl-interpol local-time log4cl safe-queue trivial-utf-8 usocket +cl-statsd cl-statsd.test cl-statsd.test cl-statsd log4cl prove prove-asdf +cl-stdutils stdutils stdutils cl-fad cl-ppcre +cl-steamworks cl-steamworks cl-steamworks alexandria asdf babel cffi documentation-utils trivial-features trivial-garbage trivial-gray-streams +cl-steamworks cl-steamworks-generator cl-steamworks-generator alexandria asdf cffi cl-ppcre parse-number pathname-utils yason +cl-stomp cl-stomp cl-stomp asdf babel usocket +cl-stopwatch cl-stopwatch cl-stopwatch asdf +cl-store cl-store cl-store asdf +cl-store cl-store cl-store-tests cl-store rt +cl-str str str asdf cl-change-case cl-ppcre cl-ppcre-unicode +cl-str str.test str.test asdf prove prove-asdf str +cl-stream cl-stream cl-stream asdf +cl-strftime cl-strftime cl-strftime alexandria cl-ppcre local-time serapeum +cl-strftime cl-strftime cl-strftime/tests cffi cl-strftime fiveam uiop +cl-string-complete cl-string-complete cl-string-complete asdf +cl-string-match ascii-strings ascii-strings alexandria asdf babel +cl-string-match cl-string-match cl-string-match alexandria ascii-strings asdf iterate jpl-queues mgl-pax yacc +cl-string-match cl-string-match-test cl-string-match-test ascii-strings asdf cl-string-match lisp-unit simple-scanf +cl-string-match simple-scanf simple-scanf alexandria asdf iterate parse-float proc-parse +cl-strings cl-strings cl-strings asdf +cl-strings cl-strings cl-strings-tests cl-strings prove +cl-svg cl-svg cl-svg asdf +cl-svm cl-svm cl-svm +cl-swagger-codegen cl-swagger cl-swagger asdf cl-json cl-mustache cl-ppcre drakma +cl-sxml cl-sxml cl-sxml cxml +cl-sxml cl-sxml cl-sxml-test asdf cl-sxml fiveam flexi-streams uiop +cl-syntax cl-syntax cl-syntax named-readtables trivial-types +cl-syntax cl-syntax-annot cl-syntax-annot cl-annot cl-syntax +cl-syntax cl-syntax-anonfun cl-syntax-anonfun cl-anonfun cl-syntax +cl-syntax cl-syntax-clsql cl-syntax-clsql cl-syntax clsql +cl-syntax cl-syntax-fare-quasiquote cl-syntax-fare-quasiquote cl-syntax fare-quasiquote +cl-syntax cl-syntax-interpol cl-syntax-interpol cl-interpol cl-syntax +cl-syntax cl-syntax-markup cl-syntax-markup cl-markup cl-syntax +cl-syslog cl-syslog cl-syslog alexandria asdf babel cffi global-vars local-time split-sequence usocket +cl-table cl-table cl-table iterate +cl-tasukete cl-tasukete cl-tasukete asdf cl-annot cl-gists dissect jonathan local-time +cl-tasukete cl-tasukete-test cl-tasukete-test asdf cl-tasukete dissect prove prove-asdf +cl-tcod parse-rgb parse-rgb asdf cl-ppcre tcod +cl-tcod tcod tcod asdf cffi cffi-libffi defstar +cl-template cl-template cl-template +cl-template cl-template cl-template-tests cl-template fiveam +cl-tesseract cl-tesseract cl-tesseract cffi +cl-tetris3d cl-tetris3d cl-tetris3d asdf cl-glu cl-opengl iterate lispbuilder-sdl +cl-textmagic cl-textmagic cl-textmagic cl-json dexador +cl-textmagic cl-textmagic-test cl-textmagic-test cl-textmagic prove prove-asdf +cl-tga cl-tga cl-tga +cl-threadpool cl-threadpool cl-threadpool asdf bordeaux-threads queues.simple-cqueue verbose +cl-threadpool cl-threadpool-test cl-threadpool-test asdf bordeaux-threads lisp-unit queues.simple-cqueue verbose +cl-tidy cl-tidy cl-tidy cffi +cl-tiled cl-tiled cl-tiled alexandria asdf chipz cl-base64 cl-json nibbles parse-float split-sequence uiop xmls +cl-tk cl-tk cl-tk cffi +cl-tld cl-tld cl-tld +cl-tokyo-cabinet cl-tokyo-cabinet cl-tokyo-cabinet cffi deoxybyte-systems +cl-tokyo-cabinet cl-tokyo-cabinet-test cl-tokyo-cabinet-test cl-tokyo-cabinet deoxybyte-io deoxybyte-utilities lift +cl-toml cl-toml cl-toml alexandria asdf esrap local-time trivial-types +cl-toml cl-toml-test cl-toml-test asdf cl-toml prove +cl-torrents torrents torrents asdf cl-ansi-text cl-readline cl-transmission clache dexador log4cl lparallel lquery mockingbird parse-float plump py-configparser replic str unix-opts +cl-torrents torrents-test torrents-test asdf mockingbird prove prove-asdf torrents +cl-torrents torrents torrents/tk nodgui torrents +cl-transmission cl-transmission cl-transmission asdf cl-ppcre drakma jonathan named-readtables rutils uiop x.let-star +cl-transmission cl-transmission-test cl-transmission-test asdf cl-transmission prove prove-asdf +cl-trie cl-trie cl-trie asdf +cl-trie cl-trie-examples cl-trie-examples asdf cl-ppcre cl-trie +cl-trie cl-trie cl-trie/tests cl-trie fiveam +cl-tulip-graph cl-tulip-graph cl-tulip-graph +cl-tuples cl-tuples cl-tuples alexandria iterate +cl-twitter cl-twit-repl cl-twit-repl asdf cl-twitter +cl-twitter cl-twitter cl-twitter anaphora asdf cl-json cl-oauth cl-ppcre closer-mop drakma trivial-http url-rewrite +cl-twitter twitter-mongodb-driver twitter-mongodb-driver asdf cl-mongo cl-twitter +cl-typesetting cl-pdf-doc cl-pdf-doc cl-pdf cl-typesetting +cl-typesetting cl-typesetting cl-typesetting cl-pdf +cl-typesetting xml-render xml-render cl-typesetting xmls +cl-uglify-js cl-uglify-js cl-uglify-js cl-ppcre cl-ppcre-unicode iterate parse-js parse-number +cl-unicode cl-unicode cl-unicode asdf cl-ppcre +cl-unicode cl-unicode cl-unicode/base cl-ppcre +cl-unicode cl-unicode cl-unicode/build cl-ppcre flexi-streams +cl-unicode cl-unicode cl-unicode/test cl-unicode +cl-unification cl-ppcre-template cl-ppcre-template asdf cl-ppcre cl-unification +cl-unification cl-unification cl-unification asdf +cl-unification cl-unification-lib cl-unification-lib asdf cl-ppcre cl-unification +cl-unification cl-unification-test cl-unification-test asdf cl-unification ptester +cl-utilities cl-utilities cl-utilities +cl-variates cl-variates cl-variates asdf asdf-system-connections +cl-vectors cl-aa cl-aa asdf +cl-vectors cl-aa-misc cl-aa-misc asdf +cl-vectors cl-paths cl-paths asdf +cl-vectors cl-paths-ttf cl-paths-ttf asdf cl-paths zpb-ttf +cl-vectors cl-vectors cl-vectors asdf cl-aa cl-paths +cl-vhdl cl-vhdl cl-vhdl alexandria cl-interpol cl-itertools cl-ppcre esrap-liquid iterate +cl-vhdl cl-vhdl cl-vhdl-tests cl-interpol cl-vhdl fare-quasiquote-optima fiveam optima +cl-video cl-video cl-video asdf bordeaux-threads +cl-video cl-video-avi cl-video-avi alexandria asdf cl-jpeg cl-riff cl-video flexi-streams +cl-video cl-video-gif cl-video-gif alexandria asdf cl-video skippy +cl-video cl-video-player cl-video-player asdf bordeaux-threads cl-portaudio cl-video-avi cl-video-gif cl-video-wav clx +cl-video cl-video-wav cl-video-wav alexandria asdf cl-riff cl-video flexi-streams +cl-virtualbox cl-virtualbox cl-virtualbox alexandria asdf cl-ppcre uiop usocket +cl-voxelize cl-voxelize cl-voxelize alexandria +cl-voxelize cl-voxelize-examples cl-voxelize-examples cl-ply cl-voxelize +cl-voxelize cl-voxelize-test cl-voxelize-test cl-voxelize prove prove-asdf +cl-wadler-pprint cl-wadler-pprint cl-wadler-pprint asdf +cl-wadler-pprint cl-wadler-pprint cl-wadler-pprint/test cl-wadler-pprint fiveam +cl-wav cl-wav cl-wav alexandria asdf cl-riff +cl-wayland cl-wayland cl-wayland asdf cffi closer-mop +cl-weather-jp cl-weather-jp cl-weather-jp clss dexador function-cache jonathan plump +cl-weather-jp cl-weather-jp-test cl-weather-jp-test cl-weather-jp prove prove-asdf +cl-webdav cl-webdav cl-webdav cl-fad cxml hunchentoot +cl-webkit cl-soup cl-soup cffi +cl-webkit cl-webkit-dom cl-webkit-dom cffi cl-cffi-gtk cl-cffi-gtk-gobject +cl-webkit cl-webkit2 cl-webkit2 cffi cl-cffi-gtk cl-soup cl-webkit-dom +cl-webkit cl-webkit2-tests cl-webkit2-tests cl-webkit2 lisp-unit uiop +cl-who cl-who cl-who asdf +cl-who cl-who cl-who-test cl-who flexi-streams +cl-why cl-why cl-why asdf +cl-why cl-why cl-why-test cl-why flexi-streams +cl-wordcut cl-wordcut cl-wordcut asdf +cl-wordcut cl-wordcut cl-wordcut/test cl-wordcut fiveam +cl-xdg cl-xdg cl-xdg cl-sxml cl-xmlspam flexi-streams parse-number split-sequence uiop +cl-xdg cl-xdg cl-xdg-test asdf cl-xdg fiveam uiop +cl-xkb cl-xkb cl-xkb asdf cffi +cl-xkeysym cl-xkeysym cl-xkeysym +cl-xmlspam cl-xmlspam cl-xmlspam cl-ppcre cxml +cl-xmpp cl-xmpp cl-xmpp cxml ironclad usocket +cl-xmpp cl-xmpp-sasl cl-xmpp-sasl cl-base64 cl-sasl cl-xmpp +cl-xmpp cl-xmpp-tls cl-xmpp-tls cl+ssl cl-xmpp-sasl +cl-xul cl-xul cl-xul alexandria cl-fad cl-json closer-mop clws cxml log5 md5 parenscript +cl-xul cl-xul-test cl-xul-test cl-xul fiveam +cl-yacc yacc yacc +cl-yaclyaml cl-yaclyaml cl-yaclyaml alexandria cl-interpol cl-ppcre cl-test-more esrap-liquid iterate parse-number rutils +cl-yaclyaml cl-yaclyaml cl-yaclyaml-tests cl-interpol cl-yaclyaml fiveam +cl-yahoo-finance cl-yahoo-finance cl-yahoo-finance babel cl-csv drakma url-rewrite yason +cl-yaml cl-yaml cl-yaml alexandria cl-libyaml cl-ppcre parse-number +cl-yaml cl-yaml-test cl-yaml-test alexandria cl-fad cl-yaml fiveam generic-comparability trivial-benchmark yason +cl-yesql cl-yesql cl-yesql asdf asdf-package-system +cl-zmq zeromq zeromq cffi cffi-grovel trivial-garbage +cl-zmq zeromq zeromq.tests bordeaux-threads fiveam zeromq +cl4store cl4store cl4store cl-ppcre cl-rdfxml drakma log5 parser-combinators puri split-sequence +cl4store cl4store-tests cl4store-tests cl4store fiveam +clache clache clache alexandria babel cl-annot cl-fad cl-store cl-syntax cl-syntax-annot ironclad trivial-garbage +clache clache-test clache-test cl-test-more clache +clack clack clack alexandria asdf bordeaux-threads lack lack-middleware-backtrace lack-util uiop +clack clack-handler-fcgi clack-handler-fcgi alexandria asdf cl-fastcgi flexi-streams quri usocket +clack clack-handler-hunchentoot clack-handler-hunchentoot alexandria asdf bordeaux-threads clack-socket flexi-streams hunchentoot split-sequence +clack clack-handler-toot clack-handler-toot alexandria asdf bordeaux-threads cl-ppcre flexi-streams split-sequence toot +clack clack-handler-wookie clack-handler-wookie alexandria asdf babel cl-async clack-socket fast-http fast-io flexi-streams quri split-sequence wookie +clack clack-middleware-auth-basic clack-middleware-auth-basic arnesi asdf cl-base64 cl-ppcre cl-syntax cl-syntax-annot clack-v1-compat +clack clack-middleware-clsql clack-middleware-clsql asdf cl-syntax cl-syntax-annot clack-v1-compat clsql +clack clack-middleware-csrf clack-middleware-csrf alexandria asdf cl-syntax cl-syntax-annot clack-v1-compat lack-util +clack clack-middleware-dbi clack-middleware-dbi asdf cl-syntax cl-syntax-annot clack-v1-compat dbi +clack clack-middleware-oauth clack-middleware-oauth asdf cl-oauth cl-syntax cl-syntax-annot clack-v1-compat +clack clack-middleware-postmodern clack-middleware-postmodern asdf cl-syntax cl-syntax-annot clack-v1-compat postmodern +clack clack-middleware-rucksack clack-middleware-rucksack asdf cl-syntax cl-syntax-annot clack-v1-compat rucksack +clack clack-session-store-dbi clack-session-store-dbi asdf cl-base64 clack-v1-compat dbi marshal +clack clack-socket clack-socket asdf +clack clack-test clack-test asdf bordeaux-threads clack clack-handler-hunchentoot dexador flexi-streams http-body rove usocket +clack clack-v1-compat clack-v1-compat alexandria asdf circular-streams cl-base64 cl-ppcre cl-syntax-annot clack clack-test flexi-streams http-body ironclad lack lack-util local-time marshal quri split-sequence trivial-backtrace trivial-mimes trivial-types uiop +clack t-clack-handler-fcgi t-clack-handler-fcgi asdf clack-test +clack t-clack-handler-hunchentoot t-clack-handler-hunchentoot asdf clack-handler-hunchentoot clack-test +clack t-clack-handler-toot t-clack-handler-toot asdf clack-handler-toot clack-test +clack t-clack-handler-wookie t-clack-handler-wookie asdf clack-test +clack t-clack-middleware-auth-basic t-clack-middleware-auth-basic asdf clack clack-middleware-auth-basic clack-test drakma prove prove-asdf +clack t-clack-middleware-csrf t-clack-middleware-csrf asdf clack clack-middleware-csrf clack-test drakma prove prove-asdf +clack t-clack-v1-compat t-clack-v1-compat asdf clack-test clack-v1-compat drakma prove prove-asdf +clack-errors clack-errors clack-errors asdf cl-ppcre clack closer-mop djula local-time trivial-backtrace +clack-errors clack-errors-demo clack-errors-demo asdf cl-markup clack-errors +clack-errors clack-errors-test clack-errors-test asdf clack clack-errors drakma fiveam hunchentoot +clack-errors lack-middleware-clack-errors lack-middleware-clack-errors asdf clack-errors +clack-pretend clack-pretend clack-pretend alexandria cl-hash-util clack lack-request +clack-static-asset-middleware clack-static-asset-djula-helpers clack-static-asset-djula-helpers clack-static-asset-middleware djula +clack-static-asset-middleware clack-static-asset-middleware clack-static-asset-middleware alexandria cl-ppcre ironclad local-time trivial-mimes uiop +clack-static-asset-middleware clack-static-asset-middleware-test clack-static-asset-middleware-test clack-static-asset-djula-helpers clack-static-asset-middleware lack-test prove prove-asdf +clad clad clad asdf +classimp classimp classimp cffi +classimp classimp-samples classimp-samples cl-fad cl-glu cl-glut cl-ilut classimp +classowary classowary classowary asdf documentation-utils +classowary classowary-test classowary-test asdf classowary parachute +clath clath clath alexandria cl-hash-util cl-json cl-who clack cljwt-custom drakma flexi-streams ningle north ubiquitous +clath cljwt-custom cljwt-custom cl-base64 flexi-streams ironclad split-sequence yason +clavatar clavatar clavatar babel drakma iolib ironclad +clavier clavier clavier alexandria chronicity cl-fad cl-ppcre closer-mop +clavier clavier.test clavier.test clavier stefil +claw claw claw alexandria asdf cffi cl-json cl-ppcre trivial-features uiop +clawk clawk clawk regex +clazy clazy clazy asdf +clem clem clem asdf +clem clem-benchmark clem-benchmark asdf clem +clem clem-test clem-test asdf clem +cleric cleric cleric alexandria com.gigamonkeys.binary-data epmd erlang-term md5 usocket +cleric cleric-test cleric-test cleric erlang-term-test fiveam flexi-streams +clesh clesh clesh asdf named-readtables trivial-shell +clesh clesh-tests clesh-tests asdf clesh lisp-unit +cletris cletris cletris cl-ppcre pal +cletris cletris-network cletris-network cl-log cl-ppcre cletris usocket +cletris cletris-test cletris-test cletris prove prove-asdf +clfswm clfswm clfswm clx +clhs clhs clhs +clickr clickr clickr cl-ppcre md5 s-xml s-xml-rpc trivial-http +clim-widgets clim-widgets clim-widgets asdf cl-fad closer-mop local-time manifest mcclim nsort perlre simple-date-time +climacs climacs climacs asdf flexichain mcclim +climc climc climc cl-ppcre cl-xmpp-tls mcclim +climc climc-test climc-test climc lisp-unit +climon climon climon pal +climon climon-test climon-test climon prove prove-asdf +clinch clinch clinch asdf bordeaux-threads cl-opengl rtg-math sdl2 swank trivial-channels trivial-garbage +clinch clinch-cairo clinch-cairo asdf cffi cl-cairo2 clinch +clinch clinch-classimp clinch-classimp asdf cffi classimp clinch +clinch clinch-freeimage clinch-freeimage asdf cffi cl-freeimage clinch +clinch clinch-pango clinch-pango asdf cffi cl-cairo2 cl-pango clinch clinch-cairo xmls +clinenoise clinenoise clinenoise alexandria asdf cffi cffi-grovel split-sequence +clip clip clip array-utils asdf lquery +clipper clipper clipper alexandria cl-fad cl-syntax-annot closer-mop dexador fast-io opticl quri split-sequence zs3 +clipper clipper-test clipper-test clipper integral prove prove-asdf +clite clite clite +clml clml clml asdf clml.association-rule clml.blas clml.classifiers clml.clustering clml.data clml.decision-tree clml.graph clml.hjs clml.lapack clml.nearest-search clml.nonparametric clml.numeric clml.pca clml.som clml.statistics clml.svm clml.text clml.time-series clml.utility +clml clml.association-rule clml.association-rule asdf clml.hjs +clml clml.blas clml.blas asdf clml.blas.complex clml.blas.hompack clml.blas.real +clml clml.blas clml.blas.complex f2cl-lib +clml clml.blas clml.blas.hompack f2cl-lib +clml clml.blas clml.blas.real f2cl-lib +clml clml.classifiers clml.classifiers asdf clml.clustering clml.hjs clml.svm +clml clml.clustering clml.clustering asdf clml.blas clml.hjs clml.nearest-search iterate +clml clml.data clml.data asdf clml.data.r-datasets +clml clml.data.r-datasets clml.data.r-datasets asdf cl-ppcre clml.data.r-datasets-package clml.hjs clml.utility drakma +clml clml.decision-tree clml.decision-tree asdf clml.hjs lparallel +clml clml.docs clml.docs asdf cl-ppcre clml clod iterate +clml clml.graph clml.graph asdf cl-fad clml.hjs clml.statistics clml.time-series split-sequence +clml clml.hjs clml.hjs alexandria asdf clml.blas clml.lapack clml.statistics clml.utility future introspect-environment iterate +clml clml.lapack clml.lapack asdf clml.blas clml.lapack-real f2cl-lib +clml clml.lapack clml.lapack-real clml.blas f2cl-lib +clml clml.nearest-search clml.nearest-search asdf clml.hjs clml.nonparametric clml.pca +clml clml.nonparametric clml.nonparametric asdf clml.hjs +clml clml.numeric clml.numeric asdf clml.hjs +clml clml.pca clml.pca asdf clml.decision-tree clml.hjs +clml clml.pca clml.pca.examples clml.hjs clml.pca +clml clml.som clml.som asdf clml.hjs clml.statistics split-sequence +clml clml.som clml.som.example clml.hjs clml.som split-sequence +clml clml.statistics clml.statistics asdf clml.statistics.rand +clml clml.statistics.rand clml.statistics.rand asdf +clml clml.svm clml.svm asdf clml.decision-tree clml.hjs future lparallel +clml clml.svm clml.svm.examples clml.hjs clml.svm +clml clml.test clml.test asdf clml lisp-unit +clml clml.text clml.text asdf clml.hjs clml.nonparametric split-sequence +clml clml.time-series clml.time-series array-operations asdf clml.hjs clml.numeric iterate uiop +clml clml.utility clml.utility alexandria asdf cl-fad cl-ppcre drakma iterate parse-number trivial-garbage +clml f2cl-lib f2cl-lib asdf +clml fork-future fork-future asdf cffi cl-store +clml future future alexandria asdf +clnuplot clnuplot clnuplot cl-containers cl-mathstats metabang-bind trivial-shell +clobber clobber clobber asdf +clod clod clod asdf cl-ppcre closer-mop iterate +clods-export clods-export clods-export alexandria cl-fad cxml iterate local-time zip +clon clon clon bordeaux-threads trivial-timers +clon clon-test clon-test clon +clonsigna clonsigna clonsigna alexandria babel cl+ssl cl-base64 cl-ppcre iolib split-sequence +clos-diff clos-diff clos-diff closer-mop +clos-fixtures clos-fixtures clos-fixtures +clos-fixtures clos-fixtures-test clos-fixtures-test clos-fixtures fiveam +closer-mop closer-mop closer-mop asdf +closure-common closure-common closure-common asdf babel trivial-gray-streams +closure-html closure-html closure-html asdf closure-common flexi-streams +clouchdb clouchdb clouchdb closer-mop drakma flexi-streams parenscript s-base64 +clouchdb clouchdb-examples clouchdb-examples clouchdb parenscript +clsql clsql clsql uffi +clsql clsql-aodbc clsql-aodbc +clsql clsql-cffi clsql-cffi clsql +clsql clsql-mysql clsql-mysql clsql clsql-uffi uffi +clsql clsql-odbc clsql-odbc clsql clsql-uffi +clsql clsql-postgresql clsql-postgresql clsql clsql-uffi +clsql clsql-postgresql-socket clsql-postgresql-socket clsql md5 uffi +clsql clsql-postgresql-socket3 clsql-postgresql-socket3 cl-postgres clsql md5 +clsql clsql-sqlite clsql-sqlite clsql clsql-uffi +clsql clsql-sqlite3 clsql-sqlite3 clsql clsql-uffi +clsql clsql-tests clsql-tests clsql rt uffi +clsql clsql-uffi clsql-uffi clsql uffi +clsql-fluid clsql-fluid clsql-fluid bordeaux-threads closer-mop clsql +clsql-helper clsql-helper clsql-helper access alexandria asdf cl-interpol cl-ppcre closer-mop clsql collectors iterate md5 symbol-munger +clsql-helper clsql-helper-slot-coercer clsql-helper-slot-coercer asdf closer-mop clsql-helper +clsql-helper clsql-helper-slot-coercer clsql-helper-slot-coercer-test clsql-helper-slot-coercer lisp-unit2 +clsql-helper clsql-helper clsql-helper-test clsql-helper clsql-tests lisp-unit2 +clsql-local-time clsql-local-time clsql-local-time asdf clsql local-time +clsql-orm clsql-orm clsql-orm cl-inflector cl-interpol cl-ppcre clsql iterate symbol-munger +clss clss clss array-utils asdf plump +cltcl cltcl cltcl +clump clump clump clump-2-3-tree clump-binary-tree +clump clump-2-3-tree clump-2-3-tree acclimation +clump clump-binary-tree clump-binary-tree acclimation +clump clump-test clump-test clump +clunit clunit clunit +clunit2 clunit2 clunit2 asdf +clutz clutz clutz alexandria asdf bodge-glad bodge-glfw claw glad-blob glfw-blob trivial-main-thread +clweb clweb clweb asdf +clweb clweb clweb/tests clweb +clws clws clws chunga cl-base64 flexi-streams iolib ironclad split-sequence +clx clx clx asdf +clx clx clx/test clx fiasco +clx-cursor clx-cursor clx-cursor asdf cl-fad clx +clx-cursor clx-cursor clx-cursor-test cl-fad clx clx-cursor +clx-truetype clx-truetype clx-truetype cl-aa cl-fad cl-paths-ttf cl-store cl-vectors clx trivial-features zpb-ttf +clx-truetype clx-truetype clx-truetype-test clx-truetype +clx-xembed xembed xembed asdf clx +clx-xkeyboard xkeyboard xkeyboard clx +clx-xkeyboard xkeyboard xkeyboard-test xkeyboard +cmake-parser cmake-parser cmake-parser alexandria asdf esrap +cmu-infix cmu-infix cmu-infix asdf named-readtables +cmu-infix cmu-infix-tests cmu-infix-tests asdf cmu-infix fiasco uiop +codata-recommended-values codata-recommended-values codata-recommended-values +codex codex codex alexandria asdf cl-ppcre cl-slug codex-templates common-doc common-doc-contrib docparser pandocl +codex codex-templates codex-templates asdf common-html djula trivial-types +coleslaw coleslaw coleslaw 3bmd 3bmd-ext-code-blocks alexandria asdf cl-fad cl-ppcre cl-unicode closer-mop closure-template inferior-shell local-time uiop +coleslaw coleslaw-cli coleslaw-cli asdf clack coleslaw trivia uiop +coleslaw coleslaw-test coleslaw-test asdf coleslaw coleslaw-cli prove prove-asdf +collectors collectors collectors alexandria closer-mop symbol-munger +collectors collectors collectors-test collectors lisp-unit2 +colleen colleen colleen asdf bordeaux-threads cl-ppcre flexi-streams trivial-arguments universal-config usocket uuid verbose +colliflower colliflower colliflower asdf-package-system garten liter +colliflower colliflower-fset colliflower-fset colliflower fset +colliflower colliflower-test colliflower-test colliflower prove prove-asdf +colliflower garten garten +colliflower liter liter +colliflower silo silo +colorize colorize colorize alexandria asdf html-encode split-sequence +com.clearly-useful.generic-collection-interface com.clearly-useful.generic-collection-interface com.clearly-useful.generic-collection-interface asdf bordeaux-threads com.clearly-useful.protocols lparallel +com.clearly-useful.generic-collection-interface com.clearly-useful.generic-collection-interface.test com.clearly-useful.generic-collection-interface.test asdf com.clearly-useful.generic-collection-interface +com.clearly-useful.iterate-plus com.clearly-useful.iterate+ com.clearly-useful.iterate+ com.clearly-useful.generic-collection-interface com.clearly-useful.iterator-protocol com.clearly-useful.protocols iterate +com.clearly-useful.iterator-protocol com.clearly-useful.iterator-protocol com.clearly-useful.iterator-protocol com.clearly-useful.generic-collection-interface com.clearly-useful.protocols +com.clearly-useful.protocols com.clearly-useful.protocols com.clearly-useful.protocols iterate +com.google.base com.google.base com.google.base +com.google.base com.google.base-test com.google.base-test com.google.base hu.dwim.stefil +command-line-arguments command-line-arguments command-line-arguments asdf +common-doc common-doc common-doc alexandria anaphora closer-mop local-time quri trivial-types +common-doc common-doc-contrib common-doc-contrib common-doc-gnuplot common-doc-graphviz common-doc-include common-doc-split-paragraphs common-doc-tex +common-doc common-doc-gnuplot common-doc-gnuplot common-doc split-sequence +common-doc common-doc-graphviz common-doc-graphviz common-doc trivial-shell +common-doc common-doc-include common-doc-include common-doc split-sequence +common-doc common-doc-split-paragraphs common-doc-split-paragraphs cl-ppcre common-doc +common-doc common-doc-test common-doc-test common-doc common-doc-contrib fiveam +common-doc common-doc-tex common-doc-tex common-doc +common-doc-plump common-doc-plump common-doc-plump anaphora cl-markup common-doc common-doc-split-paragraphs plump +common-doc-plump common-doc-plump-test common-doc-plump-test common-doc-plump fiveam +common-html common-html common-html alexandria anaphora common-doc plump +common-html common-html-test common-html-test common-html fiveam +common-lisp-actors cl-actors cl-actors asdf bordeaux-threads +common-lisp-jupyter common-lisp-jupyter common-lisp-jupyter alexandria asdf babel bordeaux-threads cl-base64 closer-mop ironclad iterate jsown pzmq trivial-gray-streams trivial-mimes +commonqt qt qt alexandria asdf cffi cl-ppcre closer-mop iterate named-readtables trivial-features trivial-garbage +commonqt qt+libs qt+libs alexandria asdf cffi cl-ppcre closer-mop iterate named-readtables qt-libs trivial-features trivial-garbage +commonqt qt-repl qt-repl asdf bordeaux-threads qt +commonqt qt-test qt-test alexandria asdf iterate qt rt trivial-garbage +commonqt qt-tutorial qt-tutorial asdf qt +computable-reals computable-reals computable-reals asdf +concrete-syntax-tree concrete-syntax-tree concrete-syntax-tree asdf concrete-syntax-tree-base concrete-syntax-tree-lambda-list +concrete-syntax-tree concrete-syntax-tree-base concrete-syntax-tree-base acclimation asdf +concrete-syntax-tree concrete-syntax-tree-destructuring concrete-syntax-tree-destructuring asdf concrete-syntax-tree-lambda-list +concrete-syntax-tree concrete-syntax-tree-lambda-list concrete-syntax-tree-lambda-list asdf concrete-syntax-tree-base +concrete-syntax-tree concrete-syntax-tree-lambda-list-test concrete-syntax-tree-lambda-list-test asdf concrete-syntax-tree-lambda-list +concrete-syntax-tree concrete-syntax-tree-source-info concrete-syntax-tree-source-info asdf +concrete-syntax-tree concrete-syntax-tree concrete-syntax-tree/test concrete-syntax-tree +conduit-packages conduit-packages conduit-packages +conf conf conf asdf cl-fad +conf conf conf/test conf +configuration.options configuration.options configuration.options alexandria architecture.service-provider asdf cl-hooks esrap let-plus log4cl more-conditions split-sequence utilities.print-items utilities.print-tree +configuration.options configuration.options-and-mop configuration.options-and-mop alexandria asdf closer-mop configuration.options let-plus +configuration.options configuration.options-and-mop configuration.options-and-mop/test alexandria configuration.options configuration.options-and-mop fiveam let-plus +configuration.options configuration.options-and-puri configuration.options-and-puri alexandria asdf configuration.options let-plus puri +configuration.options configuration.options-and-puri configuration.options-and-puri/test alexandria configuration.options configuration.options-and-puri fiveam let-plus +configuration.options configuration.options-and-quri configuration.options-and-quri alexandria asdf configuration.options let-plus quri +configuration.options configuration.options-and-quri configuration.options-and-quri/test alexandria configuration.options configuration.options-and-quri fiveam let-plus +configuration.options configuration.options-and-service-provider configuration.options-and-service-provider alexandria architecture.service-provider architecture.service-provider-and-hooks asdf configuration.options configuration.options-and-mop let-plus log4cl +configuration.options configuration.options-and-service-provider configuration.options-and-service-provider/test alexandria architecture.service-provider configuration.options configuration.options-and-service-provider fiveam let-plus +configuration.options configuration.options-source-commandline configuration.options-source-commandline alexandria architecture.service-provider asdf configuration.options let-plus log4cl net.didierverna.clon split-sequence +configuration.options configuration.options-source-commandline configuration.options-source-commandline/test alexandria configuration.options configuration.options-source-commandline fiveam let-plus +configuration.options configuration.options-syntax-ini configuration.options-syntax-ini alexandria asdf configuration.options let-plus parser.ini +configuration.options configuration.options-syntax-ini configuration.options-syntax-ini/test alexandria configuration.options configuration.options-syntax-ini fiveam let-plus +configuration.options configuration.options-syntax-xml configuration.options-syntax-xml alexandria asdf configuration.options let-plus xml.location +configuration.options configuration.options-syntax-xml configuration.options-syntax-xml/test alexandria configuration.options configuration.options-syntax-xml fiveam let-plus +configuration.options configuration.options configuration.options/test alexandria configuration.options fiveam let-plus +conium conium conium asdf closer-mop +consix consix consix alexandria cl-glu cl-glut cl-opengl +constantfold constantfold constantfold alexandria asdf iterate lisp-namespace trivia +constantfold constantfold.test constantfold.test asdf constantfold fiveam +contextl contextl contextl asdf closer-mop lw-compat +contextl dynamic-wind dynamic-wind asdf lw-compat +copy-directory copy-directory copy-directory cl-fad uiop which +copy-directory copy-directory-test copy-directory-test copy-directory fiveam +corona corona corona anaphora cl-fad cl-virtualbox ironclad log4cl trivial-download trivial-extract trivial-types +corona corona-test corona-test archive cl-fad clack clack-v1-compat corona fiveam +corona corona-web corona-web 3bmd 3bmd-ext-code-blocks 3bmd-ext-definition-lists cl-markup corona lass +cover cover cover asdf +cover cover cover/tests cover uiop +cqlcl cqlcl cqlcl alexandria bordeaux-threads fiveam flexi-streams lparallel pooler split-sequence usocket uuid +cqlcl cqlcl cqlcl-test alexandria cqlcl fiveam flexi-streams uuid +crane crane crane anaphora cl-fad clos-fixtures closer-mop dbi iterate local-time sxql uiop +crane crane-test crane-test crane fiveam +croatoan croatoan croatoan asdf bordeaux-threads cffi trivial-gray-streams +croatoan croatoan-test croatoan-test asdf croatoan +crypto-shortcuts crypto-shortcuts crypto-shortcuts asdf cl-base64 flexi-streams ironclad +cserial-port cserial-port cserial-port cffi cffi-grovel osicat trivial-features trivial-gray-streams +css-lite css-lite css-lite +css-selectors css-selectors css-selectors alexandria buildnode cl-interpol cl-ppcre cxml iterate symbol-munger yacc +css-selectors css-selectors-simple-tree css-selectors-simple-tree cl-html5-parser css-selectors +css-selectors css-selectors-stp css-selectors-stp css-selectors cxml-stp +css-selectors css-selectors css-selectors-test buildnode-xhtml css-selectors lisp-unit2 +csv csv csv asdf +csv-parser csv-parser csv-parser +cue-parser cue-parser cue-parser asdf esrap flexi-streams +curly curly curly +curly curly curly.test curly fiveam +curry-compose-reader-macros curry-compose-reader-macros curry-compose-reader-macros alexandria asdf named-readtables +curve com.elbeno.curve com.elbeno.curve com.elbeno.vector vecto +cxml cxml cxml asdf closure-common puri trivial-gray-streams +cxml cxml-dom cxml-dom asdf closure-common puri trivial-gray-streams +cxml cxml-klacks cxml-klacks asdf closure-common puri trivial-gray-streams +cxml cxml-test cxml-test asdf closure-common puri trivial-gray-streams +cxml cxml cxml/dom closure-common puri trivial-gray-streams +cxml cxml cxml/klacks closure-common puri trivial-gray-streams +cxml cxml cxml/test closure-common puri trivial-gray-streams +cxml cxml cxml/xml closure-common puri trivial-gray-streams +cxml-rng cxml-rng cxml-rng asdf cl-base64 cl-ppcre cxml parse-number yacc +cxml-rpc cxml-rpc cxml-rpc cl-base64 cxml drakma hunchentoot parse-number +cxml-stp cxml-stp cxml-stp alexandria asdf cxml xpath +cxml-stp cxml-stp cxml-stp/test cxml-stp rt xpath +daemon daemon daemon trivial-features +dartsclemailaddress darts.lib.email-address darts.lib.email-address +dartsclemailaddress darts.lib.email-address-test darts.lib.email-address-test darts.lib.email-address stefil +dartsclhashtree darts.lib.hashtree-test darts.lib.hashtree-test asdf darts.lib.hashtrie darts.lib.wbtree stefil +dartsclhashtree darts.lib.hashtrie darts.lib.hashtrie asdf +dartsclhashtree darts.lib.wbtree darts.lib.wbtree asdf +dartsclmessagepack darts.lib.message-pack darts.lib.message-pack babel ieee-floats +dartsclmessagepack darts.lib.message-pack-test darts.lib.message-pack-test darts.lib.message-pack stefil trivial-octet-streams +dartsclsequencemetrics darts.lib.sequence-metrics darts.lib.sequence-metrics +dartscltools darts.lib.tools darts.lib.tools asdf atomics +dartscluuid darts.lib.uuid darts.lib.uuid asdf cl-ppcre ironclad trivial-utf-8 +data-lens data-lens data-lens alexandria asdf cl-ppcre serapeum +data-sift data-sift data-sift alexandria cl-ppcre parse-number puri +data-sift data-sift data-sift-test data-sift lift +data-table data-table data-table alexandria cl-interpol iterate symbol-munger +data-table data-table-clsql data-table-clsql clsql clsql-helper collectors data-table iterate +data-table data-table data-table-test data-table lisp-unit2 +database-migrations database-migrations database-migrations asdf postmodern +datafly datafly datafly alexandria asdf babel cl-syntax-annot closer-mop dbi function-cache iterate jonathan kebab local-time log4cl optima sxql trivial-types +datafly datafly-test datafly-test asdf datafly prove prove-asdf sxql +datamuse datamuse datamuse alexandria asdf drakma yason +date-calc date-calc date-calc asdf +date-calc date-calc date-calc/test date-calc fiveam serapeum +datum-comments datum-comments datum-comments asdf +datum-comments datum-comments datum-comments-test datum-comments +dbd-oracle dbd-oracle dbd-oracle asdf cffi cffi-uffi-compat dbi +dbd-oracle dbd-oracle-test dbd-oracle-test asdf dbd-oracle lift +dbus dbus dbus asdf asdf-package-system +de.setf.wilbur wilbur wilbur asdf usocket +declt net.didierverna.declt net.didierverna.declt asdf net.didierverna.declt.core net.didierverna.declt.setup +declt net.didierverna.declt.core net.didierverna.declt.core asdf net.didierverna.declt.setup +declt net.didierverna.declt.setup net.didierverna.declt.setup asdf +deeds deeds deeds asdf bordeaux-threads closer-mop form-fiddle lambda-fiddle +defclass-std defclass-std defclass-std alexandria anaphora +defclass-std defclass-std-test defclass-std-test defclass-std prove prove-asdf +defenum defenum defenum asdf +deferred deferred deferred asdf named-readtables +define-json-expander define-json-expander define-json-expander +definitions definitions definitions asdf documentation-utils +definitions-systems definitions-systems definitions-systems asdf enhanced-multiple-value-bind incognito-keywords +definitions-systems definitions-systems_tests definitions-systems_tests asdf definitions-systems parachute +deflate deflate deflate asdf +defmemo defmemo defmemo alexandria trivial-garbage +defmemo defmemo defmemo-test defmemo +defpackage-plus defpackage-plus defpackage-plus alexandria asdf +defrec defrec defrec alexandria asdf +defstar defstar defstar +defsystem-compatibility defsystem-compatibility defsystem-compatibility metatilities-base +defsystem-compatibility defsystem-compatibility-test defsystem-compatibility-test defsystem-compatibility lift +defvariant defvariant defvariant +delorean delorean delorean local-time +delorean delorean delorean-test delorean fiveam +delta-debug delta-debug delta-debug alexandria asdf curry-compose-reader-macros named-readtables +delta-debug delta-debug delta-debug/delta alexandria curry-compose-reader-macros delta-debug diff metabang-bind split-sequence trivial-shell +delta-debug delta-debug delta-debug/test alexandria curry-compose-reader-macros delta-debug stefil +dendrite dendrite dendrite dendrite.micro-l-system dendrite.primitives +dendrite dendrite.micro-l-system dendrite.micro-l-system +dendrite dendrite.primitives dendrite.primitives cffi rtg-math +deoxybyte-gzip deoxybyte-gzip deoxybyte-gzip deoxybyte-io deoxybyte-systems deoxybyte-unix +deoxybyte-gzip deoxybyte-gzip-test deoxybyte-gzip-test deoxybyte-gzip lift +deoxybyte-io deoxybyte-io deoxybyte-io cl-fad deoxybyte-systems deoxybyte-utilities getopt +deoxybyte-io deoxybyte-io-test deoxybyte-io-test deoxybyte-io lift +deoxybyte-systems deoxybyte-systems deoxybyte-systems cl-fad +deoxybyte-unix deoxybyte-unix deoxybyte-unix cffi deoxybyte-io deoxybyte-systems +deoxybyte-unix deoxybyte-unix-test deoxybyte-unix-test deoxybyte-unix lift +deoxybyte-utilities deoxybyte-utilities deoxybyte-utilities deoxybyte-systems +deoxybyte-utilities deoxybyte-utilities-test deoxybyte-utilities-test deoxybyte-utilities lift +deploy deploy deploy asdf cffi documentation-utils trivial-features +deploy deploy-test deploy-test asdf cl-mpg123 cl-out123 deploy +descriptions descriptions descriptions alexandria anaphora closer-mop sheeple +descriptions descriptions-test descriptions-test descriptions descriptions.serialization descriptions.validation stefil +descriptions descriptions.serialization descriptions.serialization cl-json descriptions +descriptions descriptions.validation descriptions.validation clavier descriptions +destructuring-bind-star destructuring-bind-star destructuring-bind-star asdf +destructuring-bind-star destructuring-bind-star destructuring-bind-star/test destructuring-bind-star +dexador dexador dexador alexandria asdf babel bordeaux-threads chipz chunga cl+ssl cl-base64 cl-cookie cl-ppcre cl-reexport fast-http fast-io quri trivial-features trivial-gray-streams trivial-mimes usocket +dexador dexador-test dexador-test asdf babel cl-cookie clack-test dexador lack-request rove +diff diff diff cl-ppcre trivial-gray-streams +diff-match-patch diff-match-patch diff-match-patch cl-ppcre iterate +diff-match-patch diff-match-patch diff-match-patch.test cl-interpol diff-match-patch fiveam +dirt dirt dirt cepl cl-soil +disposable disposable disposable +dissect dissect dissect asdf +djula djula djula access alexandria anaphora asdf babel cl-fad cl-locale cl-ppcre cl-slice closer-mop gettext iterate local-time parser-combinators split-sequence trivial-backtrace +djula djula-demo djula-demo asdf djula hunchentoot +djula djula-test djula-test asdf djula fiveam +dlist dlist dlist +dlist dlist dlist-test dlist lisp-unit +dml dml dml alexandria asdf cl-cairo2 cl-ppcre donuts +do-urlencode do-urlencode do-urlencode alexandria asdf babel +docbrowser docbrowser docbrowser alexandria asdf babel bordeaux-threads cl-json closer-mop colorize flexi-streams hunchentoot parse-number split-sequence string-case swank yacc +docparser docparser docparser alexandria anaphora asdf cffi trivial-types +docparser docparser-test docparser-test asdf docparser fiveam +docparser docparser-test-system docparser-test-system asdf cffi +documentation-template documentation-template documentation-template cl-who +documentation-utils documentation-utils documentation-utils asdf trivial-indent +documentation-utils multilang-documentation-utils multilang-documentation-utils asdf documentation-utils multilang-documentation +documentation-utils-extensions documentation-utils-extensions documentation-utils-extensions asdf documentation-utils +donuts donuts donuts cl-ppcre trivial-shell +doplus doplus doplus asdf parse-declarations-1.0 +doplus doplus-fset doplus-fset asdf doplus fset +doubly-linked-list doubly-linked-list doubly-linked-list alexandria asdf +drakma drakma drakma asdf chipz chunga cl+ssl cl-base64 cl-ppcre flexi-streams puri usocket +drakma drakma-test drakma-test asdf drakma fiveam +drakma-async drakma-async drakma-async alexandria cl-async-future cl-async-ssl drakma fast-http fast-io flexi-streams +draw-cons-tree draw-cons-tree draw-cons-tree +dso-lex dso-lex dso-lex cl-ppcre dso-util +dso-util dso-util dso-util cl-ppcre +dufy dufy dufy alexandria asdf cl-ppcre +dufy dufy dufy/core alexandria +dufy dufy dufy/examples alexandria dufy iterate lispbuilder-sdl lparallel +dufy dufy dufy/extra-data alexandria +dufy dufy dufy/hsluv alexandria +dufy dufy dufy/internal alexandria +dufy dufy dufy/munsell alexandria cl-ppcre +dufy dufy dufy/test alexandria cl-csv dufy fiveam iterate lispbuilder-sdl lparallel parse-float +duologue duologue duologue alexandria anaphora chronicity cl-ansi-text cl-fad cl-readline clavier drakma +dweet dweet dweet babel com.gigamonkeys.json drakma +dyna dyna dyna alexandria asdf cl-base64 cl-syntax-annot closer-mop dexador flexi-streams ironclad jsown local-time quri split-sequence sxql +dyna dyna-test dyna-test asdf dyna local-time prove prove-asdf +dynamic-classes dynamic-classes dynamic-classes metatilities-base +dynamic-classes dynamic-classes-test dynamic-classes-test dynamic-classes lift +dynamic-collect dynamic-collect dynamic-collect asdf +dynamic-mixins dynamic-mixins dynamic-mixins alexandria asdf closer-mop +eager-future eager-future eager-future bordeaux-threads +eager-future eager-future eager-future.test eager-future fiveam +eager-future2 eager-future2 eager-future2 asdf bordeaux-threads trivial-garbage +eager-future2 test.eager-future2 test.eager-future2 asdf eager-future2 eos +easing easing easing alexandria asdf +easing easing-demo easing-demo asdf easing sketch +easing easing-test easing-test asdf easing fiveam +easy-audio easy-audio easy-audio asdf flexi-streams +easy-audio easy-audio-examples easy-audio-examples asdf easy-audio +easy-audio easy-audio-tests easy-audio-tests asdf easy-audio fiveam flexi-streams +easy-bind easy-bind easy-bind asdf +easy-routes easy-routes easy-routes asdf hunchentoot routes +eazy-documentation eazy-documentation eazy-documentation alexandria asdf cl-ppcre cl-who common-doc common-doc-split-paragraphs common-html iterate trivia trivia.ppcre +eazy-gnuplot eazy-gnuplot eazy-gnuplot alexandria asdf iterate trivia uiop +eazy-gnuplot eazy-gnuplot.test eazy-gnuplot.test asdf eazy-gnuplot fiveam +eazy-process eazy-process eazy-process alexandria cffi cl-ppcre cl-rlimit iolib iterate optima optima.ppcre trivial-garbage +eazy-process eazy-process.test eazy-process.test eazy-process fiveam +eazy-project eazy-project eazy-project asdf bordeaux-threads cl-emb cl-ppcre cl-syntax cl-syntax-annot introspect-environment iterate lisp-namespace local-time trivia +eazy-project eazy-project.autoload eazy-project.autoload asdf eazy-project +eazy-project eazy-project.test eazy-project.test asdf eazy-project fiveam +ec2 ec2 ec2 drakma ironclad s-base64 s-xml +eclector eclector eclector acclimation alexandria asdf closer-mop +eclector eclector-concrete-syntax-tree eclector-concrete-syntax-tree alexandria asdf concrete-syntax-tree eclector +eclector eclector-concrete-syntax-tree eclector-concrete-syntax-tree/test alexandria eclector eclector-concrete-syntax-tree fiveam +eclector eclector eclector/test alexandria eclector fiveam +eco eco eco alexandria asdf cl-who esrap split-sequence +eco eco-test eco-test asdf eco fiveam +elb-log elb-log elb-log cl-annot-prove cl-ppcre cl-syntax cl-syntax-annot cl-syntax-interpol local-time zs3 +elb-log elb-log-test elb-log-test elb-log prove prove-asdf +electron-tools electron-tools electron-tools osicat trivial-download trivial-exe trivial-extract uiop +electron-tools electron-tools-test electron-tools-test electron-tools fiveam trivial-extract +elf elf elf alexandria asdf cl-ppcre com.gigamonkeys.binary-data flexi-streams metabang-bind split-sequence trivial-shell +elf elf elf/test alexandria elf metabang-bind stefil trivial-timeout +enhanced-eval-when enhanced-eval-when enhanced-eval-when +enhanced-multiple-value-bind enhanced-multiple-value-bind enhanced-multiple-value-bind +envy envy envy asdf +envy envy-test envy-test asdf cl-test-more envy osicat +eos eos eos +eos eos eos-tests eos +epigraph epigraph epigraph alexandria +epigraph epigraph epigraph-test epigraph fiveam +equals equals equals +ernestine ernestine ernestine cl-ppcre cl-prevalence drakma split-sequence +ernestine ernestine-tests ernestine-tests ernestine lisp-unit +erudite erudite erudite alexandria asdf cl-fad cl-ppcre cl-template log4cl split-sequence +erudite erudite-test erudite-test asdf erudite fiveam +escalator escalator escalator asdf iterate +escalator escalator-bench escalator-bench asdf escalator iterate +esrap esrap esrap alexandria asdf +esrap esrap esrap/tests esrap fiveam +esrap-liquid esrap-liquid esrap-liquid alexandria cl-interpol cl-ppcre iterate +esrap-liquid esrap-liquid esrap-liquid-tests cl-interpol esrap-liquid fiveam +esrap-peg esrap-peg esrap-peg alexandria asdf cl-unification esrap iterate +event-emitter event-emitter event-emitter asdf +event-emitter event-emitter-test event-emitter-test asdf event-emitter prove +event-glue event-glue event-glue +event-glue event-glue-test event-glue-test event-glue fiveam +eventbus eventbus eventbus asdf simplet-asdf +eventbus eventbus eventbus/test eventbus simplet simplet-asdf +eventfd eventfd eventfd alexandria cffi-grovel iolib +everblocking-stream everblocking-stream everblocking-stream asdf trivial-gray-streams +evol evol evol alexandria bordeaux-threads cl-fad cl-ppcre external-program patron unix-options +evol evol-test evol-test evol stefil +exit-hooks exit-hooks exit-hooks +exponential-backoff exponential-backoff exponential-backoff +exscribe exscribe exscribe alexandria fare-memoization fare-quasiquote-optima fare-scripts fare-utils quri scribble +exscribe exscribe exscribe/typeset cl-typesetting exscribe +ext-blog ext-blog ext-blog cl-fad cl-store closure-template image kl-verify local-time restas restas.file-publisher s-xml-rpc +extended-reals extended-reals extended-reals alexandria asdf +external-program external-program external-program asdf trivial-features +external-program external-program external-program-test external-program fiveam +external-symbol-not-found external-symbol-not-found external-symbol-not-found asdf +f-underscore f-underscore f-underscore +f2cl blas blas asdf blas-complex blas-package blas-real +f2cl blas-complex blas-complex asdf blas-real f2cl +f2cl blas-hompack blas-hompack asdf blas-package f2cl +f2cl blas-package blas-package asdf +f2cl blas-real blas-real asdf blas-hompack f2cl +f2cl colnew colnew asdf f2cl +f2cl colnew colnew/test-1 colnew +f2cl colnew colnew/test-2 colnew +f2cl colnew colnew/test-3 colnew +f2cl f2cl f2cl asdf f2cl-asdf +f2cl f2cl-asdf f2cl-asdf asdf +f2cl fishpack fishpack asdf f2cl +f2cl fishpack fishpack/test-hstcrt fishpack +f2cl fishpack fishpack/test-hstcsp fishpack +f2cl fishpack fishpack/test-hstcyl fishpack +f2cl fishpack fishpack/test-hstplr fishpack +f2cl fishpack fishpack/test-hstssp fishpack +f2cl fishpack fishpack/test-hwscrt fishpack +f2cl fishpack fishpack/test-hwscsp fishpack +f2cl fishpack fishpack/test-hwscyl fishpack +f2cl fishpack fishpack/test-hwsplr fishpack +f2cl fishpack fishpack/test-hwsssp fishpack +f2cl fishpack fishpack/test-sepx4 fishpack +f2cl hompack hompack asdf blas-hompack f2cl +f2cl hompack hompack/test-mainf hompack +f2cl hompack hompack/test-mainp hompack +f2cl hompack hompack/test-mains hompack +f2cl lapack lapack asdf blas-complex blas-package blas-real f2cl +f2cl lapack lapack/complex blas-complex blas-package blas-real +f2cl lapack lapack/package blas-package +f2cl lapack lapack/real blas-package blas-real +f2cl lapack lapack/tests lapack rt +f2cl minpack minpack asdf f2cl +f2cl minpack minpack/test-hybrd minpack +f2cl minpack minpack/test-lmdif minpack +f2cl odepack odepack asdf f2cl +f2cl odepack odepack/blas-util +f2cl odepack odepack/lsoda +f2cl odepack odepack/lsoda-demo +f2cl odepack odepack/lsodar +f2cl odepack odepack/lsodar-demo +f2cl odepack odepack/lsode +f2cl odepack odepack/lsode-demo +f2cl odepack odepack/lsodi-demo odepack +f2cl odepack odepack/lsodkr-demo odepack +f2cl odepack odepack/lsodpk-demo odepack +f2cl odepack odepack/lsoibt-demo odepack +f2cl odepack odepack/package +f2cl quadpack quadpack asdf f2cl +f2cl quadpack quadpack/mach-par +f2cl quadpack quadpack/tests quadpack rt +f2cl toms419 toms419 asdf f2cl +f2cl toms419 toms419/test toms419 +f2cl toms715 toms715 asdf f2cl +f2cl toms715 toms715/tests toms715 +f2cl toms717 toms717 asdf f2cl +f2cl toms717 toms717/tests toms717 +fact-base fact-base fact-base alexandria asdf cl-fad local-time optima +fare-csv fare-csv fare-csv +fare-memoization fare-memoization fare-memoization asdf +fare-memoization fare-memoization fare-memoization/test fare-memoization hu.dwim.stefil +fare-mop fare-mop fare-mop closer-mop fare-utils +fare-quasiquote fare-quasiquote fare-quasiquote asdf fare-utils +fare-quasiquote fare-quasiquote-extras fare-quasiquote-extras asdf fare-quasiquote-optima fare-quasiquote-readtable +fare-quasiquote fare-quasiquote-optima fare-quasiquote-optima asdf fare-quasiquote optima +fare-quasiquote fare-quasiquote-readtable fare-quasiquote-readtable asdf fare-quasiquote named-readtables +fare-quasiquote fare-quasiquote-test fare-quasiquote-test asdf fare-quasiquote-extras hu.dwim.stefil +fare-scripts fare-scripts fare-scripts asdf cl-scripting fare-utils inferior-shell +fare-utils fare-utils fare-utils asdf +fare-utils fare-utils-test fare-utils-test fare-utils hu.dwim.stefil +fast-http fast-http fast-http alexandria asdf babel cl-utilities proc-parse smart-buffer xsubseq +fast-http fast-http-test fast-http-test asdf babel cl-syntax-interpol fast-http prove prove-asdf xsubseq +fast-io fast-io fast-io alexandria static-vectors trivial-gray-streams +fast-io fast-io-test fast-io-test checkl fast-io fiveam +fast-websocket fast-websocket fast-websocket alexandria asdf fast-io trivial-utf-8 +fast-websocket fast-websocket-test fast-websocket-test asdf fast-io fast-websocket prove prove-asdf trivial-utf-8 +femlisp cl-cpu-affinity cl-cpu-affinity asdf cffi +femlisp ddo ddo alexandria asdf cl-mpi cl-mpi-extensions femlisp-basic femlisp-dictionary femlisp-parallel lfarm-admin lfarm-client lfarm-server trees uiop +femlisp dealii-tutorial dealii-tutorial asdf femlisp +femlisp femlisp femlisp asdf cl-ppcre femlisp-basic femlisp-dictionary femlisp-matlisp femlisp-parallel flexi-streams infix +femlisp femlisp-basic femlisp-basic asdf closer-mop fiveam +femlisp femlisp-dictionary femlisp-dictionary asdf femlisp-basic femlisp-parallel trees +femlisp femlisp-matlisp femlisp-matlisp asdf femlisp-basic femlisp-dictionary femlisp-parallel +femlisp femlisp-parallel femlisp-parallel asdf bordeaux-threads cl-cpu-affinity cl-ppcre femlisp-basic lparallel +femlisp femlisp-picture femlisp-picture asdf cl-gd femlisp +femlisp infix infix asdf +femlisp net.scipolis.graphs net.scipolis.graphs asdf femlisp-basic +ffa ffa ffa cffi cl-utilities iterate metabang-bind +fft fft fft asdf +fft pfft pfft asdf fft pcall +fiasco fiasco fiasco alexandria asdf trivial-gray-streams +fiasco fiasco fiasco-self-tests fiasco +file-local-variable file-local-variable file-local-variable alexandria iterate trivia +file-local-variable file-local-variable.test file-local-variable.test file-local-variable fiveam +file-select file-select file-select asdf cffi documentation-utils float-features trivial-features +file-types file-types file-types +filtered-functions filtered-functions filtered-functions closer-mop +find-port find-port find-port asdf usocket +find-port find-port-test find-port-test asdf find-port fiveam +firephp firephp firephp cl-json hunchentoot +firephp firephp-tests firephp-tests cl-json firephp hu.dwim.stefil hunchentoot +first-time-value first-time-value first-time-value asdf +first-time-value first-time-value_tests first-time-value_tests asdf first-time-value parachute +fiveam fiveam fiveam alexandria asdf net.didierverna.asdf-flv trivial-backtrace +fiveam fiveam fiveam/test fiveam +fiveam-asdf fiveam-asdf fiveam-asdf asdf +fixed fixed fixed +fixed fixed fixed/real-time fixed +fixed fixed fixed/test fiveam fixed +flac-metadata flac-metadata flac-metadata alexandria asdf parsley +flac-parser flac-parser flac-parser alexandria asdf babel bit-smasher fast-io +flare flare flare 3d-vectors array-utils asdf documentation-utils for lambda-fiddle trivial-garbage +flare flare-viewer flare-viewer asdf cl-opengl flare qtcore qtgui qtools qtopengl verbose +flexi-streams flexi-streams flexi-streams asdf trivial-gray-streams +flexi-streams flexi-streams flexi-streams-test flexi-streams +flexichain flexichain flexichain +flexichain flexichain-doc flexichain-doc +float-features float-features float-features asdf documentation-utils +floating-point floating-point floating-point +floating-point floating-point-test floating-point-test floating-point lisp-unit +floating-point-contractions floating-point-contractions floating-point-contractions +flow flow flow asdf closer-mop documentation-utils +flow flow-visualizer flow-visualizer asdf flow qtcore qtgui qtools +flute flute flute asdf assoc-utils let-over-lambda +flute flute-test flute-test asdf fiveam flute +fmt fmt fmt alexandria +fmt fmt-test fmt-test fiveam fmt +fmt fmt-time fmt-time fmt local-time +fn fn fn named-readtables +focus net.didierverna.focus net.didierverna.focus net.didierverna.focus.core net.didierverna.focus.flv net.didierverna.focus.setup +focus net.didierverna.focus.core net.didierverna.focus.core net.didierverna.focus.setup +focus net.didierverna.focus.demos.quotation net.didierverna.focus.demos.quotation net.didierverna.focus.flv +focus net.didierverna.focus.flv net.didierverna.focus.flv net.didierverna.asdf-flv net.didierverna.focus.core net.didierverna.focus.setup +focus net.didierverna.focus.setup net.didierverna.focus.setup +focus net.didierverna.focus.setup net.didierverna.focus.setup/flv net.didierverna.focus.setup +folio folio folio folio.as folio.boxes folio.collections folio.functions +folio folio.as folio.as +folio folio.boxes folio.boxes +folio folio.collections folio.collections folio.as folio.functions fset +folio folio.functions folio.functions +folio2 folio2 folio2 alexandria asdf folio2-as folio2-as-syntax folio2-boxes folio2-functions folio2-functions-syntax folio2-make folio2-maps folio2-maps-syntax folio2-pairs folio2-sequences folio2-sequences-syntax folio2-series folio2-taps fset series +folio2 folio2-as folio2-as asdf +folio2 folio2-as-syntax folio2-as-syntax asdf folio2-as +folio2 folio2-as-tests folio2-as-tests asdf folio2-as folio2-as-syntax lift +folio2 folio2-boxes folio2-boxes asdf folio2-as folio2-make +folio2 folio2-boxes-tests folio2-boxes-tests asdf folio2-boxes lift +folio2 folio2-functions folio2-functions alexandria asdf folio2-as folio2-make +folio2 folio2-functions-syntax folio2-functions-syntax alexandria asdf folio2-functions +folio2 folio2-functions-tests folio2-functions-tests asdf folio2-functions folio2-functions-syntax lift +folio2 folio2-make folio2-make asdf +folio2 folio2-make-tests folio2-make-tests asdf folio2-make lift +folio2 folio2-maps folio2-maps asdf folio2-as folio2-make fset +folio2 folio2-maps-syntax folio2-maps-syntax asdf folio2-maps +folio2 folio2-maps-tests folio2-maps-tests asdf folio2-maps folio2-maps-syntax lift +folio2 folio2-pairs folio2-pairs asdf folio2-as folio2-make +folio2 folio2-pairs-tests folio2-pairs-tests asdf folio2-pairs lift +folio2 folio2-sequences folio2-sequences asdf folio2-as folio2-make folio2-pairs fset series +folio2 folio2-sequences-syntax folio2-sequences-syntax asdf folio2-sequences +folio2 folio2-sequences-tests folio2-sequences-tests asdf folio2-sequences folio2-sequences-syntax lift +folio2 folio2-series folio2-series asdf folio2-as folio2-make folio2-pairs folio2-sequences fset series +folio2 folio2-series-tests folio2-series-tests asdf folio2-series lift +folio2 folio2-taps folio2-taps asdf closer-mop folio2-as folio2-make folio2-maps folio2-pairs folio2-sequences folio2-series fset +folio2 folio2-taps-tests folio2-taps-tests asdf folio2-taps lift +folio2 folio2-tests folio2-tests asdf folio2 +fomus fomus fomus +font-discovery font-discovery font-discovery asdf cffi documentation-utils trivial-features trivial-indent +for for for asdf documentation-utils form-fiddle lambda-fiddle +form-fiddle form-fiddle form-fiddle asdf documentation-utils +format-string-builder format-string-builder format-string-builder alexandria serapeum +formlets formlets formlets cl-ppcre cl-who drakma hunchentoot +formlets formlets-test formlets-test cl-ppcre cl-who drakma formlets hunchentoot +fred fred fred drakma s-xml +freebsd-sysctl freebsd-sysctl freebsd-sysctl asdf cffi +froute froute froute asdf cl-ppcre closer-mop +froute froute froute/hunchentoot froute hunchentoot +froute froute froute/test froute lisp-unit +frpc frpc frpc alexandria babel bordeaux-threads flexi-streams glass nibbles pounds usocket +frpc frpc frpc-des frpc ironclad +frpc frpc frpc-gss cerberus frpc +frpc frpcgen frpcgen cl-lex frpc yacc +fs-watcher fs-watcher fs-watcher alexandria com.gigamonkeys.pathnames +fset fset fset misc-extensions mt19937 +fsvd fsvd fsvd +fucc fucc-generator fucc-generator fucc-parser +fucc fucc-parser fucc-parser +function-cache function-cache function-cache alexandria asdf cl-interpol closer-mop iterate symbol-munger +function-cache function-cache-clsql function-cache-clsql asdf clsql clsql-helper function-cache +function-cache function-cache function-cache/test function-cache lisp-unit2 +fxml fxml fxml alexandria asdf babel flexi-streams named-readtables quri serapeum split-sequence trivial-gray-streams +fxml fxml fxml/css-selectors alexandria css-selectors fxml xpath +fxml fxml fxml/cxml cxml fxml +fxml fxml fxml/dom alexandria babel flexi-streams named-readtables quri serapeum split-sequence trivial-gray-streams +fxml fxml fxml/html5 alexandria cl-html5-parser fset fxml quri serapeum xpath +fxml fxml fxml/klacks alexandria babel flexi-streams named-readtables quri serapeum split-sequence trivial-gray-streams +fxml fxml fxml/runes babel named-readtables serapeum trivial-gray-streams +fxml fxml fxml/sanitize alexandria fxml quri serapeum +fxml fxml fxml/sanitize/test alexandria cl-html5-parser fiveam fset fxml quri serapeum xpath +fxml fxml fxml/stp alexandria fxml xpath +fxml fxml fxml/test alexandria babel cxml cxml-rng fiveam flexi-streams fxml named-readtables quri serapeum split-sequence trivial-gray-streams uiop xpath +fxml fxml fxml/xml alexandria babel flexi-streams named-readtables quri serapeum split-sequence trivial-gray-streams +fxml fxml fxml/xpath alexandria fxml xpath +gamebox-dgen gamebox-dgen gamebox-dgen alexandria asdf cl-speedy-queue genie graph simple-logger +gamebox-ecs gamebox-ecs gamebox-ecs alexandria asdf simple-logger +gamebox-frame-manager gamebox-frame-manager gamebox-frame-manager asdf local-time simple-logger +garbage-pools garbage-pools garbage-pools +garbage-pools garbage-pools-test garbage-pools-test garbage-pools lift +gcm gcm gcm babel com.gigamonkeys.json drakma +gendl base base asdf +gendl bus bus asdf gwl-graphics +gendl cl-lite cl-lite asdf glisp +gendl dom dom asdf cl-who yadd +gendl gendl gendl asdf cl-lite gwl-graphics robot tasty yadd +gendl gendl-asdf gendl-asdf asdf +gendl geom-base geom-base asdf base cl-pdf cl-typesetting cl-who +gendl glisp glisp asdf babel base bordeaux-threads cl-base64 cl-ppcre uiop +gendl gorg gorg asdf gwl-graphics html-template +gendl graphs graphs asdf gwl-graphics +gendl gwl gwl asdf cl-html-parse cl-who glisp yason zaserve +gendl gwl-graphics gwl-graphics asdf geom-base gwl +gendl ledger ledger asdf gwl +gendl regression regression asdf lift surf tasty +gendl robot robot asdf gwl-graphics +gendl setup-cffi setup-cffi asdf cffi +gendl surf surf asdf geom-base +gendl ta2 ta2 asdf gwl-graphics +gendl tasty tasty asdf gwl-graphics tree +gendl timer timer asdf cl-smtp gwl +gendl translators translators asdf gwl +gendl tree tree asdf gwl-graphics +gendl wire-world wire-world asdf gwl-graphics +gendl yadd yadd asdf cl-html-parse gwl-graphics +generators generators generators alexandria cl-cont iterate +generic-cl generic-cl generic-cl agutil alexandria anaphora asdf cl-arrows cl-custom-hash-table prove-asdf static-dispatch trivia +generic-cl generic-cl generic-cl/test generic-cl prove prove-asdf +generic-comparability generic-comparability generic-comparability alexandria asdf +generic-comparability generic-comparability generic-comparability-test alexandria fiveam generic-comparability +generic-sequences generic-sequences generic-sequences +generic-sequences generic-sequences-cont generic-sequences-cont cl-cont generic-sequences +generic-sequences generic-sequences-iterate generic-sequences-iterate generic-sequences iterate +generic-sequences generic-sequences-stream generic-sequences-stream bordeaux-threads generic-sequences +generic-sequences generic-sequences-test generic-sequences-test generic-sequences generic-sequences-cont generic-sequences-iterate generic-sequences-stream +geneva geneva geneva named-readtables split-sequence +geneva geneva-cl geneva-cl geneva geneva-mk2 named-readtables split-sequence trivial-documentation +geneva geneva-html geneva-html file-types geneva macro-html +geneva geneva-latex geneva-latex geneva geneva-tex named-readtables texp +geneva geneva-mk2 geneva-mk2 geneva maxpc split-sequence +geneva geneva-plain-text geneva-plain-text geneva geneva-mk2 +geneva geneva-tex geneva-tex file-types geneva named-readtables texp +geneva open-geneva open-geneva geneva geneva-cl geneva-html geneva-latex geneva-mk2 geneva-plain-text geneva-tex +genhash genhash genhash asdf +genie genie genie asdf cl-variates simple-logger +geowkt geowkt geowkt asdf +geowkt geowkt-update geowkt-update asdf drakma parse-number +getopt getopt getopt +getopt getopt getopt-tests getopt ptester +gettext gettext gettext flexi-streams split-sequence yacc +gettext gettext-example gettext-example gettext +gettext gettext-tests gettext-tests gettext stefil +git-file-history git-file-history git-file-history cl-ppcre legit local-time uiop +git-file-history git-file-history-test git-file-history-test fiveam git-file-history +glad-blob glad-blob glad-blob asdf bodge-blobs-support trivial-features +glass glass glass +glaw glaw glaw asdf cl-alc cl-openal cl-opengl +glaw glaw-examples glaw-examples asdf glaw glaw-imago glop +glaw glaw-imago glaw-imago asdf glaw imago +glaw glaw-sdl glaw-sdl asdf glaw lispbuilder-sdl lispbuilder-sdl-image +glfw-blob glfw-blob glfw-blob asdf bodge-blobs-support trivial-features +glisph glisph glisph cl-annot cl-glu cl-opengl cl-reexport zpb-ttf +glisph glisph-test glisph-test cl-glut glisph prove prove-asdf +glkit glkit glkit alexandria cl-opengl defpackage-plus mathkit static-vectors +glkit glkit-examples glkit-examples glkit sdl2kit-examples +global-vars global-vars global-vars +global-vars global-vars-test global-vars-test global-vars +glop glop glop cffi split-sequence trivial-garbage +glop glop-test glop-test cl-glu cl-opengl glop +glsl-packing glsl-packing glsl-packing alexandria asdf +glsl-spec glsl-docs glsl-docs asdf glsl-symbols +glsl-spec glsl-spec glsl-spec asdf +glsl-spec glsl-symbols glsl-symbols asdf +glsl-toolkit glsl-toolkit glsl-toolkit asdf cl-ppcre documentation-utils parse-float trivial-indent +glu-tessellate glu-tessellate glu-tessellate cffi +glyphs glyphs glyphs asdf cl-ppcre named-readtables parenscript +glyphs glyphs-test glyphs-test asdf glyphs stefil +golden-utils golden-utils golden-utils alexandria asdf uiop +gordon gordon gordon +graph graph graph alexandria asdf asdf-package-system curry-compose-reader-macros metabang-bind named-readtables +graylex graylex graylex alexandria cl-ppcre trivial-gray-streams +graylex graylex-m4-example graylex-m4-example cl-heredoc graylex +green-threads green-threads green-threads cl-async-future cl-cont +group-by group-by group-by alexandria iterate +group-by group-by group-by-test group-by lisp-unit2 +grovel-locally grovel-locally grovel-locally alexandria asdf cffi cffi-grovel cl-ppcre with-cached-reader-conditionals +gsll gsll gsll alexandria asdf cffi-grovel cffi-libffi foreign-array lisp-unit metabang-bind trivial-features trivial-garbage +gtk-tagged-streams gtk-tagged-streams gtk-tagged-streams asdf bordeaux-threads cl-cffi-gtk trivial-gray-streams +gtype gtype gtype alexandria asdf iterate trivia trivial-cltl2 trivialib.type-unify type-r +gtype gtype.test gtype.test asdf fiveam gtype +gzip-stream gzip-stream gzip-stream flexi-streams salza2 trivial-gray-streams +halftone halftone halftone asdf bordeaux-threads qtcore qtgui qtools qtopengl simple-tasks uiop verbose +harmony harmony harmony asdf bordeaux-threads cl-mixed flow +harmony harmony-alsa harmony-alsa asdf cffi harmony +harmony harmony-coreaudio harmony-coreaudio alexandria asdf cffi harmony +harmony harmony-flac harmony-flac asdf cl-flac harmony +harmony harmony-mp3 harmony-mp3 asdf cl-mpg123 harmony +harmony harmony-openal harmony-openal asdf cl-alc cl-openal harmony +harmony harmony-out123 harmony-out123 asdf cl-out123 harmony +harmony harmony-pulse harmony-pulse asdf cffi harmony +harmony harmony-simple harmony-simple asdf documentation-utils harmony harmony-alsa harmony-flac harmony-mp3 harmony-wav trivial-features +harmony harmony-wasapi harmony-wasapi asdf cffi harmony trivial-indent +harmony harmony-wav harmony-wav asdf cffi harmony static-vectors +hash-set hash-set hash-set alexandria optima +hash-set hash-set-tests hash-set-tests fiveam hash-set +hdf5-cffi hdf5-cffi hdf5-cffi asdf cffi cffi-grovel +hdf5-cffi hdf5-cffi.examples hdf5-cffi.examples asdf hdf5-cffi +hdf5-cffi hdf5-cffi.test hdf5-cffi.test asdf cffi cffi-grovel fiveam hdf5-cffi hdf5-cffi.examples +heap heap heap asdf +helambdap helambdap helambdap asdf cl-fad clad split-sequence xhtmlambda +hemlock hemlock.base hemlock.base alexandria bordeaux-threads cl-ppcre command-line-arguments conium iolib iterate osicat prepl trivial-gray-streams +hemlock hemlock.clx hemlock.clx clx hemlock.base +hemlock hemlock.qt hemlock.qt hemlock.base qt qt-repl +hemlock hemlock.tty hemlock.tty hemlock.base +hermetic hermetic hermetic asdf cl-pass clack +hh-aws hh-aws hh-aws cl-base64 drakma ironclad puri s-xml +hh-aws hh-aws hh-aws-tests hh-aws lisp-unit uuid +hh-redblack hh-redblack hh-redblack +hh-redblack hh-redblack hh-redblack-tests hh-redblack lisp-unit +hh-web hh-web hh-web bordeaux-threads cl-base64 cl-fad cl-ppcre drakma hunchentoot ironclad local-time log5 parenscript trivial-backtrace uuid vecto +hl7-client hl7-client hl7-client usocket +hl7-parser hl7-parser hl7-parser +horner horner horner alexandria asdf infix-math serapeum +horse-html horse-html horse-html asdf parenscript +horse-html horse-html horse-html/tests fiveam horse-html +house house house alexandria anaphora asdf bordeaux-threads cl-fad cl-json cl-ppcre flexi-streams lisp-unit optima session-token split-sequence trivial-features usocket +hspell hspell hspell cffi trivial-garbage +ht-simple-ajax ht-simple-ajax ht-simple-ajax hunchentoot +html-encode html-encode html-encode +html-entities html-entities html-entities cl-ppcre +html-entities html-entities html-entities-tests fiveam html-entities +html-template html-template html-template +http-body http-body http-body asdf babel cl-ppcre cl-utilities fast-http flexi-streams jonathan quri trivial-gray-streams +http-body http-body-test http-body-test asdf assoc-utils cl-ppcre flexi-streams http-body prove prove-asdf trivial-utf-8 +http-get-cache http-get-cache http-get-cache asdf drakma +http-parse http-parse http-parse babel cl-ppcre +http-parse http-parse-test http-parse-test babel eos http-parse +hu.dwim.asdf hu.dwim.asdf hu.dwim.asdf asdf uiop +hu.dwim.asdf hu.dwim.asdf.documentation hu.dwim.asdf.documentation asdf hu.dwim.asdf hu.dwim.presentation +hu.dwim.bluez hu.dwim.bluez hu.dwim.bluez alexandria cffi cffi-libffi hu.dwim.asdf +hu.dwim.bluez hu.dwim.bluez hu.dwim.bluez/fancy hu.dwim.asdf hu.dwim.bluez hu.dwim.def+hu.dwim.common hu.dwim.defclass-star+hu.dwim.def hu.dwim.syntax-sugar +hu.dwim.common hu.dwim.common hu.dwim.common alexandria anaphora closer-mop hu.dwim.asdf hu.dwim.common-lisp iterate metabang-bind +hu.dwim.common hu.dwim.common.documentation hu.dwim.common.documentation hu.dwim.asdf hu.dwim.common hu.dwim.presentation +hu.dwim.common-lisp hu.dwim.common-lisp hu.dwim.common-lisp hu.dwim.asdf +hu.dwim.common-lisp hu.dwim.common-lisp.documentation hu.dwim.common-lisp.documentation hu.dwim.asdf hu.dwim.common-lisp hu.dwim.presentation +hu.dwim.computed-class hu.dwim.computed-class hu.dwim.computed-class hu.dwim.asdf hu.dwim.def+hu.dwim.common hu.dwim.defclass-star+hu.dwim.def hu.dwim.syntax-sugar hu.dwim.util +hu.dwim.computed-class hu.dwim.computed-class+hu.dwim.logger hu.dwim.computed-class+hu.dwim.logger hu.dwim.asdf hu.dwim.computed-class hu.dwim.logger +hu.dwim.computed-class hu.dwim.computed-class+swank hu.dwim.computed-class+swank hu.dwim.asdf hu.dwim.computed-class swank +hu.dwim.computed-class hu.dwim.computed-class.documentation hu.dwim.computed-class.documentation hu.dwim.asdf hu.dwim.computed-class.test hu.dwim.presentation +hu.dwim.computed-class hu.dwim.computed-class.test hu.dwim.computed-class.test hu.dwim.asdf hu.dwim.computed-class+hu.dwim.logger hu.dwim.stefil+hu.dwim.def +hu.dwim.debug hu.dwim.debug hu.dwim.debug asdf hu.dwim.asdf hu.dwim.common hu.dwim.def+swank hu.dwim.defclass-star hu.dwim.util hu.dwim.walker swank +hu.dwim.debug hu.dwim.debug.documentation hu.dwim.debug.documentation asdf hu.dwim.asdf hu.dwim.debug.test hu.dwim.presentation +hu.dwim.debug hu.dwim.debug.test hu.dwim.debug.test asdf hu.dwim.asdf hu.dwim.debug hu.dwim.stefil+hu.dwim.def+swank +hu.dwim.def hu.dwim.def hu.dwim.def alexandria anaphora hu.dwim.asdf iterate metabang-bind +hu.dwim.def hu.dwim.def+cl-l10n hu.dwim.def+cl-l10n cl-l10n hu.dwim.asdf hu.dwim.def +hu.dwim.def hu.dwim.def+contextl hu.dwim.def+contextl contextl hu.dwim.asdf hu.dwim.def +hu.dwim.def hu.dwim.def+hu.dwim.common hu.dwim.def+hu.dwim.common hu.dwim.asdf hu.dwim.common hu.dwim.def +hu.dwim.def hu.dwim.def+hu.dwim.delico hu.dwim.def+hu.dwim.delico hu.dwim.asdf hu.dwim.def hu.dwim.delico +hu.dwim.def hu.dwim.def+swank hu.dwim.def+swank hu.dwim.asdf hu.dwim.def swank +hu.dwim.def hu.dwim.def.documentation hu.dwim.def.documentation hu.dwim.asdf hu.dwim.def.test hu.dwim.presentation +hu.dwim.def hu.dwim.def.namespace hu.dwim.def.namespace bordeaux-threads hu.dwim.asdf hu.dwim.def hu.dwim.util trivial-garbage +hu.dwim.def hu.dwim.def.test hu.dwim.def.test hu.dwim.asdf hu.dwim.common hu.dwim.stefil+hu.dwim.def optima +hu.dwim.defclass-star hu.dwim.defclass-star hu.dwim.defclass-star hu.dwim.asdf +hu.dwim.defclass-star hu.dwim.defclass-star+contextl hu.dwim.defclass-star+contextl contextl hu.dwim.asdf hu.dwim.defclass-star +hu.dwim.defclass-star hu.dwim.defclass-star+hu.dwim.def hu.dwim.defclass-star+hu.dwim.def hu.dwim.asdf hu.dwim.def hu.dwim.defclass-star +hu.dwim.defclass-star hu.dwim.defclass-star+hu.dwim.def+contextl hu.dwim.defclass-star+hu.dwim.def+contextl hu.dwim.asdf hu.dwim.defclass-star+contextl hu.dwim.defclass-star+hu.dwim.def +hu.dwim.defclass-star hu.dwim.defclass-star+swank hu.dwim.defclass-star+swank hu.dwim.asdf hu.dwim.defclass-star swank +hu.dwim.defclass-star hu.dwim.defclass-star.documentation hu.dwim.defclass-star.documentation hu.dwim.asdf hu.dwim.defclass-star.test hu.dwim.presentation +hu.dwim.defclass-star hu.dwim.defclass-star.test hu.dwim.defclass-star.test hu.dwim.asdf hu.dwim.common hu.dwim.defclass-star hu.dwim.stefil+hu.dwim.def+swank +hu.dwim.delico hu.dwim.delico hu.dwim.delico asdf contextl hu.dwim.asdf hu.dwim.def+hu.dwim.common hu.dwim.walker +hu.dwim.delico hu.dwim.delico.documentation hu.dwim.delico.documentation asdf hu.dwim.asdf hu.dwim.delico.test hu.dwim.presentation hu.dwim.walker.documentation +hu.dwim.delico hu.dwim.delico.test hu.dwim.delico.test asdf hu.dwim.asdf hu.dwim.def hu.dwim.delico hu.dwim.stefil+hu.dwim.def+swank hu.dwim.util +hu.dwim.graphviz hu.dwim.graphviz hu.dwim.graphviz cffi hu.dwim.asdf metabang-bind +hu.dwim.graphviz hu.dwim.graphviz.documentation hu.dwim.graphviz.documentation hu.dwim.asdf hu.dwim.graphviz.test hu.dwim.presentation +hu.dwim.graphviz hu.dwim.graphviz.test hu.dwim.graphviz.test hu.dwim.asdf hu.dwim.common hu.dwim.graphviz hu.dwim.stefil+hu.dwim.def+swank +hu.dwim.logger hu.dwim.logger hu.dwim.logger bordeaux-threads hu.dwim.asdf hu.dwim.def+hu.dwim.common hu.dwim.def.namespace hu.dwim.defclass-star+hu.dwim.def hu.dwim.util local-time +hu.dwim.logger hu.dwim.logger+iolib hu.dwim.logger+iolib hu.dwim.asdf hu.dwim.logger hu.dwim.util+iolib +hu.dwim.logger hu.dwim.logger+swank hu.dwim.logger+swank hu.dwim.asdf hu.dwim.logger swank +hu.dwim.logger hu.dwim.logger.documentation hu.dwim.logger.documentation hu.dwim.asdf hu.dwim.logger.test hu.dwim.presentation +hu.dwim.logger hu.dwim.logger.test hu.dwim.logger.test hu.dwim.asdf hu.dwim.logger hu.dwim.stefil+hu.dwim.def+swank +hu.dwim.partial-eval hu.dwim.partial-eval hu.dwim.partial-eval hu.dwim.asdf hu.dwim.common hu.dwim.def hu.dwim.defclass-star+hu.dwim.def+contextl hu.dwim.logger hu.dwim.syntax-sugar hu.dwim.util hu.dwim.walker swank +hu.dwim.partial-eval hu.dwim.partial-eval.documentation hu.dwim.partial-eval.documentation hu.dwim.asdf hu.dwim.partial-eval.test hu.dwim.presentation +hu.dwim.partial-eval hu.dwim.partial-eval.test hu.dwim.partial-eval.test hu.dwim.asdf hu.dwim.partial-eval hu.dwim.stefil+hu.dwim.def+swank hu.dwim.util +hu.dwim.perec hu.dwim.perec hu.dwim.perec asdf babel cl-containers cl-ppcre contextl hu.dwim.asdf hu.dwim.common hu.dwim.computed-class hu.dwim.def+contextl hu.dwim.def+hu.dwim.common hu.dwim.def+hu.dwim.delico hu.dwim.defclass-star+hu.dwim.def hu.dwim.logger hu.dwim.rdbms hu.dwim.serializer hu.dwim.syntax-sugar hu.dwim.util hu.dwim.walker ironclad local-time metacopy-with-contextl parse-number +hu.dwim.perec hu.dwim.perec+hu.dwim.quasi-quote.xml hu.dwim.perec+hu.dwim.quasi-quote.xml asdf hu.dwim.asdf hu.dwim.perec hu.dwim.quasi-quote.xml +hu.dwim.perec hu.dwim.perec+iolib hu.dwim.perec+iolib asdf hu.dwim.asdf hu.dwim.perec iolib +hu.dwim.perec hu.dwim.perec+swank hu.dwim.perec+swank asdf hu.dwim.asdf hu.dwim.perec swank +hu.dwim.perec hu.dwim.perec.all hu.dwim.perec.all asdf hu.dwim.asdf hu.dwim.perec.oracle hu.dwim.perec.postgresql hu.dwim.perec.sqlite +hu.dwim.perec hu.dwim.perec.all.test hu.dwim.perec.all.test asdf hu.dwim.asdf hu.dwim.perec.oracle.test hu.dwim.perec.postgresql.test hu.dwim.perec.sqlite.test +hu.dwim.perec hu.dwim.perec.documentation hu.dwim.perec.documentation asdf hu.dwim.asdf hu.dwim.perec.all.test hu.dwim.presentation +hu.dwim.perec hu.dwim.perec.oracle hu.dwim.perec.oracle asdf hu.dwim.asdf hu.dwim.perec hu.dwim.rdbms.oracle +hu.dwim.perec hu.dwim.perec.oracle.test hu.dwim.perec.oracle.test asdf hu.dwim.asdf hu.dwim.perec.oracle hu.dwim.perec.test +hu.dwim.perec hu.dwim.perec.postgresql hu.dwim.perec.postgresql asdf hu.dwim.asdf hu.dwim.perec hu.dwim.rdbms.postgresql +hu.dwim.perec hu.dwim.perec.postgresql.test hu.dwim.perec.postgresql.test asdf hu.dwim.asdf hu.dwim.perec.postgresql hu.dwim.perec.test +hu.dwim.perec hu.dwim.perec.sqlite hu.dwim.perec.sqlite asdf hu.dwim.asdf hu.dwim.perec hu.dwim.rdbms.sqlite +hu.dwim.perec hu.dwim.perec.sqlite.test hu.dwim.perec.sqlite.test asdf hu.dwim.asdf hu.dwim.perec.sqlite hu.dwim.perec.test +hu.dwim.perec hu.dwim.perec.test hu.dwim.perec.test asdf hu.dwim.asdf hu.dwim.perec+hu.dwim.quasi-quote.xml hu.dwim.perec+iolib hu.dwim.perec+swank hu.dwim.util.test +hu.dwim.presentation hu.dwim.presentation hu.dwim.presentation cl-graph+hu.dwim.graphviz contextl hu.dwim.asdf hu.dwim.def+contextl hu.dwim.logger hu.dwim.stefil+hu.dwim.def hu.dwim.util hu.dwim.web-server.application iolib moptilities +hu.dwim.presentation hu.dwim.presentation+cl-graph+cl-typesetting hu.dwim.presentation+cl-graph+cl-typesetting cl-graph hu.dwim.asdf hu.dwim.presentation+cl-typesetting +hu.dwim.presentation hu.dwim.presentation+cl-typesetting hu.dwim.presentation+cl-typesetting cl-typesetting hu.dwim.asdf hu.dwim.presentation +hu.dwim.presentation hu.dwim.presentation+hu.dwim.stefil hu.dwim.presentation+hu.dwim.stefil hu.dwim.asdf hu.dwim.presentation hu.dwim.stefil +hu.dwim.presentation hu.dwim.presentation+hu.dwim.web-server hu.dwim.presentation+hu.dwim.web-server hu.dwim.asdf hu.dwim.presentation hu.dwim.web-server +hu.dwim.quasi-quote hu.dwim.quasi-quote hu.dwim.quasi-quote babel babel-streams hu.dwim.asdf hu.dwim.common hu.dwim.defclass-star+hu.dwim.def hu.dwim.syntax-sugar hu.dwim.util hu.dwim.walker +hu.dwim.quasi-quote hu.dwim.quasi-quote.css hu.dwim.quasi-quote.css hu.dwim.asdf hu.dwim.quasi-quote +hu.dwim.quasi-quote hu.dwim.quasi-quote.documentation hu.dwim.quasi-quote.documentation hu.dwim.asdf hu.dwim.presentation hu.dwim.quasi-quote.test +hu.dwim.quasi-quote hu.dwim.quasi-quote.js hu.dwim.quasi-quote.js cl-ppcre hu.dwim.asdf hu.dwim.quasi-quote hu.dwim.util hu.dwim.walker +hu.dwim.quasi-quote hu.dwim.quasi-quote.pdf hu.dwim.quasi-quote.pdf cffi hu.dwim.asdf hu.dwim.quasi-quote +hu.dwim.quasi-quote hu.dwim.quasi-quote.test hu.dwim.quasi-quote.test cxml hu.dwim.asdf hu.dwim.quasi-quote hu.dwim.quasi-quote.css hu.dwim.quasi-quote.xml+hu.dwim.quasi-quote.js hu.dwim.stefil+hu.dwim.def+swank parse-number uiop +hu.dwim.quasi-quote hu.dwim.quasi-quote.xml hu.dwim.quasi-quote.xml hu.dwim.asdf hu.dwim.quasi-quote +hu.dwim.quasi-quote hu.dwim.quasi-quote.xml+cxml hu.dwim.quasi-quote.xml+cxml cxml hu.dwim.asdf hu.dwim.quasi-quote.xml +hu.dwim.quasi-quote hu.dwim.quasi-quote.xml+hu.dwim.quasi-quote.js hu.dwim.quasi-quote.xml+hu.dwim.quasi-quote.js hu.dwim.asdf hu.dwim.quasi-quote.js hu.dwim.quasi-quote.xml +hu.dwim.rdbms hu.dwim.rdbms hu.dwim.rdbms asdf babel hu.dwim.asdf hu.dwim.defclass-star+hu.dwim.def hu.dwim.logger hu.dwim.syntax-sugar hu.dwim.util hu.dwim.walker ironclad local-time +hu.dwim.rdbms hu.dwim.rdbms.all hu.dwim.rdbms.all asdf hu.dwim.asdf hu.dwim.rdbms.oracle hu.dwim.rdbms.postgresql hu.dwim.rdbms.sqlite +hu.dwim.rdbms hu.dwim.rdbms.all.test hu.dwim.rdbms.all.test asdf hu.dwim.asdf hu.dwim.rdbms.oracle.test hu.dwim.rdbms.postgresql.test hu.dwim.rdbms.sqlite.test +hu.dwim.rdbms hu.dwim.rdbms.documentation hu.dwim.rdbms.documentation asdf hu.dwim.asdf hu.dwim.presentation hu.dwim.rdbms.all.test +hu.dwim.rdbms hu.dwim.rdbms.oracle hu.dwim.rdbms.oracle asdf cffi hu.dwim.asdf hu.dwim.rdbms +hu.dwim.rdbms hu.dwim.rdbms.oracle.test hu.dwim.rdbms.oracle.test asdf hu.dwim.asdf hu.dwim.rdbms.oracle hu.dwim.rdbms.test +hu.dwim.rdbms hu.dwim.rdbms.postgresql hu.dwim.rdbms.postgresql asdf cl-postgres+local-time hu.dwim.asdf hu.dwim.rdbms +hu.dwim.rdbms hu.dwim.rdbms.postgresql.test hu.dwim.rdbms.postgresql.test asdf hu.dwim.asdf hu.dwim.rdbms.postgresql hu.dwim.rdbms.test +hu.dwim.rdbms hu.dwim.rdbms.sqlite hu.dwim.rdbms.sqlite asdf cffi hu.dwim.asdf hu.dwim.rdbms +hu.dwim.rdbms hu.dwim.rdbms.sqlite.test hu.dwim.rdbms.sqlite.test asdf hu.dwim.asdf hu.dwim.rdbms.sqlite hu.dwim.rdbms.test +hu.dwim.rdbms hu.dwim.rdbms.test hu.dwim.rdbms.test asdf hu.dwim.asdf hu.dwim.rdbms hu.dwim.stefil+hu.dwim.def+swank +hu.dwim.reiterate hu.dwim.reiterate hu.dwim.reiterate alexandria anaphora hu.dwim.asdf hu.dwim.common-lisp hu.dwim.def hu.dwim.defclass-star hu.dwim.syntax-sugar hu.dwim.util metabang-bind +hu.dwim.reiterate hu.dwim.reiterate+hu.dwim.logger hu.dwim.reiterate+hu.dwim.logger hu.dwim.asdf hu.dwim.logger hu.dwim.reiterate +hu.dwim.reiterate hu.dwim.reiterate hu.dwim.reiterate/test hu.dwim.asdf hu.dwim.debug hu.dwim.reiterate+hu.dwim.logger hu.dwim.stefil+hu.dwim.def+swank +hu.dwim.sdl hu.dwim.sdl hu.dwim.sdl alexandria asdf cffi cffi-libffi hu.dwim.asdf +hu.dwim.sdl hu.dwim.sdl hu.dwim.sdl/fancy alexandria cffi cffi-libffi hu.dwim.asdf hu.dwim.def+hu.dwim.common hu.dwim.defclass-star+hu.dwim.def hu.dwim.sdl hu.dwim.syntax-sugar +hu.dwim.sdl hu.dwim.sdl hu.dwim.sdl/gfx alexandria cffi cffi-libffi hu.dwim.sdl +hu.dwim.sdl hu.dwim.sdl hu.dwim.sdl/image alexandria cffi cffi-libffi hu.dwim.sdl +hu.dwim.sdl hu.dwim.sdl hu.dwim.sdl/ttf alexandria cffi cffi-libffi hu.dwim.sdl +hu.dwim.serializer hu.dwim.serializer hu.dwim.serializer babel hu.dwim.asdf hu.dwim.common hu.dwim.def hu.dwim.syntax-sugar hu.dwim.util +hu.dwim.serializer hu.dwim.serializer.documentation hu.dwim.serializer.documentation hu.dwim.asdf hu.dwim.presentation hu.dwim.serializer.test +hu.dwim.serializer hu.dwim.serializer.test hu.dwim.serializer.test hu.dwim.asdf hu.dwim.serializer hu.dwim.stefil+hu.dwim.def+swank +hu.dwim.stefil hu.dwim.stefil hu.dwim.stefil alexandria hu.dwim.asdf +hu.dwim.stefil hu.dwim.stefil+hu.dwim.def hu.dwim.stefil+hu.dwim.def hu.dwim.asdf hu.dwim.def hu.dwim.stefil +hu.dwim.stefil hu.dwim.stefil+hu.dwim.def+swank hu.dwim.stefil+hu.dwim.def+swank hu.dwim.asdf hu.dwim.def+swank hu.dwim.stefil+hu.dwim.def hu.dwim.stefil+swank +hu.dwim.stefil hu.dwim.stefil+swank hu.dwim.stefil+swank hu.dwim.asdf hu.dwim.stefil swank +hu.dwim.stefil hu.dwim.stefil hu.dwim.stefil/test hu.dwim.asdf hu.dwim.stefil +hu.dwim.syntax-sugar hu.dwim.syntax-sugar hu.dwim.syntax-sugar hu.dwim.asdf hu.dwim.common +hu.dwim.syntax-sugar hu.dwim.syntax-sugar.documentation hu.dwim.syntax-sugar.documentation hu.dwim.asdf hu.dwim.presentation hu.dwim.syntax-sugar.test +hu.dwim.syntax-sugar hu.dwim.syntax-sugar.test hu.dwim.syntax-sugar.test hu.dwim.asdf hu.dwim.stefil+hu.dwim.def+swank hu.dwim.syntax-sugar hu.dwim.walker +hu.dwim.syntax-sugar hu.dwim.syntax-sugar hu.dwim.syntax-sugar/lambda-with-bang-args hu.dwim.asdf hu.dwim.syntax-sugar hu.dwim.walker +hu.dwim.syntax-sugar hu.dwim.syntax-sugar hu.dwim.syntax-sugar/unicode hu.dwim.asdf hu.dwim.syntax-sugar +hu.dwim.uri hu.dwim.uri hu.dwim.uri asdf babel cl-ppcre hu.dwim.asdf hu.dwim.util iolib +hu.dwim.uri hu.dwim.uri.test hu.dwim.uri.test asdf hu.dwim.asdf hu.dwim.stefil+hu.dwim.def+swank hu.dwim.uri hu.dwim.util +hu.dwim.util hu.dwim.util hu.dwim.util hu.dwim.asdf hu.dwim.def+hu.dwim.common hu.dwim.defclass-star+hu.dwim.def hu.dwim.syntax-sugar +hu.dwim.util hu.dwim.util+iolib hu.dwim.util+iolib hu.dwim.asdf hu.dwim.util iolib +hu.dwim.util hu.dwim.util.documentation hu.dwim.util.documentation hu.dwim.asdf hu.dwim.presentation hu.dwim.stefil+hu.dwim.def+swank +hu.dwim.util hu.dwim.util.test hu.dwim.util.test babel babel-streams bordeaux-threads cl-l10n cl-ppcre closer-mop command-line-arguments cxml drakma hu.dwim.asdf hu.dwim.def hu.dwim.def+hu.dwim.common hu.dwim.def.namespace hu.dwim.defclass-star+hu.dwim.def hu.dwim.delico hu.dwim.logger hu.dwim.perec.postgresql hu.dwim.quasi-quote.xml hu.dwim.stefil+hu.dwim.def+swank hu.dwim.syntax-sugar hu.dwim.util hu.dwim.util+iolib hu.dwim.web-server.application iolib swank uiop +hu.dwim.util hu.dwim.util hu.dwim.util/authorization hu.dwim.asdf hu.dwim.defclass-star+hu.dwim.def hu.dwim.logger hu.dwim.partial-eval hu.dwim.util hu.dwim.walker +hu.dwim.util hu.dwim.util hu.dwim.util/command-line command-line-arguments hu.dwim.asdf hu.dwim.util uiop +hu.dwim.util hu.dwim.util hu.dwim.util/error-handling hu.dwim.asdf hu.dwim.defclass-star+hu.dwim.def hu.dwim.util +hu.dwim.util hu.dwim.util hu.dwim.util/error-handling+swank hu.dwim.asdf hu.dwim.defclass-star+hu.dwim.def hu.dwim.util swank +hu.dwim.util hu.dwim.util hu.dwim.util/finite-state-machine hu.dwim.asdf hu.dwim.def.namespace hu.dwim.defclass-star+hu.dwim.def hu.dwim.util +hu.dwim.util hu.dwim.util hu.dwim.util/flexml cl-ppcre cxml hu.dwim.asdf hu.dwim.def hu.dwim.def.namespace hu.dwim.defclass-star+hu.dwim.def hu.dwim.util +hu.dwim.util hu.dwim.util hu.dwim.util/i18n cl-l10n hu.dwim.asdf hu.dwim.util +hu.dwim.util hu.dwim.util hu.dwim.util/linear-mapping bordeaux-threads hu.dwim.asdf hu.dwim.util +hu.dwim.util hu.dwim.util hu.dwim.util/mop closer-mop hu.dwim.asdf hu.dwim.util +hu.dwim.util hu.dwim.util hu.dwim.util/production command-line-arguments hu.dwim.asdf hu.dwim.defclass-star+hu.dwim.def hu.dwim.logger hu.dwim.perec.postgresql hu.dwim.util hu.dwim.util+iolib hu.dwim.web-server.application iolib swank uiop +hu.dwim.util hu.dwim.util hu.dwim.util/soap babel babel-streams cl-ppcre cxml drakma hu.dwim.asdf hu.dwim.def hu.dwim.def.namespace hu.dwim.defclass-star+hu.dwim.def hu.dwim.logger hu.dwim.quasi-quote.xml hu.dwim.util +hu.dwim.util hu.dwim.util hu.dwim.util/source hu.dwim.asdf hu.dwim.def+hu.dwim.common hu.dwim.syntax-sugar hu.dwim.util swank +hu.dwim.util hu.dwim.util hu.dwim.util/standard-process hu.dwim.asdf hu.dwim.def.namespace hu.dwim.defclass-star+hu.dwim.def hu.dwim.delico hu.dwim.logger hu.dwim.util +hu.dwim.util hu.dwim.util hu.dwim.util/temporary-files hu.dwim.asdf hu.dwim.util+iolib iolib +hu.dwim.util hu.dwim.util hu.dwim.util/threads bordeaux-threads hu.dwim.asdf hu.dwim.def.namespace hu.dwim.util +hu.dwim.util hu.dwim.util hu.dwim.util/worker-group bordeaux-threads hu.dwim.asdf hu.dwim.defclass-star+hu.dwim.def hu.dwim.logger hu.dwim.util +hu.dwim.walker hu.dwim.walker hu.dwim.walker alexandria anaphora closer-mop contextl hu.dwim.asdf hu.dwim.common-lisp hu.dwim.def+contextl hu.dwim.defclass-star+hu.dwim.def hu.dwim.util metabang-bind +hu.dwim.walker hu.dwim.walker.documentation hu.dwim.walker.documentation hu.dwim.asdf hu.dwim.presentation hu.dwim.walker.test +hu.dwim.walker hu.dwim.walker.test hu.dwim.walker.test hu.dwim.asdf hu.dwim.stefil+hu.dwim.def hu.dwim.stefil+swank hu.dwim.util hu.dwim.walker +hu.dwim.web-server hu.dwim.web-server hu.dwim.web-server asdf babel babel-streams bordeaux-threads cffi cl+ssl hu.dwim.asdf hu.dwim.common hu.dwim.computed-class hu.dwim.def+cl-l10n hu.dwim.def+contextl hu.dwim.def+hu.dwim.delico hu.dwim.def.namespace hu.dwim.logger+iolib hu.dwim.quasi-quote.xml+hu.dwim.quasi-quote.js hu.dwim.syntax-sugar hu.dwim.uri hu.dwim.util hu.dwim.zlib iolib local-time parse-number rfc2109 rfc2388-binary swank +hu.dwim.web-server hu.dwim.web-server+swank hu.dwim.web-server+swank asdf hu.dwim.asdf hu.dwim.def+swank hu.dwim.web-server +hu.dwim.web-server hu.dwim.web-server.application hu.dwim.web-server.application asdf hu.dwim.asdf hu.dwim.web-server +hu.dwim.web-server hu.dwim.web-server.application+hu.dwim.perec hu.dwim.web-server.application+hu.dwim.perec asdf hu.dwim.asdf hu.dwim.perec hu.dwim.web-server.application +hu.dwim.web-server hu.dwim.web-server.application.test hu.dwim.web-server.application.test asdf hu.dwim.asdf hu.dwim.web-server.application hu.dwim.web-server.test +hu.dwim.web-server hu.dwim.web-server.documentation hu.dwim.web-server.documentation asdf hu.dwim.asdf hu.dwim.presentation hu.dwim.web-server.test +hu.dwim.web-server hu.dwim.web-server.test hu.dwim.web-server.test asdf drakma hu.dwim.asdf hu.dwim.computed-class+hu.dwim.logger hu.dwim.stefil+hu.dwim.def+swank hu.dwim.web-server hu.dwim.web-server+swank +hu.dwim.web-server hu.dwim.web-server.websocket hu.dwim.web-server.websocket asdf cl-base64 hu.dwim.asdf hu.dwim.web-server ironclad +hu.dwim.zlib hu.dwim.zlib hu.dwim.zlib alexandria cffi cffi-libffi hu.dwim.asdf +hu.dwim.zlib hu.dwim.zlib hu.dwim.zlib/fancy hu.dwim.asdf hu.dwim.def+hu.dwim.common hu.dwim.syntax-sugar hu.dwim.zlib +hu.dwim.zlib hu.dwim.zlib hu.dwim.zlib/test hu.dwim.asdf hu.dwim.stefil hu.dwim.zlib +huffman huffman huffman asdf +humbler humbler humbler asdf cl-ppcre closer-mop local-time north-core trivial-mimes yason +hunchensocket hunchensocket hunchensocket alexandria asdf bordeaux-threads chunga cl-fad flexi-streams hunchentoot ironclad trivial-backtrace trivial-utf-8 +hunchensocket hunchensocket hunchensocket-tests fiasco hunchensocket +hunchentools hunchentools hunchentools alexandria cl-ppcre hunchentoot ironclad +hunchentoot hunchentoot hunchentoot bordeaux-threads chunga cl+ssl cl-base64 cl-fad cl-ppcre flexi-streams md5 rfc2388 trivial-backtrace usocket +hunchentoot hunchentoot hunchentoot-dev cxml-stp hunchentoot hunchentoot-test swank xpath +hunchentoot hunchentoot hunchentoot-test cl-ppcre cl-who drakma hunchentoot +hunchentoot-auth hunchentoot-auth hunchentoot-auth bordeaux-threads cl-store cl-who hunchentoot +hunchentoot-cgi hunchentoot-cgi hunchentoot-cgi hunchentoot puri +hunchentoot-multi-acceptor hunchentoot-multi-acceptor hunchentoot-multi-acceptor asdf hunchentoot str usocket +hunchentoot-single-signon hunchentoot-single-signon hunchentoot-single-signon cl-base64 cl-gss hunchentoot split-sequence +hyperluminal-mem hyperluminal-mem hyperluminal-mem cffi osicat stmx swap-bytes trivial-features +hyperluminal-mem hyperluminal-mem hyperluminal-mem-test fiveam hyperluminal-mem log4cl +hyperobject hyperobject hyperobject clsql kmrcl +hyperobject hyperobject-tests hyperobject-tests hyperobject rt +hyperspec hyperspec hyperspec alexandria asdf +ia-hash-table ia-hash-table ia-hash-table alexandria split-sequence +ia-hash-table ia-hash-table.test ia-hash-table.test cl-interpol ia-hash-table log4cl mw-equiv prove prove-asdf +iclendar iclendar iclendar asdf cl-base64 closer-mop documentation-utils trivial-gray-streams +id3v2 id3v2 id3v2 babel trivial-gray-streams +id3v2 id3v2-test id3v2-test flexi-streams id3v2 prove prove-asdf +idna idna idna split-sequence +ieee-floats ieee-floats ieee-floats +ieee-floats ieee-floats ieee-floats-tests fiveam ieee-floats +illogical-pathnames illogical-pathnames illogical-pathnames +illusion illusion illusion alexandria asdf let-over-lambda named-readtables +illusion illusion-test illusion-test asdf fiveam illusion split-sequence +image image image flexi-streams gzip-stream skippy zpng +imago imago imago zlib +immutable-struct immutable-struct immutable-struct alexandria closer-mop trivia +incf-cl incf-cl incf-cl asdf cl-ppcre +incf-cl incf-cl incf-cl/tests fiasco incf-cl uiop +incognito-keywords incognito-keywords incognito-keywords enhanced-eval-when map-bind +incongruent-methods incongruent-methods incongruent-methods closer-mop +inferior-shell inferior-shell inferior-shell alexandria asdf fare-mop fare-quasiquote-extras fare-utils optima +inferior-shell inferior-shell inferior-shell/test hu.dwim.stefil inferior-shell +infix-dollar-reader infix-dollar-reader infix-dollar-reader cl-syntax +infix-dollar-reader infix-dollar-reader-test infix-dollar-reader-test infix-dollar-reader rt +infix-math infix-math infix-math asdf-package-system +injection injection injection cl-yaml +injection injection-test injection-test fiveam injection +inkwell inkwell inkwell alexandria asdf documentation-utils drakma local-time yason +inlined-generic-function inlined-generic-function inlined-generic-function alexandria asdf closer-mop introspect-environment iterate trivia +inlined-generic-function inlined-generic-function.test inlined-generic-function.test asdf fiveam inlined-generic-function +inner-conditional inner-conditional inner-conditional alexandria cl-syntax-annot iterate optima +inner-conditional inner-conditional-test inner-conditional-test cl-test-more inner-conditional +inotify inotify inotify cffi cffi-grovel iolib +inquisitor inquisitor inquisitor alexandria anaphora asdf +inquisitor inquisitor-flexi inquisitor-flexi asdf flexi-streams inquisitor +inquisitor inquisitor-flexi-test inquisitor-flexi-test asdf inquisitor-flexi prove prove-asdf +inquisitor inquisitor-test inquisitor-test asdf babel flexi-streams inquisitor prove prove-asdf +integral integral integral alexandria asdf cl-ppcre cl-syntax-annot clos-fixtures closer-mop dbi group-by iterate split-sequence sxql trivial-types +integral integral-test integral-test asdf integral local-time prove prove-asdf split-sequence uiop +integral-rest integral-rest integral-rest alexandria cl-inflector closer-mop integral jonathan map-set ningle +integral-rest integral-rest-test integral-rest-test integral integral-rest prove prove-asdf +intel-hex intel-hex intel-hex +intel-hex intel-hex-test intel-hex-test intel-hex prove prove-asdf +intercom intercom intercom alexandria bordeaux-threads hunchentoot jsown split-sequence +intercom intercom-examples intercom-examples intercom jsown +interface interface interface alexandria asdf global-vars +introspect-environment introspect-environment introspect-environment +introspect-environment introspect-environment-test introspect-environment-test fiveam introspect-environment +iolib iolib iolib asdf babel bordeaux-threads cffi idna iolib.asdf iolib.base iolib.conf iolib.grovel swap-bytes trivial-features +iolib iolib.asdf iolib.asdf alexandria asdf +iolib iolib.base iolib.base alexandria asdf iolib.asdf iolib.common-lisp iolib.conf split-sequence +iolib iolib.common-lisp iolib.common-lisp alexandria asdf iolib.asdf iolib.conf +iolib iolib.conf iolib.conf asdf iolib.asdf +iolib iolib.examples iolib.examples asdf bordeaux-threads iolib iolib.asdf iolib.base iolib.conf +iolib iolib.grovel iolib.grovel alexandria asdf cffi iolib.asdf iolib.base iolib.conf split-sequence uiop +iolib iolib.tests iolib.tests asdf cffi fiveam iolib iolib.asdf iolib.base iolib.conf iolib.grovel trivial-features +iolib iolib iolib/multiplex cffi iolib.asdf iolib.base iolib.conf iolib.grovel trivial-features +iolib iolib iolib/os cffi iolib.asdf iolib.base iolib.conf iolib.grovel trivial-features +iolib iolib iolib/pathnames cffi iolib.asdf iolib.base iolib.conf iolib.grovel trivial-features +iolib iolib iolib/sockets babel bordeaux-threads cffi idna iolib.asdf iolib.base iolib.conf iolib.grovel swap-bytes trivial-features +iolib iolib iolib/streams cffi iolib.asdf iolib.base iolib.conf iolib.grovel trivial-features +iolib iolib iolib/syscalls cffi iolib.asdf iolib.base iolib.conf iolib.grovel trivial-features +iolib iolib iolib/trivial-sockets babel bordeaux-threads cffi idna iolib.asdf iolib.base iolib.conf iolib.grovel swap-bytes trivial-features +iolib iolib iolib/zstreams bordeaux-threads cffi iolib.asdf iolib.base iolib.conf iolib.grovel trivial-features +ip-interfaces ip-interfaces ip-interfaces asdf cffi +ip-interfaces ip-interfaces-test ip-interfaces-test asdf ip-interfaces prove prove-asdf +irc-logger irc-logger irc-logger cl-irc cl-ppcre +ironclad ironclad ironclad asdf bordeaux-threads nibbles +ironclad ironclad-text ironclad-text asdf flexi-streams ironclad +ironclad ironclad ironclad/tests ironclad rt +iso-8601-date eclecticse.iso-8601-date eclecticse.iso-8601-date asdf local-time +iterate iterate iterate asdf +iterate iterate iterate/tests iterate +iterate-clsql iterate-clsql iterate-clsql clsql iterate +its its its asdf definitions-systems +its its_tests its_tests asdf its parachute +jenkins jenkins.api jenkins.api alexandria cl-json cl-ppcre closer-mop drakma iterate let-plus more-conditions puri split-sequence xml.location +jonathan jonathan jonathan asdf babel cl-annot cl-ppcre cl-syntax cl-syntax-annot fast-io proc-parse trivial-types +jonathan jonathan-test jonathan-test asdf jonathan legion prove prove-asdf +jose jose jose asdf +jp-numeral jp-numeral jp-numeral alexandria asdf babel +jp-numeral jp-numeral-test jp-numeral-test 1am alexandria asdf jp-numeral +jpl-queues jpl-queues jpl-queues bordeaux-threads jpl-util +js cl-js cl-js asdf cl-ppcre local-time parse-js +js-parser js-parser js-parser cl-ppcre +js-parser js-parser-tests js-parser-tests js-parser +json-mop json-mop json-mop anaphora asdf closer-mop yason +json-mop json-mop-tests json-mop-tests asdf fiveam json-mop +json-responses json-responses json-responses asdf cl-json hunchentoot +json-responses json-responses json-responses-test fiveam json-responses +json-streams json-streams json-streams +json-streams json-streams-tests json-streams-tests cl-quickcheck flexi-streams json-streams +jsonrpc jsonrpc jsonrpc asdf +jsown jsown jsown asdf +jsown jsown-tests jsown-tests asdf fiveam jsown +jwacs jwacs jwacs asdf cl-ppcre +jwacs jwacs-tests jwacs-tests asdf jwacs +kebab kebab kebab alexandria cl-interpol cl-ppcre split-sequence +kebab kebab-test kebab-test kebab prove prove-asdf +kenzo kenzo kenzo asdf +kenzo kenzo-test kenzo-test asdf fiveam kenzo +kl-verify kl-verify kl-verify image +km km km +kmrcl kmrcl kmrcl +kmrcl kmrcl-tests kmrcl-tests kmrcl rt +l-math l-math l-math asdf +l-system l-system l-system asdf iterate +l-system l-system-examples l-system-examples asdf l-system +laap laap laap bordeaux-threads cffi cl-base32 cl-ppcre uiop +lack lack lack asdf lack-component lack-util +lack lack-component lack-component asdf +lack lack-middleware-accesslog lack-middleware-accesslog asdf lack-util local-time +lack lack-middleware-auth-basic lack-middleware-auth-basic asdf cl-base64 split-sequence +lack lack-middleware-backtrace lack-middleware-backtrace asdf uiop +lack lack-middleware-csrf lack-middleware-csrf asdf lack-request lack-util +lack lack-middleware-mount lack-middleware-mount asdf lack-component +lack lack-middleware-session lack-middleware-session asdf cl-ppcre lack-request lack-response lack-util +lack lack-middleware-static lack-middleware-static alexandria asdf local-time trivial-mimes uiop +lack lack-request lack-request asdf circular-streams cl-ppcre http-body quri +lack lack-response lack-response asdf local-time quri +lack lack-session-store-dbi lack-session-store-dbi asdf cl-base64 dbi lack-middleware-session marshal trivial-utf-8 +lack lack-session-store-redis lack-session-store-redis asdf cl-base64 cl-redis lack-middleware-session marshal trivial-utf-8 +lack lack-test lack-test asdf cl-cookie flexi-streams lack quri +lack lack-util lack-util asdf ironclad +lack lack-util-writer-stream lack-util-writer-stream asdf babel trivial-gray-streams +lack t-lack t-lack asdf clack clack-v1-compat lack prove prove-asdf +lack t-lack-component t-lack-component asdf lack-component lack-test prove prove-asdf +lack t-lack-middleware-accesslog t-lack-middleware-accesslog asdf lack lack-test prove prove-asdf split-sequence +lack t-lack-middleware-auth-basic t-lack-middleware-auth-basic alexandria asdf cl-base64 lack lack-middleware-auth-basic lack-test prove prove-asdf +lack t-lack-middleware-backtrace t-lack-middleware-backtrace alexandria asdf lack lack-test prove prove-asdf +lack t-lack-middleware-csrf t-lack-middleware-csrf asdf cl-ppcre lack lack-middleware-csrf lack-request lack-test prove prove-asdf +lack t-lack-middleware-mount t-lack-middleware-mount asdf lack lack-component lack-middleware-mount lack-test prove prove-asdf +lack t-lack-middleware-session t-lack-middleware-session asdf cl-cookie lack lack-middleware-session lack-test prove prove-asdf +lack t-lack-middleware-static t-lack-middleware-static alexandria asdf lack lack-test prove prove-asdf +lack t-lack-request t-lack-request alexandria asdf clack-test dexador flexi-streams hunchentoot lack-request prove prove-asdf +lack t-lack-session-store-dbi t-lack-session-store-dbi asdf dbi lack lack-session-store-dbi lack-test prove prove-asdf sqlite +lack t-lack-session-store-redis t-lack-session-store-redis asdf lack lack-session-store-redis lack-test prove prove-asdf +lack t-lack-util t-lack-util asdf lack-test lack-util prove prove-asdf +lake lake lake asdf cl-syntax-interpol deploy +lake lake-test lake-test asdf lake prove prove-asdf +lambda-fiddle lambda-fiddle lambda-fiddle asdf +lambda-reader lambda-reader lambda-reader named-readtables +lambda-reader lambda-reader-8bit lambda-reader-8bit asdf asdf-encodings named-readtables +lambdalite lambdalite lambdalite bordeaux-threads wu-sugar +language-codes language-codes language-codes asdf documentation-utils +lass binary-lass binary-lass asdf lass +lass lass lass asdf cl-base64 trivial-indent trivial-mimes +lass-flexbox lass-flexbox lass-flexbox lass +lass-flexbox lass-flexbox-test lass-flexbox-test fiveam lass-flexbox +lassie lassie lassie fsvd +lastfm lastfm lastfm alexandria asdf defmemo drakma generators ironclad lquery plump trivial-open-browser +latex-table latex-table latex-table alexandria anaphora array-operations asdf let-plus +lazy lazy lazy asdf +legion legion legion vom +legion legion-test legion-test legion local-time prove prove-asdf +legit legit legit asdf cl-ppcre documentation-utils lambda-fiddle simple-inferiors uiop +let-over-lambda let-over-lambda let-over-lambda alexandria cl-ppcre named-readtables +let-over-lambda let-over-lambda-test let-over-lambda-test let-over-lambda named-readtables prove prove-asdf +let-plus let-plus let-plus alexandria anaphora asdf +let-plus let-plus let-plus/tests let-plus lift +letrec letrec letrec alexandria asdf +lev lev lev cffi +leveldb leveldb leveldb babel cffi cffi-grovel trivial-garbage +levenshtein levenshtein levenshtein +lfarm lfarm-admin lfarm-admin lfarm-common usocket +lfarm lfarm-client lfarm-client lfarm-common lparallel usocket +lfarm lfarm-common lfarm-common alexandria bordeaux-threads cl-store flexi-streams usocket +lfarm lfarm-gss lfarm-gss cl-gss lfarm-common trivial-gray-streams +lfarm lfarm-launcher lfarm-launcher external-program lfarm-admin lfarm-server +lfarm lfarm-server lfarm-server lfarm-common usocket +lfarm lfarm-ssl lfarm-ssl cl+ssl lfarm-common +lfarm lfarm-test lfarm-test lfarm-admin lfarm-client lfarm-launcher lfarm-server +lhstats lhstats lhstats +liblmdb liblmdb liblmdb cffi +lichat-ldap lichat-ldap lichat-ldap asdf documentation-utils lichat-serverlib trivial-ldap +lichat-protocol lichat-protocol lichat-protocol asdf closer-mop documentation-utils +lichat-serverlib lichat-serverlib lichat-serverlib asdf crypto-shortcuts documentation-utils lichat-protocol trivial-mimes +lichat-tcp-client lichat-tcp-client lichat-tcp-client asdf bordeaux-threads documentation-utils lichat-protocol usocket verbose +lichat-tcp-server lichat-tcp-server lichat-tcp-server asdf bordeaux-threads documentation-utils lichat-protocol lichat-serverlib usocket verbose +lichat-ws-server lichat-ws-server lichat-ws-server asdf bordeaux-threads documentation-utils hunchensocket lichat-protocol lichat-serverlib verbose +lift lift lift asdf +lift lift-documentation lift-documentation asdf lift +lift lift-test lift-test asdf lift +lila lila lila asdf +lime lime lime alexandria swank-protocol trivial-types +lime lime-example lime-example bordeaux-threads lime +lime lime-test lime-test alexandria external-program fiveam lime +linear-programming linear-programming linear-programming asdf +linear-programming linear-programming-test linear-programming-test asdf +linedit linedit linedit alexandria asdf cffi osicat terminfo +linewise-template linewise-template linewise-template cl-fad cl-ppcre +lionchat lionchat lionchat alexandria asdf bordeaux-threads cl-ppcre documentation-utils lichat-tcp-client qtcore qtgui qtools qtools-ui-listing qtools-ui-notification qtools-ui-options qtools-ui-repl qtsvg trivial-arguments ubiquitous verbose +lisa lisa lisa +lisp-binary lisp-binary lisp-binary asdf cffi closer-mop flexi-streams moptilities quasiquote-2.0 +lisp-binary lisp-binary-test lisp-binary-test asdf lisp-binary +lisp-chat lisp-chat lisp-chat asdf bordeaux-threads cl-readline usocket +lisp-chat lisp-chat lisp-chat/client bordeaux-threads cl-readline usocket +lisp-chat lisp-chat lisp-chat/server bordeaux-threads usocket +lisp-critic ckr-tables ckr-tables asdf +lisp-critic lisp-critic lisp-critic asdf ckr-tables +lisp-executable lisp-executable lisp-executable alexandria asdf +lisp-executable lisp-executable-example lisp-executable-example asdf lisp-executable +lisp-executable lisp-executable-tests lisp-executable-tests asdf lisp-executable lisp-unit +lisp-gflags com.google.flag com.google.flag com.google.base +lisp-gflags com.google.flag-test com.google.flag-test com.google.flag hu.dwim.stefil +lisp-interface-library lil lil asdf fare-memoization +lisp-interface-library lil lil/test +lisp-interface-library lisp-interface-library lisp-interface-library asdf lil +lisp-invocation lisp-invocation lisp-invocation asdf +lisp-invocation lisp-invocation lisp-invocation/all lisp-invocation +lisp-namespace lisp-namespace lisp-namespace alexandria +lisp-namespace lisp-namespace.test lisp-namespace.test fiveam lisp-namespace uiop +lisp-unit lisp-unit lisp-unit +lisp-unit2 lisp-unit2 lisp-unit2 alexandria asdf cl-interpol iterate symbol-munger +lisp-unit2 lisp-unit2 lisp-unit2-test lisp-unit2 +lisp-zmq zmq zmq bordeaux-threads cffi cffi-grovel trivial-features +lisp-zmq zmq-examples zmq-examples bordeaux-threads zmq +lisp-zmq zmq-test zmq-test bordeaux-threads fiveam zmq +lispbuilder cocoahelper cocoahelper asdf cffi lispbuilder-sdl-binaries +lispbuilder lispbuilder-lexer lispbuilder-lexer asdf lispbuilder-regex +lispbuilder lispbuilder-net lispbuilder-net asdf cffi lispbuilder-net-cffi +lispbuilder lispbuilder-net-cffi lispbuilder-net-cffi asdf cffi +lispbuilder lispbuilder-opengl-1-1 lispbuilder-opengl-1-1 asdf cffi +lispbuilder lispbuilder-opengl-examples lispbuilder-opengl-examples asdf cffi lispbuilder-opengl-1-1 lispbuilder-sdl +lispbuilder lispbuilder-regex lispbuilder-regex asdf +lispbuilder lispbuilder-sdl lispbuilder-sdl asdf cffi lispbuilder-sdl-assets lispbuilder-sdl-base trivial-garbage +lispbuilder lispbuilder-sdl-assets lispbuilder-sdl-assets asdf +lispbuilder lispbuilder-sdl-base lispbuilder-sdl-base asdf cffi lispbuilder-sdl-cffi +lispbuilder lispbuilder-sdl-binaries lispbuilder-sdl-binaries asdf +lispbuilder lispbuilder-sdl-cffi lispbuilder-sdl-cffi asdf cffi lispbuilder-sdl-binaries +lispbuilder lispbuilder-sdl-cl-vectors lispbuilder-sdl-cl-vectors asdf cl-aa-misc cl-paths-ttf cl-vectors lispbuilder-sdl zpb-ttf +lispbuilder lispbuilder-sdl-cl-vectors-examples lispbuilder-sdl-cl-vectors-examples asdf lispbuilder-sdl-cl-vectors +lispbuilder lispbuilder-sdl-examples lispbuilder-sdl-examples asdf lispbuilder-sdl +lispbuilder lispbuilder-sdl-gfx lispbuilder-sdl-gfx asdf cffi lispbuilder-sdl lispbuilder-sdl-gfx-cffi +lispbuilder lispbuilder-sdl-gfx-binaries lispbuilder-sdl-gfx-binaries asdf +lispbuilder lispbuilder-sdl-gfx-cffi lispbuilder-sdl-gfx-cffi asdf cffi lispbuilder-sdl +lispbuilder lispbuilder-sdl-gfx-examples lispbuilder-sdl-gfx-examples asdf lispbuilder-sdl-gfx +lispbuilder lispbuilder-sdl-image lispbuilder-sdl-image asdf cffi lispbuilder-sdl lispbuilder-sdl-image-cffi +lispbuilder lispbuilder-sdl-image-binaries lispbuilder-sdl-image-binaries asdf +lispbuilder lispbuilder-sdl-image-cffi lispbuilder-sdl-image-cffi asdf cffi lispbuilder-sdl lispbuilder-sdl-image-binaries +lispbuilder lispbuilder-sdl-image-examples lispbuilder-sdl-image-examples asdf cffi lispbuilder-sdl lispbuilder-sdl-image +lispbuilder lispbuilder-sdl-mixer lispbuilder-sdl-mixer asdf cffi lispbuilder-sdl lispbuilder-sdl-mixer-cffi +lispbuilder lispbuilder-sdl-mixer-binaries lispbuilder-sdl-mixer-binaries asdf +lispbuilder lispbuilder-sdl-mixer-cffi lispbuilder-sdl-mixer-cffi asdf cffi lispbuilder-sdl lispbuilder-sdl-mixer-binaries +lispbuilder lispbuilder-sdl-mixer-examples lispbuilder-sdl-mixer-examples asdf cffi lispbuilder-sdl lispbuilder-sdl-mixer +lispbuilder lispbuilder-sdl-ttf lispbuilder-sdl-ttf asdf cffi lispbuilder-sdl lispbuilder-sdl-ttf-cffi +lispbuilder lispbuilder-sdl-ttf-binaries lispbuilder-sdl-ttf-binaries asdf +lispbuilder lispbuilder-sdl-ttf-cffi lispbuilder-sdl-ttf-cffi asdf cffi lispbuilder-sdl lispbuilder-sdl-ttf-binaries +lispbuilder lispbuilder-sdl-ttf-examples lispbuilder-sdl-ttf-examples asdf cffi lispbuilder-sdl lispbuilder-sdl-ttf +lispbuilder lispbuilder-sdl-vecto lispbuilder-sdl-vecto asdf lispbuilder-sdl lispbuilder-sdl-cl-vectors vecto +lispbuilder lispbuilder-sdl-vecto-examples lispbuilder-sdl-vecto-examples asdf lispbuilder-sdl-vecto +lispbuilder lispbuilder-windows lispbuilder-windows asdf cffi +lispbuilder lispbuilder-yacc lispbuilder-yacc asdf +lispqr lispqr lispqr asdf zpng +listoflist listoflist listoflist clunit xarray +listopia listopia listopia asdf +listopia listopia-bench listopia-bench asdf listopia prove prove-asdf trivial-benchmark +listopia listopia-test listopia-test asdf listopia prove prove-asdf +literate-lisp literate-demo literate-demo asdf literate-lisp +literate-lisp literate-lisp literate-lisp asdf +livesupport livesupport livesupport asdf +lla lla lla alexandria anaphora asdf cffi cl-num-utils cl-slice let-plus +lla lla lla-tests clunit lla +lmdb lmdb lmdb alexandria liblmdb trivial-utf-8 +lmdb lmdb-test lmdb-test fiveam lmdb +lml lml lml +lml lml-tests lml-tests lml rt +lml2 lml2 lml2 kmrcl +lml2 lml2-tests lml2-tests lml2 rt +local-package-aliases local-package-aliases local-package-aliases +local-time cl-postgres+local-time cl-postgres+local-time asdf cl-postgres local-time +local-time local-time local-time asdf cl-fad +local-time local-time local-time/test local-time stefil +local-time-duration cl-postgres+local-time-duration cl-postgres+local-time-duration asdf cl-postgres local-time-duration +local-time-duration local-time-duration local-time-duration alexandria asdf esrap local-time +log4cl log4cl log4cl asdf bordeaux-threads +log4cl log4cl-examples log4cl-examples asdf log4cl swank +log4cl log4cl log4cl/syslog log4cl +log4cl log4cl log4cl/test log4cl stefil +log4cl log4slime log4slime asdf log4cl swank +log5 log5 log5 +lorem-ipsum lorem-ipsum lorem-ipsum asdf +lowlight lowlight lowlight alexandria cl-ppcre cl-who graylex spinneret yacc +lowlight lowlight.doc lowlight.doc cl-gendoc lowlight lowlight.tests +lowlight lowlight.old lowlight.old alexandria cl-ppcre cl-who spinneret +lowlight lowlight.tests lowlight.tests fiveam lowlight +lparallel lparallel lparallel alexandria bordeaux-threads +lparallel lparallel-bench lparallel-bench lparallel trivial-garbage +lparallel lparallel-test lparallel-test lparallel +lquery lquery lquery array-utils asdf clss form-fiddle plump +lquery lquery-test lquery-test asdf fiveam lquery +lredis lredis lredis babel babel-streams usocket +lsx cl-syntax-lsx cl-syntax-lsx asdf cl-syntax lsx +lsx lsx lsx asdf +lsx lsx lsx/tests rove +ltk ltk ltk asdf +ltk ltk-mw ltk-mw asdf ltk +ltk ltk-remote ltk-remote asdf ltk +lucerne lucerne lucerne alexandria asdf cl-annot cl-mustache clack clack-errors clack-v1-compat djula local-time log4cl myway trivial-types +lucerne lucerne-auth lucerne-auth asdf cl-pass lucerne +lucerne lucerne-hello-world lucerne-hello-world asdf lucerne +lucerne lucerne-test lucerne-test asdf drakma fiveam lucerne lucerne-hello-world lucerne-utweet +lucerne lucerne-utweet lucerne-utweet asdf avatar-api local-time lucerne lucerne-auth +lw-compat lw-compat lw-compat +lyrics lyrics lyrics alexandria asdf bordeaux-threads cl-ppcre defmemo drakma lquery plump sqlite +m2cl m2cl m2cl babel cl-json cl-ppcre flexi-streams salza2 zmq +m2cl m2cl-examples m2cl-examples bordeaux-threads m2cl +m2cl m2cl-test m2cl-test fiveam m2cl +macro-html macro-html macro-html named-readtables +macro-level macro-level macro-level +macrodynamics macrodynamics macrodynamics alexandria asdf +macrodynamics macrodynamics macrodynamics/test check-it fiasco macrodynamics +macroexpand-dammit macroexpand-dammit macroexpand-dammit +madeira-port madeira-port madeira-port +madeira-port madeira-port madeira-port-tests eos madeira-port +magicl magicl magicl alexandria asdf cffi cffi-libffi +magicl magicl-examples magicl-examples asdf magicl +magicl magicl-gen magicl-gen asdf cffi cffi-libffi +magicl magicl-tests magicl-tests asdf fiasco magicl magicl-examples magicl-transcendental uiop +magicl magicl-transcendental magicl-transcendental alexandria asdf cffi cffi-libffi magicl +maiden maiden maiden asdf bordeaux-threads closer-mop deeds documentation-utils form-fiddle lambda-fiddle trivial-garbage trivial-indent uuid verbose +maiden maiden-accounts maiden-accounts asdf maiden-client-entities maiden-commands maiden-storage +maiden maiden-activatable maiden-activatable asdf maiden maiden-commands maiden-storage +maiden maiden-api-access maiden-api-access asdf drakma jsown maiden plump +maiden maiden-blocker maiden-blocker asdf cl-ppcre maiden-client-entities maiden-commands maiden-storage +maiden maiden-chatlog maiden-chatlog asdf bordeaux-threads maiden-client-entities maiden-commands maiden-storage postmodern +maiden maiden-client-entities maiden-client-entities asdf documentation-utils maiden +maiden maiden-commands maiden-commands asdf lambda-fiddle maiden maiden-client-entities +maiden maiden-core-manager maiden-core-manager asdf maiden-client-entities maiden-commands maiden-storage +maiden maiden-counter maiden-counter asdf cl-ppcre maiden-activatable maiden-client-entities maiden-commands maiden-storage +maiden maiden-crimes maiden-crimes alexandria asdf cl-ppcre maiden-api-access maiden-client-entities maiden-commands maiden-storage +maiden maiden-dictionary maiden-dictionary asdf maiden-client-entities maiden-commands maiden-storage oxenfurt +maiden maiden-emoticon maiden-emoticon asdf cl-ppcre maiden-activatable maiden-client-entities maiden-commands maiden-storage +maiden maiden-help maiden-help asdf documentation-utils maiden-client-entities maiden-commands +maiden maiden-irc maiden-irc asdf babel cl-ppcre form-fiddle lambda-fiddle maiden-client-entities maiden-networking +maiden maiden-lastfm maiden-lastfm asdf bordeaux-threads maiden-api-access maiden-client-entities maiden-commands maiden-storage +maiden maiden-lichat maiden-lichat asdf lichat-protocol maiden-client-entities maiden-networking +maiden maiden-location maiden-location asdf maiden-api-access maiden-client-entities maiden-commands maiden-storage +maiden maiden-lookup maiden-lookup asdf cl-ppcre drakma lquery maiden-api-access maiden-client-entities maiden-commands +maiden maiden-markov maiden-markov alexandria asdf babel cl-ppcre fast-io maiden-activatable maiden-client-entities maiden-commands maiden-storage parse-number +maiden maiden-medals maiden-medals asdf cl-ppcre maiden-accounts maiden-client-entities maiden-commands maiden-storage +maiden maiden-networking maiden-networking asdf maiden usocket +maiden maiden-notify maiden-notify asdf maiden-accounts maiden-client-entities maiden-commands maiden-storage +maiden maiden-permissions maiden-permissions asdf cl-ppcre documentation-utils maiden-client-entities maiden-commands maiden-storage +maiden maiden-relay maiden-relay asdf maiden-networking maiden-serialize +maiden maiden-serialize maiden-serialize asdf cl-store gzip-stream maiden +maiden maiden-silly maiden-silly alexandria asdf cl-ppcre lquery maiden-activatable maiden-api-access maiden-client-entities maiden-commands +maiden maiden-storage maiden-storage asdf maiden pathname-utils ubiquitous-concurrent +maiden maiden-talk maiden-talk array-utils asdf drakma harmony harmony-flac harmony-mp3 harmony-pulse harmony-wav maiden-commands trivial-features +maiden maiden-throttle maiden-throttle asdf maiden-client-entities maiden-commands maiden-storage +maiden maiden-time maiden-time asdf maiden-api-access maiden-client-entities maiden-commands maiden-location +maiden maiden-trivia maiden-trivia alexandria asdf maiden-client-entities maiden-commands maiden-storage +maiden maiden-twitter maiden-twitter asdf chirp maiden-client-entities +maiden maiden-urlinfo maiden-urlinfo asdf cl-ppcre drakma maiden-activatable maiden-client-entities maiden-commands plump +maiden maiden-vote maiden-vote asdf cl-ppcre maiden-client-entities maiden-commands +maiden maiden-weather maiden-weather asdf local-time maiden-api-access maiden-client-entities maiden-commands maiden-location maiden-storage +mailbox mailbox mailbox bordeaux-threads +make-hash make-hash make-hash +make-hash make-hash-tests make-hash-tests fiveam make-hash +manifest manifest manifest alexandria closer-mop monkeylib-html puri split-sequence toot +map-bind map-bind map-bind +map-set map-set map-set asdf +marching-cubes marching-cubes marching-cubes +marching-cubes marching-cubes-example marching-cubes-example marching-cubes +marching-cubes marching-cubes-test marching-cubes-test cl-test-more marching-cubes +markdown.cl markdown.cl markdown.cl asdf cl-ppcre split-sequence xmls +markdown.cl markdown.cl-test markdown.cl-test asdf fiveam markdown.cl xmls +markup markup markup asdf named-readtables str +markup markup.test markup.test asdf fiveam markup +marshal fmarshal fmarshal closer-mop +marshal fmarshal-test fmarshal-test fiveam fmarshal +mathkit mathkit mathkit alexandria +maxpc maxpc maxpc +maxpc maxpc-test maxpc-test maxpc +mcclim automaton automaton asdf +mcclim clim clim asdf clim-core drei-mcclim +mcclim clim-basic clim-basic asdf babel bordeaux-threads clim-lisp flexichain spatial-trees trivial-features trivial-garbage +mcclim clim-core clim-core asdf clim-basic +mcclim clim-debugger clim-debugger asdf clouseau mcclim slim swank +mcclim clim-examples clim-examples alexandria asdf clim closer-mop mcclim mcclim-bezier mcclim-raster-image +mcclim clim-examples clim-examples/superapp bordeaux-threads mcclim +mcclim clim-lisp clim-lisp alexandria asdf closer-mop trivial-gray-streams +mcclim clim-listener clim-listener asdf cl-fad clim-debugger mcclim uiop +mcclim clim-pdf clim-pdf asdf cl-pdf clim-basic clim-postscript-font flexi-streams +mcclim clim-pdf clim-pdf/test clim-pdf fiveam mcclim +mcclim clim-postscript clim-postscript asdf clim-basic clim-postscript-font +mcclim clim-postscript-font clim-postscript-font asdf clim-basic mcclim-backend-common +mcclim clim-postscript clim-postscript/test clim-postscript fiveam mcclim +mcclim clouseau clouseau asdf closer-mop mcclim +mcclim clouseau clouseau/test clouseau fiveam +mcclim conditional-commands conditional-commands asdf clim-basic +mcclim drei-mcclim drei-mcclim asdf automaton clim-core esa-mcclim flexichain mcclim-fonts persistent swank +mcclim drei-mcclim drei-mcclim/test automaton drei-mcclim fiveam +mcclim esa-mcclim esa-mcclim alexandria asdf clim-core +mcclim functional-geometry functional-geometry asdf clim-listener +mcclim mcclim mcclim alexandria asdf cl-aa cl-paths-ttf cl-vectors clim clim-basic clim-pdf clim-postscript conditional-commands mcclim-bezier mcclim-bitmaps mcclim-clx mcclim-clx-fb mcclim-franz mcclim-image mcclim-null zpb-ttf +mcclim mcclim-backend-common mcclim-backend-common asdf clim +mcclim mcclim-bezier mcclim-bezier asdf clim clim-pdf clim-postscript mcclim-clx mcclim-null mcclim-render +mcclim mcclim-bezier mcclim-bezier/clx clim clim-pdf clim-postscript mcclim-clx mcclim-null mcclim-render +mcclim mcclim-bezier mcclim-bezier/core clim clim-pdf clim-postscript mcclim-null mcclim-render +mcclim mcclim-bitmaps mcclim-bitmaps asdf clim-basic opticl +mcclim mcclim-clx mcclim-clx alexandria asdf cl-unicode clx mcclim-backend-common mcclim-fonts +mcclim mcclim-clx-fb mcclim-clx-fb asdf mcclim-backend-common mcclim-clx mcclim-render +mcclim mcclim-clx mcclim-clx/truetype alexandria cl-aa cl-paths-ttf cl-vectors clim-basic mcclim-clx zpb-ttf +mcclim mcclim-fonts mcclim-fonts asdf clim-basic +mcclim mcclim-fonts mcclim-fonts/clx-truetype alexandria cl-aa cl-paths-ttf cl-vectors clim-basic mcclim-clx zpb-ttf +mcclim mcclim-fonts mcclim-fonts/truetype alexandria cl-aa cl-paths-ttf cl-vectors clim-basic zpb-ttf +mcclim mcclim-franz mcclim-franz asdf clim +mcclim mcclim-image mcclim-image asdf clim-basic mcclim-bitmaps opticl +mcclim mcclim-layouts mcclim-layouts asdf +mcclim mcclim-layouts mcclim-layouts/tab clim +mcclim mcclim-null mcclim-null asdf clim +mcclim mcclim-raster-image mcclim-raster-image asdf clim-basic mcclim-backend-common mcclim-render +mcclim mcclim-raster-image mcclim-raster-image/test fiveam mcclim mcclim-image mcclim-raster-image +mcclim mcclim-render mcclim-render alexandria asdf cl-aa cl-paths-ttf cl-vectors clim-basic zpb-ttf +mcclim mcclim-tree-with-cross-edges mcclim-tree-with-cross-edges asdf mcclim +mcclim mcclim mcclim/extensions clim clim-pdf clim-postscript conditional-commands mcclim-bezier mcclim-bitmaps mcclim-franz mcclim-image +mcclim mcclim mcclim/looks alexandria cl-aa cl-paths-ttf cl-vectors clim clim-basic mcclim-clx mcclim-clx-fb mcclim-null zpb-ttf +mcclim mcclim mcclim/test fiveam mcclim +mcclim mcclim mcclim/test-util mcclim +mcclim persistent persistent asdf +mcclim scigraph scigraph asdf mcclim +mcclim scigraph scigraph/dwim mcclim +mcclim slim slim asdf mcclim +md5 md5 md5 asdf +media-types media-types media-types alexandria asdf cl-ppcre serapeum +media-types media-types media-types/tests fiveam media-types +mel-base mel-base mel-base asdf cl+ssl flexi-streams usocket +memoize memoize memoize +message-oo message-oo message-oo +meta meta meta named-readtables +meta-sexp meta-sexp meta-sexp +metabang-bind metabang-bind metabang-bind asdf +metabang-bind metabang-bind-test metabang-bind-test asdf lift metabang-bind +metacopy metacopy metacopy moptilities +metacopy metacopy-with-contextl metacopy-with-contextl contextl metacopy +metacopy metacopy-with-contextl metacopy-with-contextl/test lift metacopy metacopy-with-contextl +metacopy metacopy metacopy/test lift metacopy +metap metap metap closer-mop +metap metap-test metap-test fiveam metap +metatilities metatilities metatilities asdf asdf-system-connections cl-containers metabang-bind metatilities-base moptilities +metatilities metatilities-test metatilities-test asdf lift metatilities +metatilities metatilities metatilities/with-lift lift metatilities-base +metatilities-base metatilities-base metatilities-base asdf +metatilities-base metatilities-base-test metatilities-base-test asdf lift metatilities-base +metering metering metering +metering metering metering/test fiveam metering +method-combination-utilities method-combination-utilities method-combination-utilities closer-mop +method-combination-utilities method-combination-utilities method-combination-utilities.tests fiveam method-combination-utilities +method-hooks method-hooks method-hooks asdf +method-hooks method-hooks-test method-hooks-test asdf method-hooks parachute uiop +method-versions method-versions method-versions +mexpr mexpr mexpr alexandria cl-syntax +mexpr mexpr-tests mexpr-tests mexpr named-readtables should-test +mgl-pax mgl-pax mgl-pax 3bmd 3bmd-ext-code-blocks alexandria asdf babel cl-fad colorize ironclad named-readtables pythonic-string-reader swank +mgl-pax mgl-pax-test mgl-pax-test asdf mgl-pax +micmac micmac micmac mgl-pax +micmac micmac-test micmac-test micmac +midi midi midi +minheap minheap minheap +minheap minheap-tests minheap-tests lisp-unit minheap +mini-cas mini-cas mini-cas +misc-extensions misc-extensions misc-extensions +mito lack-middleware-mito lack-middleware-mito asdf cl-dbi mito-core +mito mito mito asdf cl-reexport lack-middleware-mito mito-core mito-migration +mito mito-core mito-core alexandria asdf cl-ppcre cl-reexport closer-mop dbi dissect local-time optima sxql uuid +mito mito-migration mito-migration alexandria asdf cl-reexport closer-mop dbi esrap mito-core sxql uiop +mito mito-test mito-test asdf mito prove prove-asdf +mito-attachment mito-attachment mito-attachment alexandria asdf cl-reexport lack-component mito trivial-mimes uiop uuid zs3 +mito-auth mito-auth mito-auth babel ironclad mito +mixalot flac flac cffi cffi-grovel +mixalot mixalot mixalot alexandria bordeaux-threads cffi +mixalot mixalot-flac mixalot-flac cffi flac mixalot +mixalot mixalot-mp3 mixalot-mp3 cffi mixalot mpg123-ffi +mixalot mixalot-vorbis mixalot-vorbis cffi mixalot vorbisfile-ffi +mixalot mpg123-ffi mpg123-ffi cffi +mixalot vorbisfile-ffi vorbisfile-ffi cffi cffi-grovel +mk-string-metrics mk-string-metrics mk-string-metrics asdf +mk-string-metrics mk-string-metrics-tests mk-string-metrics-tests asdf mk-string-metrics +mmap mmap mmap asdf cffi documentation-utils trivial-features +mmap mmap-test mmap-test alexandria asdf cffi mmap parachute +mockingbird mockingbird mockingbird +mockingbird mockingbird-test mockingbird-test mockingbird prove prove-asdf +modest-config modest-config modest-config asdf +modest-config modest-config-test modest-config-test asdf modest-config prove prove-asdf +modf modf modf alexandria asdf closer-mop iterate +modf modf-test modf-test asdf iterate modf stefil +modf-fset modf-fset modf-fset fset modf +modf-fset modf-fset-test modf-fset-test modf modf-fset stefil +modularize modularize modularize asdf documentation-utils +modularize modularize-test-module modularize-test-module asdf modularize +modularize-hooks modularize-hooks modularize-hooks asdf closer-mop lambda-fiddle modularize trivial-arguments +modularize-interfaces interfaces-test-implementation interfaces-test-implementation asdf modularize modularize-interfaces +modularize-interfaces modularize-interfaces modularize-interfaces asdf lambda-fiddle modularize trivial-arguments trivial-indent +moira moira moira alexandria bordeaux-threads osicat serapeum trivial-features trivial-garbage +monkeylib-binary-data com.gigamonkeys.binary-data com.gigamonkeys.binary-data alexandria +monkeylib-html monkeylib-html monkeylib-html asdf com.gigamonkeys.macro-utilities com.gigamonkeys.pathnames com.gigamonkeys.test-framework com.gigamonkeys.utilities monkeylib-text-languages monkeylib-text-output +monkeylib-json com.gigamonkeys.json com.gigamonkeys.json asdf com.gigamonkeys.parser com.gigamonkeys.utilities +monkeylib-macro-utilities com.gigamonkeys.macro-utilities com.gigamonkeys.macro-utilities +monkeylib-markup com.gigamonkeys.markup com.gigamonkeys.markup cl-ppcre com.gigamonkeys.pathnames com.gigamonkeys.utilities +monkeylib-markup-html monkeylib-markup-html monkeylib-markup-html alexandria com.gigamonkeys.macro-utilities com.gigamonkeys.markup com.gigamonkeys.utilities monkeylib-html +monkeylib-parser com.gigamonkeys.parser com.gigamonkeys.parser com.gigamonkeys.macro-utilities com.gigamonkeys.utilities +monkeylib-pathnames com.gigamonkeys.pathnames com.gigamonkeys.pathnames +monkeylib-prose-diff com.gigamonkeys.prose-diff com.gigamonkeys.prose-diff cl-ppcre com.gigamonkeys.macro-utilities com.gigamonkeys.markup com.gigamonkeys.pathnames com.gigamonkeys.utilities monkeylib-markup-html +monkeylib-test-framework com.gigamonkeys.test-framework com.gigamonkeys.test-framework com.gigamonkeys.macro-utilities +monkeylib-text-languages monkeylib-text-languages monkeylib-text-languages com.gigamonkeys.macro-utilities monkeylib-text-output +monkeylib-text-output monkeylib-text-output monkeylib-text-output com.gigamonkeys.macro-utilities com.gigamonkeys.pathnames com.gigamonkeys.test-framework com.gigamonkeys.utilities +monkeylib-utilities com.gigamonkeys.utilities com.gigamonkeys.utilities alexandria split-sequence +montezuma lucene-in-action-tests lucene-in-action-tests asdf lift montezuma +montezuma montezuma montezuma asdf babel cl-fad cl-ppcre +montezuma montezuma-indexfiles montezuma-indexfiles asdf cl-fad montezuma +montezuma montezuma montezuma-tests montezuma trivial-timeout +mop-utils mop-utils mop-utils +moptilities moptilities moptilities closer-mop +moptilities moptilities-test moptilities-test lift moptilities +more-conditions more-conditions more-conditions alexandria asdf closer-mop +more-conditions more-conditions more-conditions/test fiveam let-plus more-conditions +mp3-duration mp3-duration mp3-duration +mp3-duration mp3-duration-test mp3-duration-test mp3-duration prove prove-asdf +mpc mpc mpc +mra-wavelet-plot mra-wavelet-plot mra-wavelet-plot asdf +mt19937 mt19937 mt19937 +mtif mtif mtif cffi +mtlisp mtlisp mtlisp acl-compat +multilang-documentation multilang-documentation multilang-documentation asdf documentation-utils language-codes system-locale +multiple-value-variants multiple-value-variants multiple-value-variants enhanced-multiple-value-bind map-bind positional-lambda +multiposter multiposter multiposter asdf cl-ppcre documentation-utils +multiposter multiposter-git multiposter-git asdf legit multiposter +multiposter multiposter-mastodon multiposter-mastodon asdf multiposter tooter +multiposter multiposter-studio multiposter-studio asdf multiposter north-dexador studio-client +multiposter multiposter-tumblr multiposter-tumblr asdf humbler multiposter north-dexador +multiposter multiposter-twitter multiposter-twitter asdf chirp multiposter +multival-plist multival-plist multival-plist alexandria cl-annot cl-syntax-annot trivial-types +multival-plist multival-plist-test multival-plist-test cl-test-more multival-plist +mw-equiv mw-equiv mw-equiv +mystic mystic mystic anaphora cl-mustache local-time split-sequence +mystic mystic-file-mixin mystic-file-mixin mystic +mystic mystic-fiveam-mixin mystic-fiveam-mixin mystic mystic-file-mixin +mystic mystic-gitignore-mixin mystic-gitignore-mixin mystic mystic-file-mixin +mystic mystic-library-template mystic-library-template mystic mystic-fiveam-mixin mystic-gitignore-mixin mystic-readme-mixin mystic-travis-mixin +mystic mystic-readme-mixin mystic-readme-mixin mystic mystic-file-mixin +mystic mystic-test mystic-test fiveam mystic mystic-library-template +mystic mystic-travis-mixin mystic-travis-mixin mystic mystic-file-mixin +myway myway myway alexandria asdf cl-ppcre cl-utilities map-set quri +myway myway-test myway-test asdf myway prove prove-asdf +myweb myweb myweb bordeaux-threads cl-log local-time trivial-utf-8 usocket +named-read-macros named-read-macros named-read-macros asdf named-readtables +named-read-macros named-read-macros-test named-read-macros-test asdf fiveam named-read-macros uiop +named-readtables named-readtables named-readtables asdf +named-readtables named-readtables named-readtables/doc mgl-pax named-readtables +named-readtables named-readtables named-readtables/test named-readtables +nanovg-blob nanovg-blob nanovg-blob asdf bodge-blobs-support glad-blob trivial-features +napa-fft3 napa-fft3 napa-fft3 +narrowed-types narrowed-types narrowed-types asdf +narrowed-types narrowed-types-test narrowed-types-test asdf narrowed-types rt +neo4cl neo4cl neo4cl asdf cl-base64 cl-json cl-ppcre drakma flexi-streams +neo4cl neo4cl-test neo4cl-test asdf fiveam neo4cl +net-telent-date net-telent-date net-telent-date +network-addresses network-addresses network-addresses cl-ppcre +network-addresses network-addresses-test network-addresses-test fiveam network-addresses +new-op new-op new-op asdf +nibbles nibbles nibbles asdf +nibbles nibbles nibbles/tests nibbles rt +nineveh nineveh nineveh asdf cepl cl-soil dendrite.primitives documentation-utils easing livesupport rtg-math.vari with-setf +ningle ningle ningle asdf cl-syntax-annot +ningle ningle-test ningle-test asdf babel clack-test drakma ningle prove yason +nodgui nodgui nodgui alexandria asdf bordeaux-threads cl-colors2 cl-jpeg cl-lex cl-ppcre-unicode cl-unicode clunit2 named-readtables parse-number yacc +north north north asdf north-drakma +north north-core north-core asdf cl-ppcre crypto-shortcuts documentation-utils uuid +north north-dexador north-dexador asdf dexador north-core +north north-drakma north-drakma asdf drakma north-core +north north-example north-example asdf clip drakma hunchentoot north +nsort nsort nsort prove +nst asdf-nst asdf-nst +nst comp-set comp-set +nst mnst-relay mnst-relay asdf-nst nst nst-selftest-utils +nst nst nst closer-mop org-sampler +nst nst-manual-tests nst-manual-tests asdf-nst nst nst-selftest-utils +nst nst-meta-tests nst-meta-tests asdf-nst nst nst-selftest-utils +nst nst-mop-utils nst-mop-utils closer-mop nst +nst nst-selftest-utils nst-selftest-utils nst +nst nst-simple-tests nst-simple-tests asdf-nst nst nst-selftest-utils +nst nst-test nst-test asdf-nst nst nst-meta-tests nst-simple-tests +nst nst-test-jenkins nst-test-jenkins asdf-nst nst nst-test +nuclblog nuclblog nuclblog bordeaux-threads cl-markdown cl-store cl-who hunchentoot hunchentoot-auth md5 +nuklear-blob nuklear-blob nuklear-blob asdf bodge-blobs-support glad-blob trivial-features +num-utils num-utils num-utils alexandria anaphora array-operations asdf let-plus select +num-utils num-utils num-utils/tests fiveam num-utils select +numcl numcl numcl alexandria asdf cl-randist constantfold float-features function-cache gtype iterate lisp-namespace specialized-function trivia type-r +numcl numcl.test numcl.test asdf fiveam numcl +numpy-file-format numpy-file-format numpy-file-format asdf ieee-floats +oclcl oclcl oclcl alexandria asdf cffi cl-pattern cl-ppcre cl-reexport external-program lisp-namespace osicat split-sequence +oclcl oclcl-examples oclcl-examples asdf cl-oclapi imago oclcl +oclcl oclcl-test oclcl-test arrow-macros asdf oclcl prove prove-asdf +ode-blob ode-blob ode-blob asdf base-blobs bodge-blobs-support trivial-features +oe-encode oe-encode oe-encode babel +oe-encode oe-encode oe-encode-test clunit oe-encode +omer-count eclecticse.omer eclecticse.omer asdf local-time +oneliner cl-oneliner cl-oneliner cl-ppcre lisp-unit split-sequence +ook ook ook asdf +oook oook oook alexandria anaphora cl-inflector closer-mop clsql jonathan parse-number semantic-spinneret spinneret +open-location-code open-location-code open-location-code alexandria asdf iterate +open-vrp open-vrp open-vrp alexandria fiveam open-vrp-lib vecto +open-vrp open-vrp-lib open-vrp-lib alexandria cl-fad fiveam vecto +openal-blob openal-blob openal-blob asdf bodge-blobs-support trivial-features +openid-key openid-key openid-key asdf cl-base64 dexador ironclad jonathan local-time quri trivial-rfc-1123 +openid-key openid-key-test openid-key-test 1am asdf openid-key +opticl opticl opticl alexandria asdf cl-jpeg cl-tga opticl-core pngload retrospectiff skippy zpng +opticl opticl-doc opticl-doc alexandria asdf cl-containers cl-markdown opticl +opticl opticl opticl/test fiveam opticl +opticl-core opticl-core opticl-core alexandria +optima optima optima alexandria closer-mop +optima optima.ppcre optima.ppcre alexandria cl-ppcre optima +optima optima.test optima.test eos optima optima.ppcre +org-davep-dict org-davep-dict org-davep-dict acl-compat asdf cl-ppcre split-sequence +org-davep-dictrepl org-davep-dictrepl org-davep-dictrepl asdf org-davep-dict +org-sampler org-sampler org-sampler iterate +origin origin origin alexandria asdf golden-utils +origin origin.test origin.test asdf origin parachute +orizuru-orm orizuru-orm orizuru-orm alexandria anaphora asdf cl-fad cl-ppcre-unicode clos-fixtures closer-mop clunit2 dbi iterate local-time sxql uiop +osc osc osc asdf +osicat osicat osicat alexandria asdf cffi cffi-grovel trivial-features +osicat osicat-tests osicat-tests asdf osicat rt +osmpbf osmpbf osmpbf asdf chipz com.google.base flexi-streams nibbles protobuf +overlord overlord overlord asdf +oxenfurt oxenfurt oxenfurt asdf oxenfurt-dexador +oxenfurt oxenfurt-core oxenfurt-core alexandria asdf babel documentation-utils yason +oxenfurt oxenfurt-dexador oxenfurt-dexador asdf dexador oxenfurt-core +oxenfurt oxenfurt-drakma oxenfurt-drakma asdf drakma oxenfurt-core +pack pack pack alexandria ieee-floats +package-renaming package-renaming package-renaming alexandria +package-renaming package-renaming-test package-renaming-test hu.dwim.stefil package-renaming +packet packet packet ieee-floats +paiprolog paiprolog paiprolog asdf +paiprolog unifgram unifgram asdf paiprolog +pal bermuda bermuda pal +pal pal pal cffi +pandocl pandocl pandocl common-doc common-doc-contrib common-html parenml scriba thorn vertex +pango-markup pango-markup pango-markup asdf documentation-utils +papyrus papyrus papyrus asdf named-readtables +parachute parachute parachute asdf documentation-utils form-fiddle +parachute parachute-fiveam parachute-fiveam asdf parachute +parachute parachute-lisp-unit parachute-lisp-unit asdf parachute +parachute parachute-prove parachute-prove asdf cl-ppcre parachute +parameterized-function parameterized-function parameterized-function asdf interface +paren-files paren-files paren-files parenscript +paren-test arith arith paren-files paren-test parenscript +paren-test paren-test paren-test paren-files parenscript trivial-shell +paren-util paren-util paren-util paren-files parenscript +paren6 paren6 paren6 alexandria asdf parenscript +paren6 test-paren6 test-paren6 asdf external-program paren6 parenscript +parenml parenml parenml common-doc-plump esrap plump +parenml parenml-test parenml-test fiveam parenml +parenscript parenscript parenscript anaphora asdf cl-ppcre named-readtables +parenscript parenscript.tests parenscript.tests asdf cl-js fiveam parenscript +parenscript-classic parenscript-classic parenscript-classic +parse parse parse asdf +parse-declarations parse-declarations-1.0 parse-declarations-1.0 +parse-float parse-float parse-float alexandria +parse-float parse-float parse-float-tests lisp-unit parse-float +parse-front-matter parse-front-matter parse-front-matter cl-ppcre +parse-front-matter parse-front-matter-test parse-front-matter-test fiveam parse-front-matter +parse-js parse-js parse-js +parse-number parse-number parse-number asdf +parse-number parse-number parse-number/tests parse-number +parse-number-range parse-number-range parse-number-range cartesian-product-switch enhanced-multiple-value-bind map-bind +parseltongue parseltongue parseltongue lisp-unit +parseq parseq parseq asdf +parseq parseq parseq/test parseq +parser.common-rules parser.common-rules parser.common-rules alexandria asdf esrap let-plus split-sequence +parser.common-rules parser.common-rules.operators parser.common-rules.operators alexandria architecture.builder-protocol asdf esrap let-plus parser.common-rules +parser.common-rules parser.common-rules.operators parser.common-rules.operators/test alexandria fiveam let-plus parser.common-rules parser.common-rules.operators +parser.common-rules parser.common-rules parser.common-rules/test alexandria fiveam let-plus parser.common-rules +parser.ini parser.ini parser.ini alexandria architecture.builder-protocol asdf esrap let-plus more-conditions parser.common-rules +parser.ini parser.ini parser.ini/test alexandria fiveam let-plus parser.ini +parsley parsley parsley asdf babel bitio chipz fast-io +patchwork patchwork patchwork asdf binpack opticl pngload +path-parse path-parse path-parse split-sequence uiop +path-parse path-parse-test path-parse-test fiveam path-parse +path-string path-string path-string cl-ppcre split-sequence uiop +path-string path-string-test path-string-test path-string prove prove-asdf +pathname-utils pathname-utils pathname-utils asdf +pathname-utils pathname-utils-test pathname-utils-test asdf parachute pathname-utils +patron patron patron bordeaux-threads +pcall pcall pcall bordeaux-threads pcall-queue +pcall pcall-queue pcall-queue bordeaux-threads +pcall pcall pcall-tests fiveam pcall +percent-encoding percent-encoding percent-encoding anaphora babel +percent-encoding percent-encoding percent-encoding-test fiveam percent-encoding +periodic-table periodic-table periodic-table +periods periods periods asdf local-time +periods periods-series periods-series asdf periods series +perlre perlre perlre asdf cl-interpol cl-ppcre let-over-lambda prove trivia trivia.ppcre +persistent-tables persistent-tables persistent-tables lisp-unit random-access-lists +persistent-variables persistent-variables persistent-variables +persistent-variables persistent-variables persistent-variables.test persistent-variables +petalisp petalisp petalisp asdf petalisp.api +petalisp petalisp.api petalisp.api alexandria asdf petalisp.core petalisp.ir-backend petalisp.native-backend petalisp.reference-backend petalisp.utilities trivia +petalisp petalisp.blueprint-compiler petalisp.blueprint-compiler alexandria asdf petalisp.core petalisp.ir petalisp.utilities +petalisp petalisp.core petalisp.core agnostic-lizard alexandria asdf bordeaux-threads lparallel petalisp.type-inference petalisp.utilities split-sequence trivia ucons +petalisp petalisp.examples petalisp.examples asdf petalisp +petalisp petalisp.graphviz petalisp.graphviz alexandria asdf cl-dot petalisp petalisp.core petalisp.ir petalisp.utilities uiop +petalisp petalisp.ir petalisp.ir alexandria asdf petalisp.core petalisp.utilities +petalisp petalisp.ir-backend petalisp.ir-backend alexandria asdf petalisp.core petalisp.ir +petalisp petalisp.native-backend petalisp.native-backend alexandria asdf bordeaux-threads lparallel petalisp.blueprint-compiler petalisp.core petalisp.ir petalisp.scheduler petalisp.utilities trivia +petalisp petalisp.reference-backend petalisp.reference-backend asdf petalisp.core +petalisp petalisp.scheduler petalisp.scheduler asdf petalisp.core petalisp.ir +petalisp petalisp.test-suite petalisp.test-suite asdf closer-mop petalisp petalisp.examples petalisp.graphviz +petalisp petalisp.type-inference petalisp.type-inference alexandria asdf trivia trivial-arguments +petalisp petalisp.utilities petalisp.utilities alexandria asdf trivia +petit.package-utils petit.package-utils petit.package-utils +petit.string-utils petit.string-utils petit.string-utils +petit.string-utils petit.string-utils-test petit.string-utils-test petit.string-utils rt +petri petri petri 1am alexandria asdf closer-mop phoe-toolbox split-sequence +petri petri petri/graph cl-dot petri +petri petri petri/test 1am alexandria bordeaux-threads lparallel petri trivial-backtrace +petri petri petri/threaded bordeaux-threads lparallel petri trivial-backtrace +pettomato-deque pettomato-deque pettomato-deque +pettomato-deque pettomato-deque-tests pettomato-deque-tests fiveam pettomato-deque +pettomato-indexed-priority-queue pettomato-indexed-priority-queue pettomato-indexed-priority-queue +pettomato-indexed-priority-queue pettomato-indexed-priority-queue-tests pettomato-indexed-priority-queue-tests fiveam pettomato-indexed-priority-queue +pg pg pg +pgloader pgloader pgloader abnf alexandria asdf cl-base64 cl-csv cl-fad cl-log cl-markdown cl-mustache cl-postgres cl-ppcre closer-mop command-line-arguments db3 drakma esrap flexi-streams ixf local-time lparallel metabang-bind mssql postmodern py-configparser qmynd quri simple-date split-sequence sqlite trivial-backtrace uiop usocket uuid yason zs3 +phoe-toolbox phoe-toolbox phoe-toolbox alexandria asdf closer-mop trivial-indent +phoe-toolbox phoe-toolbox phoe-toolbox/bag alexandria +physical-quantities physical-quantities physical-quantities asdf parseq +physical-quantities physical-quantities physical-quantities/test physical-quantities +piggyback-parameters piggyback-parameters piggyback-parameters asdf trivial-hashtable-serialize trivial-json-codec trivial-pooled-database +piggyback-parameters piggyback-parameters piggyback-parameters/test fiveam piggyback-parameters +pileup pileup pileup alexandria +pileup pileup pileup-tests hu.dwim.stefil pileup +pipes pipes pipes +piping piping piping asdf +pithy-xml pithy-xml pithy-xml +pjlink pjlink pjlink alexandria asdf bordeaux-threads ip-interfaces md5 split-sequence trivial-garbage usocket +place-modifiers place-modifiers place-modifiers cartesian-product-switch map-bind +place-utils place-utils place-utils asdf +plain-odbc plain-odbc plain-odbc alexandria asdf cffi +planks planks planks babel bordeaux-threads closer-mop ironclad rucksack trivial-garbage +plexippus-xpath xpath xpath asdf cl-ppcre cxml parse-number yacc +plexippus-xpath xpath xpath/test xpath +plokami plokami plokami asdf cffi uiop +pludeck pludeck pludeck asdf plump +plump plump plump array-utils asdf documentation-utils +plump plump-dom plump-dom asdf plump +plump plump-lexer plump-lexer asdf plump +plump plump-parser plump-parser asdf plump +plump-bundle plump-bundle plump-bundle asdf babel closer-mop fast-io plump-dom +plump-sexp plump-sexp plump-sexp asdf plump +plump-tex plump-tex plump-tex asdf cl-ppcre plump +plump-tex plump-tex-test plump-tex-test asdf fiveam plump-tex +png-read png-read png-read babel chipz iterate +pngload pngload pngload alexandria asdf parsley static-vectors +pngload pngload.test pngload.test alexandria asdf local-time opticl png-read pngload +pngload-fast pngload-fast pngload-fast 3bz alexandria asdf cffi mmap static-vectors swap-bytes +pngload-fast pngload-fast.test pngload-fast.test alexandria asdf local-time opticl png-read pngload-fast +poler poler poler asdf +poler poler-test poler-test asdf poler prove prove-asdf +policy-cond policy-cond policy-cond asdf +polisher polisher polisher asdf cl-ppcre +polisher polisher.test polisher.test 1am asdf polisher +pooler pooler pooler +portable-threads portable-threads portable-threads asdf +portable-threads portable-threads portable-threads/test portable-threads +portableaserve acl-compat acl-compat asdf cl-fad cl-ppcre ironclad puri +portableaserve aserve aserve acl-compat asdf htmlgen +portableaserve htmlgen htmlgen acl-compat asdf +portableaserve webactions webactions acl-compat asdf aserve htmlgen +positional-lambda positional-lambda positional-lambda map-bind +postmodern cl-postgres cl-postgres asdf md5 usocket +postmodern cl-postgres cl-postgres/simple-date-tests cl-postgres fiveam simple-date +postmodern cl-postgres cl-postgres/tests cl-postgres fiveam +postmodern postmodern postmodern alexandria asdf bordeaux-threads cl-postgres closer-mop global-vars s-sql split-sequence +postmodern postmodern postmodern/tests cl-postgres fiveam postmodern s-sql simple-date +postmodern s-sql s-sql alexandria asdf cl-postgres +postmodern s-sql s-sql/tests cl-postgres fiveam postmodern s-sql +postmodern simple-date simple-date asdf +postmodern simple-date simple-date/postgres-glue cl-postgres simple-date +postmodern simple-date simple-date/tests fiveam simple-date +postmodernity postmodernity postmodernity alexandria postmodern +postoffice postoffice postoffice acl-compat +pounds pounds pounds babel bordeaux-threads cffi nibbles trivial-gray-streams +pp-toml pp-toml pp-toml alexandria asdf cl-ppcre esrap generic-comparability local-time parse-number split-sequence +pp-toml pp-toml-tests pp-toml-tests alexandria asdf cl-ppcre esrap fiveam generic-comparability local-time parse-number pp-toml split-sequence +ppath ppath ppath alexandria asdf cffi cl-ppcre osicat split-sequence trivial-features uiop +ppath ppath-test ppath-test alexandria asdf cl-fad ppath prove prove-asdf +practical-cl pcl-binary-data pcl-binary-data asdf pcl-macro-utilities +practical-cl pcl-html pcl-html asdf pcl-macro-utilities +practical-cl pcl-id3v2 pcl-id3v2 asdf pcl-binary-data pcl-pathnames +practical-cl pcl-macro-utilities pcl-macro-utilities asdf +practical-cl pcl-mp3-browser pcl-mp3-browser asdf bordeaux-threads pcl-html pcl-id3v2 pcl-mp3-database pcl-shoutcast pcl-url-function +practical-cl pcl-mp3-database pcl-mp3-database asdf pcl-id3v2 pcl-macro-utilities pcl-pathnames +practical-cl pcl-pathnames pcl-pathnames asdf +practical-cl pcl-shoutcast pcl-shoutcast asdf pcl-html pcl-id3v2 pcl-macro-utilities pcl-mp3-database pcl-pathnames pcl-url-function +practical-cl pcl-simple-database pcl-simple-database asdf +practical-cl pcl-spam pcl-spam asdf cl-ppcre pcl-pathnames pcl-test-framework +practical-cl pcl-test-framework pcl-test-framework asdf pcl-macro-utilities +practical-cl pcl-url-function pcl-url-function asdf aserve pcl-html pcl-macro-utilities +practical-cl practical-cl practical-cl asdf pcl-binary-data pcl-html pcl-id3v2 pcl-macro-utilities pcl-mp3-browser pcl-mp3-database pcl-pathnames pcl-shoutcast pcl-simple-database pcl-spam pcl-test-framework pcl-url-function +prbs prbs prbs asdf +prbs prbs-docs prbs-docs asdf cl-gendoc prbs +prepl prepl prepl asdf bordeaux-threads closer-mop conium iterate named-readtables +pretty-function pretty-function pretty-function +print-html print-html print-html asdf +print-licenses print-licenses print-licenses alexandria asdf iterate +printv printv printv +priority-queue priority-queue priority-queue +proc-parse proc-parse proc-parse alexandria asdf babel +proc-parse proc-parse-test proc-parse-test asdf proc-parse prove prove-asdf +projectured projectured.document projectured.document cl-json hu.dwim.asdf parse-number projectured.editor s-xml +projectured projectured.editor projectured.editor hu.dwim.asdf hu.dwim.common hu.dwim.def hu.dwim.defclass-star hu.dwim.logger hu.dwim.serializer hu.dwim.syntax-sugar hu.dwim.util trivial-garbage +projectured projectured.executable projectured.executable command-line-arguments hu.dwim.asdf projectured.sdl +projectured projectured.projection projectured.projection hu.dwim.asdf projectured.document projectured.editor +projectured projectured.sdl projectured.sdl hu.dwim.asdf hu.dwim.sdl projectured.document projectured.editor projectured.projection +projectured projectured.sdl.test projectured.sdl.test hu.dwim.asdf projectured.sdl projectured.test +projectured projectured.swank projectured.swank hu.dwim.asdf projectured.editor swank +projectured projectured.test projectured.test hu.dwim.asdf hu.dwim.logger hu.dwim.stefil+hu.dwim.def+swank projectured.document projectured.editor projectured.projection projectured.swank +prometheus.cl prometheus prometheus alexandria asdf bordeaux-threads cl-ppcre local-time quantile-estimator +prometheus.cl prometheus.collectors.process prometheus.collectors.process asdf cffi cffi-grovel cl-fad prometheus split-sequence +prometheus.cl prometheus.collectors.process.test prometheus.collectors.process.test asdf cl-interpol log4cl mw-equiv prometheus.collectors.process prometheus.test.support prove prove-asdf +prometheus.cl prometheus.collectors.sbcl prometheus.collectors.sbcl asdf prometheus +prometheus.cl prometheus.collectors.sbcl.test prometheus.collectors.sbcl.test asdf cl-interpol log4cl mw-equiv prometheus.collectors.sbcl prometheus.test.support prove prove-asdf +prometheus.cl prometheus.examples prometheus.examples asdf prometheus prometheus.collectors.process prometheus.collectors.sbcl prometheus.exposers.hunchentoot prometheus.formats.text +prometheus.cl prometheus.exposers.hunchentoot prometheus.exposers.hunchentoot asdf hunchentoot prometheus prometheus.formats.text salza2 trivial-utf-8 +prometheus.cl prometheus.exposers.hunchentoot.test prometheus.exposers.hunchentoot.test asdf chipz cl-interpol drakma log4cl mw-equiv prometheus.exposers.hunchentoot prometheus.formats.text prometheus.test.support prove prove-asdf +prometheus.cl prometheus.formats.text prometheus.formats.text alexandria asdf prometheus +prometheus.cl prometheus.formats.text.test prometheus.formats.text.test asdf cl-interpol log4cl mw-equiv prometheus.formats.text prometheus.test.support prove prove-asdf +prometheus.cl prometheus.pushgateway prometheus.pushgateway asdf drakma prometheus prometheus.formats.text +prometheus.cl prometheus.pushgateway.test prometheus.pushgateway.test asdf cl-interpol hunchentoot log4cl mw-equiv prometheus.pushgateway prometheus.test.support prove prove-asdf +prometheus.cl prometheus.test prometheus.test asdf cl-interpol log4cl mw-equiv prometheus prometheus.test.support prove prove-asdf +prometheus.cl prometheus.test.all prometheus.test.all asdf cl-coveralls prometheus.collectors.process.test prometheus.collectors.sbcl.test prometheus.exposers.hunchentoot.test prometheus.formats.text.test prometheus.pushgateway.test prometheus.test prove-asdf +prometheus.cl prometheus.test.support prometheus.test.support alexandria asdf prometheus prove prove-asdf +protest protest protest alexandria asdf closer-mop moptilities trivial-garbage +protest protest protest/1am 1am alexandria closer-mop named-readtables trivial-garbage +protest protest protest/base alexandria closer-mop trivial-garbage +protest protest protest/common alexandria closer-mop moptilities trivial-garbage +protest protest protest/common/addressed alexandria closer-mop moptilities trivial-garbage +protest protest protest/common/date alexandria closer-mop moptilities trivial-garbage +protest protest protest/common/handling alexandria closer-mop moptilities trivial-garbage +protest protest protest/common/killable alexandria closer-mop moptilities trivial-garbage +protest protest protest/common/named alexandria closer-mop moptilities trivial-garbage +protest protest protest/ftype alexandria +protest protest protest/parachute alexandria closer-mop named-readtables parachute trivial-garbage +protest protest protest/protocol alexandria closer-mop moptilities trivial-garbage +protest protest protest/test 1am alexandria closer-mop named-readtables protest trivial-garbage +protest protest protest/test-case alexandria closer-mop trivial-garbage +protobuf protobuf protobuf asdf com.google.base varint +protobuf varint varint asdf com.google.base nibbles +protobuf varint-test varint-test asdf hu.dwim.stefil varint +prove cl-test-more cl-test-more prove +prove prove prove alexandria cl-ansi-text cl-colors cl-ppcre uiop +prove prove-asdf prove-asdf +prove prove-test prove-test alexandria prove prove-asdf split-sequence +pseudonyms pseudonyms pseudonyms named-readtables trivial-garbage +psgraph psgraph psgraph +psychiq psychiq psychiq alexandria asdf bordeaux-threads cl-redis cl-reexport dissect jonathan local-time uiop vom +psychiq psychiq-test psychiq-test asdf prove prove-asdf psychiq +ptester ptester ptester +puri puri puri asdf +puri puri puri-tests ptester puri +purl purl purl maxpc percent-encoding uiop +py-configparser py-configparser py-configparser parse-number +py4cl py4cl py4cl asdf cl-json numpy-file-format trivial-garbage uiop +py4cl py4cl py4cl/tests bordeaux-threads clunit py4cl trivial-garbage +pythonic-string-reader pythonic-string-reader pythonic-string-reader asdf named-readtables +pzmq pzmq pzmq asdf cffi cffi-grovel +pzmq pzmq pzmq-compat pzmq +pzmq pzmq pzmq-examples bordeaux-threads iterate local-time pzmq split-sequence +pzmq pzmq pzmq-test bordeaux-threads fiveam let-plus pzmq +qbase64 qbase64 qbase64 asdf metabang-bind trivial-gray-streams +qbase64 qbase64 qbase64/test fiveam qbase64 temporary-file +qbook qbook qbook arnesi cl-ppcre iterate yaclml +ql-checkout ql-checkout ql-checkout asdf +qlot qlot qlot asdf +qmynd qmynd qmynd asdf babel chipz cl+ssl flexi-streams ironclad list-of salza2 trivial-gray-streams usocket +qmynd qmynd-test qmynd-test asdf babel flexi-streams qmynd +qt-libs commonqt commonqt asdf qt+libs qt-libs smokebase +qt-libs phonon phonon asdf qt+libs qt-libs qtcore qtdbus qtgui qtxml +qt-libs qimageblitz qimageblitz asdf qt+libs qt-libs qtcore qtgui +qt-libs qsci qsci asdf qt+libs qt-libs qtcore qtgui +qt-libs qt-lib-generator qt-lib-generator asdf cl-ppcre pathname-utils trivial-features +qt-libs qt-libs qt-libs asdf cffi cl-ppcre qt-lib-generator +qt-libs qt3support qt3support asdf qt+libs qt-libs qtcore qtgui qtnetwork qtsql qtxml +qt-libs qtcore qtcore asdf commonqt qt+libs qt-libs +qt-libs qtdbus qtdbus asdf qt+libs qt-libs qtcore qtxml +qt-libs qtdeclarative qtdeclarative asdf qt+libs qt-libs qtcore qtgui qtnetwork qtscript qtsql qtxmlpatterns +qt-libs qtgui qtgui asdf qt+libs qt-libs qtcore +qt-libs qthelp qthelp asdf qt+libs qt-libs qtcore qtgui qtnetwork qtsql +qt-libs qtnetwork qtnetwork asdf qt+libs qt-libs qtcore +qt-libs qtopengl qtopengl asdf qt+libs qt-libs qtcore qtgui +qt-libs qtscript qtscript asdf qt+libs qt-libs qtcore +qt-libs qtsql qtsql asdf qt+libs qt-libs qtcore qtgui +qt-libs qtsvg qtsvg asdf qt+libs qt-libs qtcore qtgui +qt-libs qttest qttest asdf qt+libs qt-libs qtcore qtgui +qt-libs qtuitools qtuitools asdf qt+libs qt-libs qtcore qtgui +qt-libs qtwebkit qtwebkit asdf qt+libs qt-libs qtcore qtgui qtnetwork +qt-libs qtxml qtxml asdf qt+libs qt-libs qtcore +qt-libs qtxmlpatterns qtxmlpatterns asdf qt+libs qt-libs qtcore qtnetwork +qt-libs qwt qwt asdf qt+libs qt-libs qtcore qtgui +qt-libs smokebase smokebase asdf qt+libs qt-libs +qtools q+ q+ asdf qtools +qtools qtools qtools asdf cl-ppcre closer-mop deploy documentation-utils form-fiddle named-readtables qt+libs trivial-garbage trivial-indent trivial-main-thread +qtools qtools-evaluator qtools-evaluator asdf cl-ppcre qtcore qtgui qtools trivial-gray-streams +qtools qtools-game qtools-game asdf closer-mop qtcore qtgui qtools qtopengl +qtools qtools-helloworld qtools-helloworld asdf qtcore qtgui qtools +qtools qtools-melody qtools-melody asdf phonon qtcore qtgui qtools +qtools qtools-opengl qtools-opengl asdf cl-opengl qtcore qtgui qtools qtopengl +qtools qtools-titter qtools-titter asdf chirp qtcore qtgui qtools +qtools-ui qtools-ui qtools-ui asdf qtools-ui-base qtools-ui-cell qtools-ui-color-history qtools-ui-color-picker qtools-ui-color-sliders qtools-ui-color-triangle qtools-ui-compass qtools-ui-container qtools-ui-debugger qtools-ui-dialog qtools-ui-dictionary qtools-ui-drag-and-drop qtools-ui-fixed-qtextedit qtools-ui-flow-layout qtools-ui-helpers qtools-ui-imagetools qtools-ui-keychord-editor qtools-ui-layout qtools-ui-listing qtools-ui-notification qtools-ui-options qtools-ui-panels qtools-ui-placeholder-text-edit qtools-ui-plot qtools-ui-repl qtools-ui-slider qtools-ui-spellchecked-text-edit qtools-ui-splitter +qtools-ui qtools-ui-base qtools-ui-base array-utils asdf documentation-utils qtcore qtgui qtools +qtools-ui qtools-ui-bytearray qtools-ui-bytearray asdf qtools-ui-base +qtools-ui qtools-ui-cell qtools-ui-cell asdf qtools-ui-base qtools-ui-helpers qtools-ui-layout +qtools-ui qtools-ui-color-history qtools-ui-color-history asdf qtools-ui-base qtools-ui-flow-layout qtools-ui-helpers +qtools-ui qtools-ui-color-picker qtools-ui-color-picker asdf qtools-ui-base qtools-ui-color-history qtools-ui-color-sliders qtools-ui-color-triangle qtools-ui-dialog qtools-ui-helpers +qtools-ui qtools-ui-color-sliders qtools-ui-color-sliders asdf qtools-ui-base qtools-ui-helpers +qtools-ui qtools-ui-color-triangle qtools-ui-color-triangle asdf cl-opengl qtools-ui-base qtools-ui-helpers qtopengl +qtools-ui qtools-ui-compass qtools-ui-compass asdf qtools-ui-base qtools-ui-layout +qtools-ui qtools-ui-container qtools-ui-container asdf qtools-ui-base qtools-ui-layout +qtools-ui qtools-ui-debugger qtools-ui-debugger asdf dissect qtools-ui-base +qtools-ui qtools-ui-dialog qtools-ui-dialog asdf qtools-ui-base qtools-ui-helpers +qtools-ui qtools-ui-dictionary qtools-ui-dictionary asdf qtools-ui-base qtools-ui-fixed-qtextedit qtools-ui-helpers wordnet +qtools-ui qtools-ui-drag-and-drop qtools-ui-drag-and-drop asdf qtools-ui-base qtools-ui-helpers +qtools-ui qtools-ui-executable qtools-ui-executable asdf bordeaux-threads qtools-ui-base +qtools-ui qtools-ui-fixed-qtextedit qtools-ui-fixed-qtextedit asdf qtools-ui-base +qtools-ui qtools-ui-flow-layout qtools-ui-flow-layout asdf qtools-ui-base qtools-ui-container +qtools-ui qtools-ui-helpers qtools-ui-helpers asdf qtools-ui-base qtools-ui-layout +qtools-ui qtools-ui-imagetools qtools-ui-imagetools asdf qimageblitz qtools-ui-base +qtools-ui qtools-ui-keychord-editor qtools-ui-keychord-editor asdf qtools-ui-base +qtools-ui qtools-ui-layout qtools-ui-layout asdf qtools-ui-base +qtools-ui qtools-ui-listing qtools-ui-listing asdf qtools-ui-base qtools-ui-cell qtools-ui-container +qtools-ui qtools-ui-notification qtools-ui-notification asdf qtools-ui-base +qtools-ui qtools-ui-options qtools-ui-options asdf closer-mop qtools-ui-base qtools-ui-color-picker qtools-ui-color-triangle qtools-ui-helpers qtools-ui-listing qtools-ui-slider +qtools-ui qtools-ui-panels qtools-ui-panels asdf qtools-ui-base qtools-ui-compass qtools-ui-helpers qtools-ui-splitter +qtools-ui qtools-ui-placeholder-text-edit qtools-ui-placeholder-text-edit asdf qtools-ui-base qtools-ui-fixed-qtextedit +qtools-ui qtools-ui-plot qtools-ui-plot asdf qtools-ui-base qtools-ui-helpers +qtools-ui qtools-ui-progress-bar qtools-ui-progress-bar asdf qtools-ui-base +qtools-ui qtools-ui-repl qtools-ui-repl asdf bordeaux-threads qtools-ui-base trivial-gray-streams +qtools-ui qtools-ui-slider qtools-ui-slider asdf qtools-ui-base qtools-ui-helpers +qtools-ui qtools-ui-spellchecked-text-edit qtools-ui-spellchecked-text-edit asdf qtools-ui-base qtools-ui-fixed-qtextedit qtools-ui-helpers spell +qtools-ui qtools-ui-splitter qtools-ui-splitter asdf qtools-ui-base qtools-ui-container qtools-ui-helpers +qtools-ui qtools-ui-svgtools qtools-ui-svgtools asdf qtools-ui-base qtsvg +quadtree quadtree quadtree +quadtree quadtree-test quadtree-test prove prove-asdf quadtree +quantile-estimator.cl quantile-estimator quantile-estimator alexandria +quantile-estimator.cl quantile-estimator.test quantile-estimator.test log4cl mw-equiv prove prove-asdf quantile-estimator +quasiquote-2.0 quasiquote-2.0 quasiquote-2.0 iterate +quasiquote-2.0 quasiquote-2.0 quasiquote-2.0-tests fiveam quasiquote-2.0 +queen.lisp queen queen alexandria anaphora cl-ppcre-unicode named-readtables +query-fs query-fs query-fs asdf bordeaux-threads cl-fuse cl-fuse-meta-fs cl-ppcre command-line-arguments iterate trivial-backtrace +queues queues queues +queues queues.priority-cqueue queues.priority-cqueue bordeaux-threads queues queues.priority-queue +queues queues.priority-queue queues.priority-queue queues +queues queues.simple-cqueue queues.simple-cqueue bordeaux-threads queues queues.simple-queue +queues queues.simple-queue queues.simple-queue queues +quickapp quickapp quickapp +quicklisp-slime-helper quicklisp-slime-helper quicklisp-slime-helper alexandria swank +quickproject quickproject quickproject asdf cl-fad html-template +quicksearch quicksearch quicksearch alexandria anaphora bordeaux-threads cl-ppcre do-urlencode drakma flexi-streams html-entities iterate yason +quickutil quickutil quickutil asdf quickutil-client +quickutil quickutil-client quickutil-client asdf cl-fad quickutil-client-management quickutil-utilities +quickutil quickutil-client-management quickutil-client-management asdf trivial-garbage +quickutil quickutil-server quickutil-server asdf cl-fad cl-markdown cl-ppcre cl-syntax cl-syntax-annot clack-middleware-csrf closure-template dbi multival-plist ningle quickutil-utilities trivial-shell yason +quickutil quickutil-utilities quickutil-utilities asdf cl-heredoc +quickutil quickutil-utilities-test quickutil-utilities-test asdf quickutil-client quickutil-server +quilc boondoggle boondoggle asdf cl-quil command-line-arguments drakma uiop +quilc boondoggle-tests boondoggle-tests asdf boondoggle cl-quil fiasco sapaclisp uiop +quilc cl-quil cl-quil abstract-classes alexa alexandria asdf cl-algebraic-data-type cl-grnm cl-heap cl-permutation closer-mop global-vars magicl optima parse-float queues.priority-queue salza2 singleton-classes split-sequence trivial-garbage uiop yacc yason +quilc cl-quil-benchmarking cl-quil-benchmarking asdf cl-quil trivial-benchmark +quilc cl-quil-tests cl-quil-tests alexa alexandria asdf cl-permutation cl-ppcre cl-quil fiasco magicl magicl-transcendental qvm uiop yacc +quilc cl-quil cl-quil/quilt cl-quil +quilc cl-quil cl-quil/quilt-tests cl-quil cl-quil-tests +quilc cl-quil cl-quil/tweedledum cffi cl-quil +quilc cl-quil cl-quil/tweedledum-tests cffi cl-quil cl-quil-tests +quilc quilc quilc alexandria asdf bordeaux-threads cl-ppcre cl-quil cl-quil-benchmarking cl-syslog command-line-arguments drakma magicl rpcq split-sequence trivial-features uiop yason +quilc quilc-tests quilc-tests alexandria asdf bordeaux-threads fiasco quilc uiop uuid +quri quri quri alexandria asdf babel cl-utilities split-sequence +quri quri-test quri-test asdf prove prove-asdf quri +quux-hunchentoot quux-hunchentoot quux-hunchentoot alexandria asdf bordeaux-threads hunchentoot lil lparallel optima +quux-time quux-time quux-time +qvm qvm qvm abstract-classes alexandria asdf cffi cffi-grovel cl-quil global-vars ieee-floats lparallel magicl mt19937 static-vectors trivial-features trivial-garbage +qvm qvm-app qvm-app alexandria asdf bordeaux-threads cl-fad cl-quil cl-syslog command-line-arguments drakma global-vars hunchentoot ieee-floats qvm qvm-benchmarks swank trivial-features trivial-garbage uiop yason +qvm qvm-app-ng qvm-app-ng alexandria asdf cl-quil cl-syslog command-line-arguments qvm trivial-features uiop +qvm qvm-app-ng-tests qvm-app-ng-tests asdf fiasco qvm-app-ng uiop +qvm qvm-app-tests qvm-app-tests asdf fiasco qvm-app uiop +qvm qvm-benchmarks qvm-benchmarks asdf cl-quil qvm trivial-benchmark yason +qvm qvm-examples qvm-examples asdf cl-grnm cl-quil qvm qvm-app +qvm qvm-tests qvm-tests alexandria asdf cffi cl-quil fiasco qvm qvm-examples trivial-garbage +racer lracer lracer asdf +racer racer racer asdf aserve deflate flexi-streams +random acm-random acm-random asdf com.google.base random +random acm-random-test acm-random-test acm-random asdf hu.dwim.stefil +random random random asdf com.google.base +random random-test random-test asdf hu.dwim.stefil random +random-access-lists random-access-lists random-access-lists lisp-unit +random-sample random-sample random-sample alexandria asdf infix-math serapeum +random-state random-state random-state asdf documentation-utils +random-state random-state-viewer random-state-viewer asdf qtcore qtgui qtools random-state +rate-monotonic rate-monotonic rate-monotonic bordeaux-threads timer-wheel +rate-monotonic rate-monotonic.examples rate-monotonic.examples bordeaux-threads rate-monotonic +ratify ratify ratify asdf cl-ppcre local-time parse-float +rcl rcl rcl bordeaux-threads cffi named-readtables simple-tasks trivial-garbage +rcl rcl rcl-test fiveam rcl +re re re asdf parse +read-csv read-csv read-csv asdf +read-csv read-csv read-csv.test read-csv +read-number read-number read-number alexandria asdf lisp-unit +reader reader reader alexandria asdf generic-cl hash-set iterate named-readtables numcl trivial-types +reader reader-test reader-test asdf prove reader +reader-interception reader-interception reader-interception +reader-interception reader-interception-test reader-interception-test fare-utils hu.dwim.stefil reader-interception +rectangle-packing rectangle-packing rectangle-packing +recur recur recur asdf +recursive-regex recursive-regex recursive-regex alexandria anaphora cl-interpol cl-ppcre iterate symbol-munger +recursive-regex recursive-regex recursive-regex-test lisp-unit recursive-regex +recursive-restart recursive-restart recursive-restart alexandria +redirect-stream redirect-stream redirect-stream asdf trivial-gray-streams +regex regex regex +regular-type-expression 2d-array 2d-array asdf +regular-type-expression 2d-array-test 2d-array-test 2d-array asdf scrutiny +regular-type-expression adjuvant adjuvant asdf +regular-type-expression adjuvant-test adjuvant-test adjuvant asdf scrutiny +regular-type-expression cl-robdd cl-robdd adjuvant asdf +regular-type-expression cl-robdd-analysis cl-robdd-analysis adjuvant asdf cl-fad cl-robdd +regular-type-expression cl-robdd-analysis-test cl-robdd-analysis-test adjuvant asdf cl-robdd-analysis scrutiny +regular-type-expression cl-robdd-test cl-robdd-test adjuvant asdf cl-fad cl-robdd scrutiny +regular-type-expression dispatch dispatch adjuvant asdf closer-mop +regular-type-expression dispatch-test dispatch-test asdf dispatch scrutiny +regular-type-expression lisp-types lisp-types adjuvant asdf cl-robdd dispatch +regular-type-expression lisp-types-analysis lisp-types-analysis adjuvant asdf cl-fad cl-robdd cl-robdd-analysis lisp-types scrutiny +regular-type-expression lisp-types-test lisp-types-test adjuvant asdf bordeaux-threads closer-mop lisp-types lisp-types-analysis scrutiny +regular-type-expression ndfa ndfa adjuvant asdf +regular-type-expression ndfa-test ndfa-test adjuvant asdf ndfa scrutiny +regular-type-expression research research 2d-array-test adjuvant adjuvant-test asdf dispatch-test ndfa-test rte-regexp-test rte-test scrutiny scrutiny-test +regular-type-expression rte rte adjuvant asdf lisp-types ndfa +regular-type-expression rte-regexp rte-regexp adjuvant asdf rte yacc +regular-type-expression rte-regexp-test rte-regexp-test adjuvant asdf rte rte-regexp scrutiny +regular-type-expression rte-test rte-test 2d-array 2d-array-test adjuvant asdf lisp-types-test ndfa-test rte rte-regexp-test scrutiny +regular-type-expression scrutiny scrutiny adjuvant asdf +regular-type-expression scrutiny-test scrutiny-test asdf scrutiny +remote-js remote-js remote-js asdf cl-markup find-port trivial-ws +remote-js remote-js-test remote-js-test asdf bordeaux-threads fiveam remote-js trivial-open-browser +repl-utilities repl-utilities repl-utilities +replic replic replic asdf cl-ansi-text cl-readline py-configparser shlex str unix-opts +replic replic-test replic-test asdf prove prove-asdf replic +restas restas restas alexandria asdf bordeaux-threads cffi data-sift hunchentoot routes +restas restas-doc restas-doc asdf restas restas-directory-publisher sphinx +restas-directory-publisher restas-directory-publisher restas-directory-publisher closure-template local-time restas +restas.file-publisher restas.file-publisher restas.file-publisher cl-fad restas +restful restful restful alexandria cl-ppcre closer-mop hunchentoot jonathan +restful restful-test restful-test drakma prove prove-asdf restful +restricted-functions restricted-functions restricted-functions alexandria asdf closer-mop simplified-types trivia trivial-arguments trivial-garbage +retrospectiff retrospectiff retrospectiff cl-jpeg com.gigamonkeys.binary-data deflate flexi-streams ieee-floats opticl-core +retrospectiff retrospectiff retrospectiff/test fiveam retrospectiff +reversi reversi reversi +rfc2109 rfc2109 rfc2109 split-sequence +rfc2109 rfc2109 rfc2109/test fiveam split-sequence +rfc2388 rfc2388 rfc2388 asdf +rfc2388-binary rfc2388-binary rfc2388-binary +rfc3339-timestamp rfc3339-timestamp rfc3339-timestamp yacc +rfc3339-timestamp rfc3339-timestamp-test rfc3339-timestamp-test lisp-unit rfc3339-timestamp +rlc rlc rlc kmrcl +roan roan roan alexandria asdf binascii cl-fad cl-interpol cl-ppcre drakma iterate local-time plump uuid zip +roan roan roan/doc alexandria asdf cl-fad cl-ppcre iterate roan trivial-documentation +roan roan roan/test alexandria cl-fad cl-ppcre iterate lisp-unit2 roan +rock rock rock anaphora asdf trivial-download trivial-extract trivial-types +rock rock-test rock-test fiveam rock +rock rock-web rock-web 3bmd 3bmd-ext-code-blocks 3bmd-ext-definition-lists cl-markup lass rock +romreader romreader romreader +rove rove rove asdf +rpc4cl rpc4cl rpc4cl babel cl-ppcre cxml drakma parse-number rfc3339-timestamp trivial-timeout +rpc4cl rpc4cl-test rpc4cl-test hunchentoot lisp-unit rpc4cl +rpcq rpcq rpcq alexandria asdf bordeaux-threads cl-messagepack cl-syslog flexi-streams local-time parse-float pzmq trivial-backtrace uuid yason +rpcq rpcq-tests rpcq-tests asdf cl-messagepack cl-syslog fiasco rpcq uiop +rpm rpm rpm cl-ppcre fare-utils inferior-shell lambda-reader +rt rt rt +rt-events rt-events rt-events bordeaux-threads +rt-events rt-events.examples rt-events.examples bordeaux-threads rt-events +rtg-math rtg-math rtg-math alexandria asdf documentation-utils glsl-symbols +rtg-math rtg-math.vari rtg-math.vari asdf glsl-symbols rtg-math varjo +rucksack rucksack rucksack +rucksack rucksack-test rucksack-test rucksack +rutils rutils rutils asdf closer-mop named-readtables +rutils rutils-test rutils-test asdf rutils should-test +rutils rutilsx rutilsx asdf closer-mop named-readtables rutils +ryeboy ryeboy ryeboy alexandria protobuf prove-asdf usocket +ryeboy ryeboy ryeboy-test prove prove-asdf ryeboy +s-base64 s-base64 s-base64 +s-dot2 s-dot2 s-dot2 asdf uiop +s-http-client s-http-client s-http-client chipz puri s-base64 s-sysdeps s-utils +s-http-server s-http-server s-http-server puri s-base64 s-sysdeps s-utils salza2 +s-protobuf s-protobuf s-protobuf cffi +s-sysdeps s-sysdeps s-sysdeps +s-utils s-utils s-utils +s-xml s-xml s-xml +s-xml s-xml s-xml.examples s-xml +s-xml s-xml s-xml.test s-xml +s-xml-rpc s-xml-rpc s-xml-rpc asdf s-xml +safe-queue safe-queue safe-queue split-sequence +safe-read safe-read safe-read asdf local-time trivial-garbage +safe-read safe-read safe-read/test safe-read +safety-params safety-params safety-params alexandria asdf parse-number +safety-params safety-params safety-params/tests rove safety-params +salza2 salza2 salza2 +sandalphon.lambda-list sandalphon.lambda-list sandalphon.lambda-list asdf +sanity-clause sanity-clause sanity-clause alexandria asdf cl-arrows cl-ppcre closer-mop local-time parse-float quri str trivial-types +sanity-clause sanity-clause sanity-clause/test rove sanity-clause +sapaclisp sapaclisp sapaclisp +sb-cga sb-cga sb-cga alexandria +sb-fastcgi sb-fastcgi sb-fastcgi asdf +sb-vector-io sb-vector-io sb-vector-io +sc-extensions sc-extensions sc-extensions alexandria asdf cl-collider named-readtables +scalpl scalpl scalpl anaphora asdf chanl cl-base64 cl-json decimals drakma ironclad local-time method-combination-utilities parse-float split-sequence string-case +scalpl scalpl scalpl.bitfinex scalpl +scalpl scalpl scalpl.dbi dbi scalpl +scalpl scalpl scalpl.irc cl-irc scalpl +scalpl scalpl scalpl.kraken scalpl +scalpl scalpl scalpl.mpex rss scalpl +scalpl scalpl scalpl.poloniex scalpl +screamer screamer screamer asdf +screamer screamer-tests screamer-tests asdf hu.dwim.stefil iterate screamer +scriba scriba scriba common-doc-plump esrap plump-sexp +scriba scriba-test scriba-test fiveam scriba +scribble scribble scribble fare-memoization fare-quasiquote-readtable fare-utils meta +scribble scribble scribble/test babel hu.dwim.stefil scribble +scriptl scriptl scriptl alexandria asdf bordeaux-threads cl-ppcre defpackage-plus iolib osicat trivial-backtrace trivial-gray-streams trivial-utf-8 +scriptl scriptl-examples scriptl-examples asdf scriptl unix-options +scriptl scriptl-util scriptl-util asdf cl-ppcre scriptl +sdl2-game-controller-db sdl2-game-controller-db sdl2-game-controller-db asdf sdl2 +sdl2kit sdl2kit sdl2kit alexandria cl-opengl defpackage-plus sdl2 +sdl2kit sdl2kit-examples sdl2kit-examples alexandria defpackage-plus glkit mathkit sdl2kit +sealable-metaobjects sealable-metaobjects sealable-metaobjects asdf closer-mop trivial-macroexpand-all +sealable-metaobjects sealable-metaobjects-test-suite sealable-metaobjects-test-suite asdf closer-mop sealable-metaobjects +secret-values secret-values secret-values +secure-random secure-random secure-random cl+ssl +sel software-evolution-library software-evolution-library asdf asdf-package-system +sel software-evolution-library software-evolution-library/components/serapi-io alexandria arrow-macros cl-ppcre curry-compose-reader-macros fare-quasiquote iterate metabang-bind named-readtables optima split-sequence +sel software-evolution-library software-evolution-library/run-dump-store +sel software-evolution-library software-evolution-library/run-rest-server +sel software-evolution-library software-evolution-library/test alexandria arrow-macros cl-ppcre cl-store clack closer-mop curry-compose-reader-macros drakma fare-quasiquote hunchentoot iterate metabang-bind named-readtables optima osicat snooze split-sequence trace-db +select select select alexandria anaphora asdf let-plus +select select select/tests fiveam select +semantic-spinneret semantic-spinneret semantic-spinneret alexandria spinneret +sequence-iterators extensible-sequences extensible-sequences sequence-iterators +sequence-iterators sequence-iterators sequence-iterators parse-declarations-1.0 +sequence-iterators sequence-iterators sequence-iterators-test sequence-iterators +serapeum serapeum serapeum alexandria asdf bordeaux-threads fare-quasiquote-extras global-vars introspect-environment named-readtables parse-declarations-1.0 parse-number split-sequence string-case trivia trivia.quasiquote trivial-cltl2 trivial-file-size trivial-garbage trivial-macroexpand-all uiop +serializable-object serializable-object serializable-object alexandria asdf +serializable-object serializable-object.test serializable-object.test asdf fiveam serializable-object +series series series +series series series-tests series +session-token session-token session-token cl-isaac +sexml sexml sexml alexandria cl-ppcre contextl cxml macroexpand-dammit +sexml sexml-objects sexml-objects sexml +sha1 sha1 sha1 asdf base64 +sha3 sha3 sha3 asdf +shadchen shadchen shadchen +shadow shadow shadow alexandria asdf cl-opengl glsl-packing golden-utils origin static-vectors varjo +sheeple sheeple sheeple +sheeple sheeple sheeple-tests eos sheeple +shellpool shellpool shellpool bordeaux-threads bt-semaphore cl-fad trivial-features +shelly shelly shelly babel bordeaux-threads cl-fad local-time split-sequence trivial-signal uiop +shelly shelly-test shelly-test cl-test-more shelly +shorty shorty shorty asdf babel chipz cl-base64 dexador fast-io quri salza2 split-sequence +should-test should-test should-test asdf cl-ppcre local-time osicat rutils +shuffletron shuffletron shuffletron asdf mixalot mixalot-flac mixalot-mp3 mixalot-vorbis osicat +simple-actors simple-actors simple-actors asdf bordeaux-threads +simple-config simple-config simple-config asdf str uiop +simple-config simple-config-test simple-config-test asdf prove simple-config +simple-currency simple-currency simple-currency cl-store dexador plump simple-date split-sequence +simple-date-time simple-date-time simple-date-time cl-ppcre +simple-finalizer simple-finalizer simple-finalizer cffi trivial-garbage +simple-flow-dispatcher simple-flow-dispatcher simple-flow-dispatcher alexandria asdf cl-muth +simple-inferiors simple-inferiors simple-inferiors asdf bordeaux-threads documentation-utils uiop +simple-logger simple-logger simple-logger alexandria asdf local-time +simple-parallel-tasks simple-parallel-tasks simple-parallel-tasks asdf chanl +simple-parallel-tasks simple-parallel-tasks-tests simple-parallel-tasks-tests asdf fiveam simple-parallel-tasks +simple-rgb simple-rgb simple-rgb asdf +simple-routes simple-routes simple-routes asdf cl-ppcre hunchentoot +simple-routes simple-routes simpleroutes-demo cl-fad cl-ppcre cl-who hunchentoot simple-routes +simple-routes simple-routes simpleroutes-test simple-routes +simple-tasks simple-tasks simple-tasks array-utils asdf bordeaux-threads dissect +simplet simplet simplet asdf +simplet simplet-asdf simplet-asdf asdf +simplet simplet simplet/test simplet +simplified-types simplified-types simplified-types alexandria asdf introspect-environment trivia +simplified-types simplified-types-test-suite simplified-types-test-suite alexandria asdf simplified-types +simpsamp simpsamp simpsamp jpl-util +single-threaded-ccl single-threaded-ccl single-threaded-ccl +sip-hash sip-hash sip-hash com.google.base nibbles +sip-hash sip-hash-test sip-hash-test hu.dwim.stefil sip-hash +skeleton-creator skeleton-creator skeleton-creator asdf cl-fad cl-ppcre conf simplet-asdf +skeleton-creator skeleton-creator skeleton-creator/test simplet simplet-asdf skeleton-creator +sketch sketch sketch alexandria cl-geometry glkit mathkit md5 sdl2-image sdl2-ttf sdl2kit split-sequence static-vectors +sketch sketch-examples sketch-examples alexandria sketch +skippy skippy skippy +skippy-renderer skippy-renderer skippy-renderer asdf skippy +skitter skitter skitter alexandria asdf rtg-math structy-defclass +skitter skitter.glop skitter.glop asdf glop skitter +skitter skitter.sdl2 skitter.sdl2 asdf sdl2 skitter +slack-client slack-client slack-client babel blackbird cl-async drakma-async event-glue jonathan safe-queue websocket-driver +slack-client slack-client-test slack-client-test prove prove-asdf slack-client +slime swank swank asdf +slk-581 eclecticse.slk-581 eclecticse.slk-581 asdf cl-ppcre +sly slynk slynk asdf +sly slynk slynk/arglists slynk +sly slynk slynk/indentation slynk +sly slynk slynk/mrepl slynk +sly slynk slynk/package-fu slynk +sly slynk slynk/retro slynk +sly slynk slynk/stickers slynk +sly slynk slynk/util slynk +smackjack smackjack smackjack alexandria asdf cl-containers cl-json hunchentoot parenscript +smackjack smackjack-demo smackjack-demo asdf cl-containers cl-who local-time smackjack +smart-buffer smart-buffer smart-buffer flexi-streams uiop xsubseq +smart-buffer smart-buffer-test smart-buffer-test babel prove prove-asdf smart-buffer +smug smug smug asdf-package-system +sn.man sn.man sn.man asdf +snakes snakes snakes alexandria asdf cl-cont cl-utilities closer-mop fiveam iterate +snappy snappy snappy com.google.base nibbles varint +snappy snappy-test snappy-test acm-random hu.dwim.stefil nibbles snappy +snark snark snark snark-implementation +snark snark-agenda snark-agenda snark-auxiliary-packages snark-deque snark-lisp snark-sparse-array +snark snark-auxiliary-packages snark-auxiliary-packages +snark snark-deque snark-deque snark-auxiliary-packages snark-lisp +snark snark-dpll snark-dpll snark-auxiliary-packages snark-lisp +snark snark-examples snark-examples snark +snark snark-feature snark-feature snark-auxiliary-packages snark-lisp +snark snark-implementation snark-implementation snark-agenda snark-auxiliary-packages snark-deque snark-dpll snark-feature snark-infix-reader snark-lisp snark-numbering snark-pkg snark-sparse-array +snark snark-infix-reader snark-infix-reader snark-auxiliary-packages snark-lisp +snark snark-lisp snark-lisp snark-auxiliary-packages +snark snark-loads snark-loads +snark snark-numbering snark-numbering snark-auxiliary-packages snark-lisp snark-sparse-array +snark snark-pkg snark-pkg snark-dpll +snark snark-sparse-array snark-sparse-array snark-auxiliary-packages snark-lisp +sndfile-blob sndfile-blob sndfile-blob asdf bodge-blobs-support trivial-features +snmp snmp snmp ieee-floats ironclad portable-threads trivial-gray-streams usocket +snmp snmp-server snmp-server snmp usocket-server +snmp snmp-test snmp-test snmp snmp-server +snmp snmp-ui snmp-ui snmp +snooze snooze snooze alexandria asdf cl-ppcre closer-mop parse-float quri rfc2388 uiop +snooze snooze snooze-demo alexandria cl-css cl-fad cl-json cl-who hunchentoot local-time local-time-duration snooze +snooze snooze snooze-tests fiasco snooze +softdrink softdrink softdrink asdf lass lquery +solid-engine solid-engine solid-engine alexandria asdf +soundex soundex soundex +south south south asdf cl-ppcre drakma ironclad uuid +spatial-trees spatial-trees spatial-trees +spatial-trees spatial-trees.nns spatial-trees.nns alexandria iterate optima spatial-trees +spatial-trees spatial-trees.nns.test spatial-trees.nns.test alexandria fiveam iterate optima spatial-trees spatial-trees.nns +spatial-trees spatial-trees.test spatial-trees.test fiveam spatial-trees +specialization-store specialization-store specialization-store alexandria asdf introspect-environment specialization-store-features +specialization-store specialization-store-features specialization-store-features alexandria asdf introspect-environment +specialization-store specialization-store-tests specialization-store-tests asdf fiveam specialization-store +specialized-function specialized-function specialized-function alexandria asdf iterate lisp-namespace trivia trivial-cltl2 type-r +specialized-function specialized-function.test specialized-function.test asdf fiveam specialized-function +spell spell spell asdf +spell spell spell/simple +spellcheck spellcheck spellcheck alexandria cl-ppcre +spinneret spinneret spinneret alexandria asdf cl-ppcre global-vars parenscript serapeum trivial-gray-streams +spinneret spinneret spinneret/cl-markdown cl-markdown spinneret +spinneret spinneret spinneret/ps parenscript spinneret +spinneret spinneret spinneret/tests cl-markdown fiveam serapeum spinneret +split-sequence split-sequence split-sequence asdf +split-sequence split-sequence split-sequence/tests fiveam split-sequence +sprint-stars stars stars asdf cl-json drakma xmls +st-json st-json st-json asdf +staple staple staple asdf babel cl-ppcre clip definitions documentation-utils language-codes pathname-utils staple-code-parser staple-package-recording +staple staple-code-parser staple-code-parser alexandria asdf concrete-syntax-tree concrete-syntax-tree-destructuring concrete-syntax-tree-lambda-list definitions documentation-utils eclector eclector-concrete-syntax-tree +staple staple-markdown staple-markdown 3bmd 3bmd-ext-code-blocks asdf staple +staple staple-markless staple-markless asdf cl-markless-plump staple +staple staple-package-recording staple-package-recording asdf +staple staple-restructured-text staple-restructured-text asdf docutils staple +staple staple-server staple-server asdf dissect documentation-utils hunchentoot staple-markdown staple-markless +static-dispatch static-dispatch static-dispatch agutil alexandria anaphora asdf cl-arrows cl-environments closer-mop iterate prove-asdf trivia +static-dispatch static-dispatch static-dispatch/test prove prove-asdf static-dispatch +static-vectors static-vectors static-vectors alexandria asdf cffi cffi-grovel +static-vectors static-vectors static-vectors/test fiveam static-vectors +stealth-mixin stealth-mixin stealth-mixin asdf closer-mop +stefil stefil stefil alexandria asdf iterate metabang-bind swank +stefil stefil stefil-test stefil +stem stem stem +stl stl stl 3d-vectors +stmx stmx stmx alexandria asdf bordeaux-threads closer-mop log4cl trivial-garbage +stmx stmx stmx.test bordeaux-threads fiveam log4cl stmx +string-case string-case string-case asdf +string-escape string-escape string-escape +stripe stripe stripe alexandria asdf dexador golden-utils local-time yason +structy-defclass structy-defclass structy-defclass +studio-client studio-client studio-client asdf babel documentation-utils north-core yason +stumpwm stumpwm stumpwm alexandria asdf cl-ppcre clx +stumpwm stumpwm-tests stumpwm-tests asdf fiasco stumpwm +submarine submarine submarine iterate mop-utils postmodern +sucle aabbcc aabbcc asdf quads utility +sucle application application asdf bordeaux-threads cl-opengl deflazy glhelp nsb-cga scratch-buffer utility window +sucle application-example-hello-world application-example-hello-world application asdf +sucle camera-matrix camera-matrix asdf nsb-cga +sucle cartesian-graphing cartesian-graphing alexandria application asdf opengl-immediate utility +sucle character-modifier-bits character-modifier-bits asdf +sucle clock clock asdf utility +sucle control control asdf character-modifier-bits utility window +sucle deflazy deflazy asdf bordeaux-threads utility +sucle fast-text-grid-sprites fast-text-grid-sprites application asdf image-utility opengl-immediate quads sprite-chain text-subsystem utility +sucle fps-independent-timestep fps-independent-timestep asdf clock utility +sucle glhelp glhelp asdf cl-opengl deflazy glsl-toolkit split-sequence uncommon-lisp +sucle image-utility image-utility asdf opticl +sucle matrix matrix asdf +sucle nsb-cga nsb-cga asdf cl-reexport +sucle opengl-glfw3 opengl-glfw3 alexandria asdf bodge-glfw glfw-blob utility +sucle opengl-immediate opengl-immediate asdf cl-opengl reverse-array-iterator scratch-buffer utility +sucle quads quads asdf utility +sucle reverse-array-array reverse-array-array asdf reverse-array-iterator utility +sucle reverse-array-array-example reverse-array-array-example asdf reverse-array-array +sucle reverse-array-iterator reverse-array-iterator asdf utility +sucle sandbox sandbox asdf bordeaux-threads chipz cl-conspack cl-cpus cl-opengl glhelp lparallel nsb-cga quads reverse-array-iterator salza2 scratch-buffer uncommon-lisp utility +sucle scratch-buffer scratch-buffer asdf bordeaux-threads reverse-array-iterator utility +sucle sketch-sucle sketch-sucle alexandria asdf cl-geometry glhelp glkit image-utility mathkit md5 split-sequence static-vectors uncommon-lisp vecto +sucle sketch-sucle-examples sketch-sucle-examples alexandria asdf sketch-sucle +sucle sprite-chain sprite-chain asdf sucle-doubly-linked-list uncommon-lisp +sucle sucle sucle application asdf cartesian-graphing fast-text-grid-sprites sketch-sucle-examples testbed utility vecto-stuff +sucle sucle-doubly-linked-list sucle-doubly-linked-list asdf utility +sucle sucle2 sucle2 application asdf +sucle testbed testbed aabbcc alexandria application asdf camera-matrix control fps-independent-timestep image-utility reverse-array-iterator sandbox uncommon-lisp +sucle text-subsystem text-subsystem application asdf deflazy image-utility quads utility +sucle text-subsystem-generate-font text-subsystem-generate-font asdf cl-freetype2 opticl utility +sucle uncommon-lisp uncommon-lisp asdf structy-defclass +sucle vecto-stuff vecto-stuff application asdf image-utility lparallel text-subsystem utility vecto +sucle window window asdf opengl-glfw3 +swank-client swank-client swank-client asdf bordeaux-threads com.google.base swank usocket +swank-client swank-client-test swank-client-test asdf bordeaux-threads hu.dwim.stefil swank swank-client +swank-crew swank-crew swank-crew bordeaux-threads com.google.base com.google.flag osicat swank-client +swank-crew swank-crew-test swank-crew-test hu.dwim.stefil swank-crew +swank-protocol swank-protocol swank-protocol swank usocket +swank.live swank.live swank.live swank +swap-bytes swap-bytes swap-bytes asdf trivial-features +swap-bytes swap-bytes swap-bytes/test fiveam swap-bytes +sxql sxql sxql alexandria asdf cl-syntax-annot iterate optima split-sequence trivial-types +sxql sxql-test sxql-test asdf prove prove-asdf sxql +sycamore sycamore sycamore alexandria asdf cl-fuzz cl-ppcre lisp-unit +symbol-munger symbol-munger symbol-munger alexandria iterate +symbol-munger symbol-munger symbol-munger-test lisp-unit2 symbol-munger +symbol-namespaces symbol-namespaces symbol-namespaces map-bind +synonyms synonyms synonyms asdf +system-locale system-locale system-locale asdf documentation-utils +tagger tagger tagger asdf closer-mop +taglib taglib taglib asdf bordeaux-threads flexi-streams optima optima.ppcre +taglib taglib-tests taglib-tests asdf chanl cl-fad taglib +talcl talcl talcl alexandria asdf buildnode cl-ppcre cxml iterate symbol-munger +talcl talcl talcl-examples buildnode-xhtml talcl +talcl talcl talcl-speed-tests buildnode-xhtml lisp-unit2 talcl talcl-examples +talcl talcl talcl-test buildnode-xhtml lisp-unit2 talcl +tap-unit-test tap-unit-test tap-unit-test +targa targa targa asdf +teepeedee2 teepeedee2 teepeedee2 alexandria cffi cl-cont cl-fad cl-irregsexp iterate parenscript trivial-backtrace trivial-garbage +teepeedee2 teepeedee2-test teepeedee2-test fiveam teepeedee2 +telnetlib telnetlib telnetlib cl-ppcre +template template template alexandria asdf parameterized-function +template-function template-function template-function alexandria introspect-environment specialization-store +template-function template-function-tests template-function-tests fiveam template-function +temporal-functions temporal-functions temporal-functions fn +temporary-file temporary-file temporary-file alexandria bordeaux-threads cl-fad cl-ppcre unit-test +terminfo terminfo terminfo asdf +terrable terrable terrable asdf documentation-utils fast-io ieee-floats static-vectors trivial-garbage +test-utils test-utils test-utils alexandria asdf cl-quickcheck prove +testbild testbild testbild cl-ppcre graylex +testbild testbild-test testbild-test alexandria cl-heredoc testbild trivial-gray-streams +texp texp texp named-readtables +text-query text-query text-query +tfm net.didierverna.tfm net.didierverna.tfm asdf net.didierverna.tfm.core net.didierverna.tfm.setup +tfm net.didierverna.tfm.core net.didierverna.tfm.core asdf net.didierverna.tfm.setup +tfm net.didierverna.tfm.setup net.didierverna.tfm.setup asdf +the-cost-of-nothing the-cost-of-nothing the-cost-of-nothing alexandria asdf closer-mop local-time trivial-garbage +thnappy thnappy thnappy asdf cffi +thorn thorn thorn common-doc +thorn thorn-doc thorn-doc thorn +thorn thorn-test thorn-test fiveam thorn thorn-doc +thread-pool thread-pool thread-pool arnesi bordeaux-threads +thread.comm.rendezvous thread.comm.rendezvous thread.comm.rendezvous bordeaux-threads cl-annot +thread.comm.rendezvous thread.comm.rendezvous.test thread.comm.rendezvous.test cl-test-more thread.comm.rendezvous +time-interval time-interval time-interval asdf cl-ppcre local-time +timer-wheel timer-wheel timer-wheel asdf bordeaux-threads +timer-wheel timer-wheel.examples timer-wheel.examples asdf bordeaux-threads timer-wheel +tinaa tinaa tinaa anaphora asdf-system-connections cl-containers cl-graph defsystem-compatibility dynamic-classes lml2 metatilities trivial-shell +tinaa tinaa-test tinaa-test lift tinaa +tinaa tinaa tinaa/with-cl-markdown cl-markdown tinaa +tm tm tm asdf bordeaux-threads local-time +tmpdir tmpdir tmpdir asdf uiop +toadstool toadstool toadstool closer-mop +toadstool toadstool-tests toadstool-tests stefil toadstool +toot toot toot alexandria bordeaux-threads chunga cl+ssl cl-base64 cl-fad cl-ppcre flexi-streams md5 puri trivial-backtrace usocket +tooter tooter tooter asdf cl-ppcre documentation-utils drakma yason +torta torta torta gordon +towers towers towers alexandria cl-glu cl-glut cl-opengl +trace-db trace-db trace-db alexandria arrow-macros asdf bordeaux-threads cffi cffi-libffi cl-store curry-compose-reader-macros iterate named-readtables trivial-garbage +track-best track-best track-best asdf +track-best track-best track-best-tests nst track-best +trainable-object trainable-object trainable-object asdf closer-mop serializable-object +trainable-object trainable-object.test trainable-object.test asdf fiveam trainable-object +translate translate translate asdf +translate translate translate/test fiveam translate +translate-client translate-client translate-client alexandria asdf assoc-utils dexador quri yason +transparent-wrap transparent-wrap transparent-wrap fare-quasiquote-extras named-readtables optima trivial-arguments +transparent-wrap transparent-wrap transparent-wrap-test alexandria stefil transparent-wrap +treedb treedb treedb cl-json +treedb treedb.doc treedb.doc cl-gendoc treedb treedb.tests +treedb treedb.tests treedb.tests fiveam treedb +trees trees trees asdf +trees trees trees-tests trees +trivia trivia trivia asdf trivia.balland2006 +trivia trivia.balland2006 trivia.balland2006 alexandria asdf iterate trivia.trivial type-i +trivia trivia.benchmark trivia.benchmark asdf iterate optima trivia trivia.balland2006 +trivia trivia.benchmark trivia.benchmark/run trivia.benchmark +trivia trivia.cffi trivia.cffi asdf cffi trivia.trivial +trivia trivia.level0 trivia.level0 alexandria asdf +trivia trivia.level1 trivia.level1 asdf trivia.level0 +trivia trivia.level2 trivia.level2 asdf closer-mop lisp-namespace trivia.level1 trivial-cltl2 +trivia trivia.ppcre trivia.ppcre asdf cl-ppcre trivia.trivial +trivia trivia.quasiquote trivia.quasiquote asdf fare-quasiquote-readtable trivia.trivial +trivia trivia.test trivia.test asdf fiveam optima trivia trivia.cffi trivia.ppcre trivia.quasiquote +trivia trivia.trivial trivia.trivial asdf trivia.level2 +trivial-arguments trivial-arguments trivial-arguments asdf +trivial-backtrace trivial-backtrace trivial-backtrace asdf +trivial-backtrace trivial-backtrace-test trivial-backtrace-test asdf lift trivial-backtrace +trivial-battery trivial-battery trivial-battery asdf +trivial-benchmark trivial-benchmark trivial-benchmark alexandria asdf +trivial-bit-streams trivial-bit-streams trivial-bit-streams asdf trivial-gray-streams +trivial-bit-streams trivial-bit-streams-tests trivial-bit-streams-tests asdf fiveam flexi-streams trivial-bit-streams +trivial-build trivial-build trivial-build lisp-invocation trivial-exe +trivial-build trivial-build-test trivial-build-test fiveam trivial-build +trivial-channels trivial-channels trivial-channels bordeaux-threads trivial-timeout +trivial-clipboard trivial-clipboard trivial-clipboard asdf uiop +trivial-clipboard trivial-clipboard-test trivial-clipboard-test asdf fiveam trivial-clipboard +trivial-cltl2 trivial-cltl2 trivial-cltl2 asdf +trivial-compress trivial-compress trivial-compress alexandria archive uiop which zip +trivial-compress trivial-compress-test trivial-compress-test fiveam trivial-compress +trivial-continuation trivial-continuation trivial-continuation asdf log4cl trivial-utilities +trivial-continuation trivial-continuation trivial-continuation/test fiveam trivial-continuation +trivial-debug-console trivial-debug-console trivial-debug-console cffi +trivial-documentation trivial-documentation trivial-documentation closer-mop +trivial-documentation trivial-documentation-test trivial-documentation-test trivial-documentation +trivial-download trivial-download trivial-download drakma +trivial-download trivial-download-test trivial-download-test clack clack-v1-compat fiveam trivial-download +trivial-dump-core trivial-dump-core trivial-dump-core +trivial-escapes trivial-escapes trivial-escapes asdf named-readtables +trivial-escapes trivial-escapes-test trivial-escapes-test asdf fiveam trivial-escapes uiop +trivial-exe trivial-exe trivial-exe osicat uiop +trivial-exe trivial-exe-test trivial-exe-test fiveam trivial-exe +trivial-extensible-sequences trivial-extensible-sequences trivial-extensible-sequences asdf +trivial-extract trivial-extract trivial-extract alexandria archive cl-fad deflate uiop which zip +trivial-extract trivial-extract-test trivial-extract-test fiveam trivial-extract +trivial-features trivial-features trivial-features asdf +trivial-features trivial-features-tests trivial-features-tests alexandria asdf cffi cffi-grovel rt trivial-features +trivial-file-size trivial-file-size trivial-file-size asdf uiop +trivial-file-size trivial-file-size trivial-file-size/tests fiveam trivial-file-size +trivial-garbage trivial-garbage trivial-garbage asdf +trivial-garbage trivial-garbage trivial-garbage/tests rt trivial-garbage +trivial-gray-streams trivial-gray-streams trivial-gray-streams asdf +trivial-gray-streams trivial-gray-streams-test trivial-gray-streams-test asdf trivial-gray-streams +trivial-hashtable-serialize trivial-hashtable-serialize trivial-hashtable-serialize asdf split-sequence +trivial-http trivial-http trivial-http usocket +trivial-http trivial-http-test trivial-http-test lift trivial-http +trivial-indent trivial-indent trivial-indent asdf +trivial-irc trivial-irc trivial-irc cl-ppcre split-sequence usocket +trivial-irc trivial-irc-echobot trivial-irc-echobot trivial-irc +trivial-json-codec trivial-json-codec trivial-json-codec asdf closer-mop iterate log4cl parse-number trivial-utilities +trivial-jumptables trivial-jumptables trivial-jumptables asdf +trivial-jumptables trivial-jumptables_tests trivial-jumptables_tests asdf bubble-operator-upwards parachute trivial-jumptables +trivial-lazy trivial-lazy trivial-lazy bordeaux-threads +trivial-ldap trivial-ldap trivial-ldap asdf cl+ssl usocket yacc +trivial-left-pad trivial-left-pad trivial-left-pad alexandria asdf prove-asdf +trivial-left-pad trivial-left-pad trivial-left-pad-test prove prove-asdf trivial-left-pad +trivial-macroexpand-all trivial-macroexpand-all trivial-macroexpand-all +trivial-main-thread trivial-main-thread trivial-main-thread asdf bordeaux-threads simple-tasks trivial-features +trivial-method-combinations trivial-method-combinations trivial-method-combinations asdf closer-mop +trivial-mimes trivial-mimes trivial-mimes asdf +trivial-mmap trivial-mmap trivial-mmap alexandria asdf osicat +trivial-monitored-thread trivial-monitored-thread trivial-monitored-thread asdf iterate log4cl trivial-utilities +trivial-monitored-thread trivial-monitored-thread trivial-monitored-thread/test fiveam trivial-monitored-thread +trivial-msi trivial-msi trivial-msi uiop +trivial-msi trivial-msi-test trivial-msi-test fiveam trivial-msi +trivial-nntp trivial-nntp trivial-nntp cl+ssl usocket +trivial-object-lock trivial-object-lock trivial-object-lock asdf bordeaux-threads iterate log4cl trivial-utilities +trivial-object-lock trivial-object-lock trivial-object-lock/test fiveam trivial-object-lock +trivial-octet-streams trivial-octet-streams trivial-octet-streams +trivial-open-browser trivial-open-browser trivial-open-browser uiop +trivial-openstack trivial-openstack trivial-openstack alexandria drakma local-time st-json +trivial-openstack trivial-openstack-test trivial-openstack-test fiveam hunchentoot local-time st-json trivial-openstack uri-template +trivial-package-local-nicknames trivial-package-local-nicknames trivial-package-local-nicknames asdf +trivial-package-manager trivial-package-manager trivial-package-manager alexandria trivial-features trivial-open-browser +trivial-package-manager trivial-package-manager.test trivial-package-manager.test fiveam trivial-package-manager +trivial-pooled-database trivial-pooled-database trivial-pooled-database asdf bordeaux-threads cl-dbi iterate log4cl parse-number trivial-object-lock trivial-utilities +trivial-project trivial-project trivial-project alexandria cl-ppcre +trivial-raw-io trivial-raw-io trivial-raw-io alexandria +trivial-renamer trivial-renamer trivial-renamer cl-ppcre +trivial-rfc-1123 trivial-rfc-1123 trivial-rfc-1123 cl-ppcre +trivial-shell trivial-shell trivial-shell asdf +trivial-shell trivial-shell-test trivial-shell-test asdf lift trivial-shell +trivial-signal trivial-signal trivial-signal asdf bordeaux-threads cffi cffi-grovel +trivial-sockets trivial-sockets trivial-sockets asdf +trivial-ssh trivial-ssh trivial-ssh asdf trivial-ssh-libssh2 +trivial-ssh trivial-ssh-libssh2 trivial-ssh-libssh2 asdf babel cffi cffi-grovel cl-fad split-sequence trivial-gray-streams usocket +trivial-ssh trivial-ssh-test trivial-ssh-test asdf fiveam trivial-ssh +trivial-string-template trivial-string-template trivial-string-template alexandria cl-ppcre closer-mop proc-parse +trivial-string-template trivial-string-template-test trivial-string-template-test alexandria prove prove-asdf trivial-string-template +trivial-swank trivial-swank trivial-swank asdf bordeaux-threads usocket verbose +trivial-tco trivial-tco trivial-tco +trivial-tco trivial-tco-test trivial-tco-test clunit trivial-tco +trivial-thumbnail trivial-thumbnail trivial-thumbnail asdf uiop +trivial-timeout trivial-timeout trivial-timeout asdf +trivial-timer trivial-timer trivial-timer asdf bordeaux-threads chanl iterate log4cl trivial-utilities +trivial-timer trivial-timer trivial-timer/test fiveam trivial-timer +trivial-timers trivial-timers trivial-timers +trivial-types trivial-types trivial-types +trivial-update trivial-update trivial-update asdf +trivial-utf-8 trivial-utf-8 trivial-utf-8 +trivial-utf-8 trivial-utf-8 trivial-utf-8-tests trivial-utf-8 +trivial-utilities trivial-utilities trivial-utilities alexandria asdf closer-mop iterate +trivial-variable-bindings trivial-variable-bindings trivial-variable-bindings asdf iterate trivial-utilities +trivial-variable-bindings trivial-variable-bindings trivial-variable-bindings/test fiveam trivial-variable-bindings +trivial-wish trivial-wish trivial-wish +trivial-with trivial-with trivial-with +trivial-ws trivial-ws trivial-ws asdf hunchensocket +trivial-ws trivial-ws-client trivial-ws-client asdf cl-async websocket-driver +trivial-ws trivial-ws-test trivial-ws-test asdf find-port prove prove-asdf trivial-ws trivial-ws-client +trivial-yenc trivial-yenc trivial-yenc split-sequence +trivialib.bdd trivialib.bdd trivialib.bdd alexandria asdf immutable-struct trivia trivial-garbage +trivialib.bdd trivialib.bdd.test trivialib.bdd.test asdf fiveam trivialib.bdd +trivialib.type-unify trivialib.type-unify trivialib.type-unify alexandria introspect-environment trivia type-r +trivialib.type-unify trivialib.type-unify.test trivialib.type-unify.test fiveam trivialib.type-unify +twfy twfy twfy cl-json drakma +type-i type-i type-i alexandria asdf introspect-environment lisp-namespace trivia.trivial +type-i type-i.test type-i.test asdf fiveam type-i +type-r type-r type-r alexandria asdf trivia +type-r type-r.test type-r.test asdf fiveam type-r +uax-14 uax-14 uax-14 asdf documentation-utils +uax-14 uax-14-test uax-14-test asdf cl-ppcre parachute uax-14 +uax-9 uax-9 uax-9 asdf documentation-utils +uax-9 uax-9-test uax-9-test asdf cl-ppcre parachute uax-9 +ubiquitous ubiquitous ubiquitous asdf +ubiquitous ubiquitous-concurrent ubiquitous-concurrent asdf bordeaux-threads ubiquitous +ucons ucons ucons alexandria asdf named-readtables +ucw ucw ucw cl-ppcre closer-mop ucw-core +ucw ucw-core ucw-core arnesi bordeaux-threads cl-fad closer-mop iterate local-time net-telent-date rfc2109 swank trivial-garbage usocket yaclml +ucw ucw-core ucw-core.test arnesi cxml drakma iterate stefil ucw-core +ucw ucw ucw.examples ucw +ucw ucw-core ucw.httpd cl-ppcre puri rfc2388-binary ucw-core +ucw ucw ucw.manual-examples ucw +uffi uffi uffi asdf +uffi uffi-tests uffi-tests asdf uffi +ufo ufo ufo uiop +ufo ufo-test ufo-test cl-fad prove prove-asdf ufo +ugly-tiny-infix-macro ugly-tiny-infix-macro ugly-tiny-infix-macro +uiop asdf-driver asdf-driver asdf uiop +uiop uiop uiop asdf +umbra umbra umbra alexandria asdf shadow varjo +umlisp umlisp umlisp asdf clsql clsql-mysql hyperobject kmrcl +umlisp umlisp-tests umlisp-tests asdf rt umlisp +umlisp-orf umlisp-orf umlisp-orf clsql clsql-postgresql-socket hyperobject kmrcl +unicly unicly unicly ironclad split-sequence +unit-formula unit-formulas unit-formulas alexandria asdf iterate +unit-test unit-test unit-test +universal-config universal-config universal-config asdf cl-ppcre parse-float +unix-options unix-options unix-options +unix-opts unix-opts unix-opts asdf +unix-opts unix-opts-tests unix-opts-tests asdf unix-opts +uri-template uri-template uri-template asdf cl-ppcre flexi-streams named-readtables +uri-template uri-template.test uri-template.test asdf fiveam uri-template +url-rewrite url-rewrite url-rewrite +userial userial userial contextl ieee-floats trivial-utf-8 +userial userial-tests userial-tests nst userial +usocket usocket usocket asdf split-sequence +usocket usocket-server usocket-server asdf bordeaux-threads usocket +usocket usocket-test usocket-test asdf rt usocket-server +utilities.binary-dump utilities.binary-dump utilities.binary-dump alexandria asdf let-plus nibbles +utilities.binary-dump utilities.binary-dump utilities.binary-dump/test alexandria fiveam let-plus nibbles split-sequence utilities.binary-dump +utilities.print-items utilities.print-items utilities.print-items alexandria asdf +utilities.print-items utilities.print-items utilities.print-items/test fiveam utilities.print-items +utilities.print-tree utilities.print-tree utilities.print-tree alexandria uiop +utilities.print-tree utilities.print-tree utilities.print-tree/test alexandria fiveam uiop utilities.print-tree +utility utility utility asdf +utility-arguments utility-arguments utility-arguments alexandria +utils-kt utils-kt utils-kt asdf +utm utm utm asdf +utm utm.test utm.test asdf fiveam utm +uuid uuid uuid asdf ironclad trivial-utf-8 +varjo varjo varjo alexandria asdf cl-ppcre documentation-utils fn glsl-docs glsl-spec glsl-symbols named-readtables parse-float uiop vas-string-metrics +varjo varjo.import varjo.import asdf fare-quasiquote-extras glsl-toolkit optima rtg-math.vari split-sequence varjo +varjo varjo.tests varjo.tests asdf fiveam rtg-math.vari varjo +vas-string-metrics test.vas-string-metrics test.vas-string-metrics vas-string-metrics +vas-string-metrics vas-string-metrics vas-string-metrics +vecto vecto vecto cl-vectors zpb-ttf zpng +vecto vectometry vectometry vecto +vector com.elbeno.vector com.elbeno.vector +vectors vectors vectors +verbose verbose verbose asdf bordeaux-threads dissect documentation-utils local-time piping +vernacular vernacular vernacular asdf +verrazano verrazano verrazano alexandria cffi cl-ppcre closer-mop cxml iterate metabang-bind parse-number trivial-shell +verrazano verrazano-runtime verrazano-runtime cffi +vertex vertex vertex common-doc common-doc-plump plump-tex +vertex vertex-test vertex-test fiveam vertex +vgplot vgplot vgplot asdf cl-fad cl-ppcre ltk +vgplot vgplot vgplot-test lisp-unit vgplot +vom vom vom +water water water asdf parenscript +weblocks weblocks weblocks anaphora asdf babel bordeaux-threads cl-cont cl-fad cl-json cl-ppcre cl-who closer-mop f-underscore html-template hunchentoot metatilities optima parenscript parse-number pretty-function puri salza2 split-sequence trivial-backtrace trivial-timeout weblocks-stores weblocks-util +weblocks weblocks-demo-popover weblocks-demo-popover asdf metatilities weblocks weblocks-yarek +weblocks weblocks-s11 weblocks-s11 arnesi asdf weblocks +weblocks weblocks-scripts weblocks-scripts asdf cl-fad cl-ppcre +weblocks weblocks-test weblocks-test anaphora asdf closer-mop f-underscore lift metatilities weblocks weblocks-prototype-js weblocks-stores +weblocks weblocks-util weblocks-util anaphora asdf bordeaux-threads cl-cont cl-fad cl-json cl-ppcre cl-who closer-mop f-underscore html-template hunchentoot ironclad metatilities optima parenscript parse-number pretty-function puri salza2 trivial-backtrace trivial-timeout +weblocks weblocks-yarek weblocks-yarek asdf weblocks +weblocks weblocks-yui weblocks-yui asdf weblocks +weblocks-examples simple-blog simple-blog weblocks +weblocks-examples weblocks-clsql-demo weblocks-clsql-demo metatilities weblocks weblocks-clsql weblocks-stores +weblocks-examples weblocks-demo weblocks-demo metatilities weblocks +weblocks-prototype-js weblocks-prototype-js weblocks-prototype-js weblocks weblocks-utils +weblocks-stores weblocks-clsql weblocks-clsql closer-mop clsql clsql-fluid metatilities weblocks-stores weblocks-util +weblocks-stores weblocks-custom weblocks-custom trivial-garbage weblocks weblocks-memory weblocks-stores +weblocks-stores weblocks-memory weblocks-memory cl-ppcre metatilities weblocks-stores +weblocks-stores weblocks-montezuma weblocks-montezuma montezuma weblocks-stores +weblocks-stores weblocks-perec weblocks-perec hu.dwim.perec weblocks-stores +weblocks-stores weblocks-postmodern weblocks-postmodern postmodern weblocks weblocks-stores +weblocks-stores weblocks-prevalence weblocks-prevalence bordeaux-threads cl-ppcre cl-prevalence metatilities weblocks-memory weblocks-stores +weblocks-stores weblocks-store-test weblocks-store-test f-underscore lift weblocks weblocks-memory weblocks-test +weblocks-stores weblocks-stores weblocks-stores closer-mop metatilities weblocks-util +weblocks-tree-widget weblocks-tree-widget weblocks-tree-widget alexandria weblocks yaclml +weblocks-utils weblocks-utils weblocks-utils alexandria arnesi cl-fad cl-json cl-tidy clache drakma uiop weblocks weblocks-custom weblocks-stores weblocks-tree-widget +websocket-driver websocket-driver websocket-driver asdf websocket-driver-client websocket-driver-server +websocket-driver websocket-driver-base websocket-driver-base asdf bordeaux-threads cl-base64 event-emitter fast-io fast-websocket ironclad split-sequence +websocket-driver websocket-driver-client websocket-driver-client asdf cl+ssl cl-base64 fast-http fast-io fast-websocket ironclad quri trivial-utf-8 usocket websocket-driver-base +websocket-driver websocket-driver-server websocket-driver-server asdf clack-socket fast-io fast-websocket ironclad trivial-utf-8 websocket-driver-base +weft weft weft asdf bordeaux-threads log4cl trivial-timeout usocket +westbrook westbrook westbrook asdf cxml +westbrook westbrook-tests westbrook-tests asdf fiasco westbrook +what3words what3words what3words cl-ppcre drakma jsown +which which which cl-fad path-parse uiop +which which-test which-test fiveam which +whofields whofields whofields asdf asdf-package-system +whofields whofields whofields/test +wild-package-inferred-system foo-wild foo-wild asdf wild-package-inferred-system +wild-package-inferred-system wild-package-inferred-system wild-package-inferred-system asdf +wild-package-inferred-system wild-package-inferred-system wild-package-inferred-system/test fiveam wild-package-inferred-system +winhttp winhttp winhttp asdf cffi +winlock winlock winlock asdf cffi named-readtables serapeum +winlock winlock winlock/test fiveam winlock +with-c-syntax with-c-syntax with-c-syntax alexandria asdf float-features floating-point-contractions named-readtables osicat yacc +with-c-syntax with-c-syntax-test with-c-syntax-test 1am asdf floating-point trivial-cltl2 with-c-syntax +with-cached-reader-conditionals with-cached-reader-conditionals with-cached-reader-conditionals +with-output-to-stream with-output-to-stream with-output-to-stream asdf +with-output-to-stream with-output-to-stream_tests with-output-to-stream_tests asdf parachute with-output-to-stream +with-setf with-setf with-setf asdf +with-shadowed-bindings with-shadowed-bindings with-shadowed-bindings asdf map-bind +with-shadowed-bindings with-shadowed-bindings_tests with-shadowed-bindings_tests asdf parachute with-shadowed-bindings +with-user-abort with-user-abort with-user-abort asdf +woo clack-handler-woo clack-handler-woo asdf woo +woo woo woo alexandria asdf bordeaux-threads cffi cffi-grovel clack-socket fast-http fast-io lev quri smart-buffer static-vectors swap-bytes trivial-utf-8 vom +woo woo-test woo-test asdf clack-test rove woo +wookie wookie wookie alexandria asdf babel blackbird chunga cl-async cl-async-ssl cl-fad cl-ppcre do-urlencode fast-http fast-io quri vom +wordnet wordnet wordnet asdf split-sequence +workout-timer workout-timer workout-timer asdf cffi-toolchain +workout-timer workout-timer workout-timer/static cffi-toolchain workout-timer +wu-decimal wu-decimal wu-decimal +wu-sugar wu-sugar wu-sugar +wuwei wuwei wuwei asdf aserve cl-json drakma ironclad mtlisp +wuwei wuwei wuwei-examples drakma wuwei +x.fdatatypes x.fdatatypes x.fdatatypes +x.fdatatypes x.fdatatypes-iterate x.fdatatypes-iterate iterate x.fdatatypes x.let-star +x.let-star x.let-star x.let-star +xarray xarray xarray anaphora cl-utilities iterate metabang-bind +xarray xarray-test xarray-test lift xarray +xecto xecto xecto +xhtmlambda xhtmlambda xhtmlambda asdf cl-unicode +xhtmlgen xhtmlgen xhtmlgen cxml +xhtmlgen xhtmlgen xhtmlgen-test rt xhtmlgen +xlsx xlsx xlsx asdf flexi-streams xmls zip +xlunit xlunit xlunit +xlunit xlunit xlunit-tests xlunit +xml-emitter xml-emitter xml-emitter asdf cl-utilities +xml-mop xml-mop xml-mop closer-mop s-xml +xml.location xml.location xml.location alexandria asdf closer-mop cxml-stp iterate let-plus more-conditions split-sequence xpath +xml.location xml.location-and-local-time xml.location-and-local-time asdf local-time xml.location +xml.location xml.location xml.location/test lift xml.location +xmls xmls xmls asdf +xmls xmls xmls/octets cl-ppcre flexi-streams xmls +xmls xmls xmls/test xmls +xmls xmls xmls/unit-test fiveam xmls +xptest xptest xptest +xsubseq xsubseq xsubseq +xsubseq xsubseq-test xsubseq-test prove prove-asdf xsubseq +xuriella xuriella xuriella closure-html cxml cxml-stp split-sequence xpath +yaclml yaclml yaclml arnesi asdf iterate +yaclml yaclml yaclml/test fiveam yaclml +yason yason yason alexandria asdf trivial-gray-streams +youtube youtube youtube alexandria asdf bordeaux-threads cl-ppcre yason +zacl zacl zacl alexandria asdf bordeaux-threads cl+ssl cl-base64 cl-ppcre cl-store flexi-streams local-time md5 queues.simple-queue quri split-sequence trivial-backtrace trivial-garbage uiop usocket +zaws zaws zaws cl-base64 drakma flexi-streams ironclad +zaws zaws-xml zaws-xml cxml +zbucium zbucium zbucium alexandria asdf bordeaux-threads drakma fare-memoization generators lastfm local-time lquery lyrics plump yason youtube +zcdb zcdb zcdb +zenekindarl zenekindarl zenekindarl alexandria anaphora babel cl-annot cl-ppcre fast-io html-encode maxpc optima +zenekindarl zenekindarl-test zenekindarl-test flexi-streams prove zenekindarl +zip zip zip babel cl-fad salza2 trivial-gray-streams +ziz ziz ziz alexandria asdf hunchentoot ironclad trivial-file-size +zlib zlib zlib +zpb-exif zpb-exif zpb-exif +zpb-ttf zpb-ttf zpb-ttf +zpng zpng zpng salza2 +zs3 zs3 zs3 alexandria asdf cl-base64 cxml drakma ironclad puri +zsort zsort zsort alexandria diff --git a/sbcl/.quicklisp/local-projects/system-index.txt b/sbcl/.quicklisp/local-projects/system-index.txt new file mode 100644 index 0000000..e69de29 diff --git a/sbcl/.quicklisp/quicklisp/bundle-template.lisp b/sbcl/.quicklisp/quicklisp/bundle-template.lisp new file mode 100644 index 0000000..8f71459 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/bundle-template.lisp @@ -0,0 +1,161 @@ +(cl:in-package #:cl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "asdf") + (unless (find-package '#:asdf) + (error "ASDF could not be required"))) + +(let ((indicator '#:ql-bundle-v1) + (searcher-name '#:ql-bundle-searcher) + (base (make-pathname :name nil :type nil + :defaults #. (or *compile-file-truename* + *load-truename*)))) + (labels ((file-lines (file) + (with-open-file (stream file) + (loop for line = (read-line stream nil) + while line + collect line))) + (relative (pathname) + (merge-pathnames pathname base)) + (pathname-timestamp (pathname) + #+clisp + (nth-value 2 (ext:probe-pathname pathname)) + #-clisp + (file-write-date pathname)) + (system-table (table pathnames) + (dolist (pathname pathnames table) + (setf (gethash (pathname-name pathname) table) + (relative pathname)))) + + (initialize-bundled-systems-table (table data-source) + (system-table table + (mapcar (lambda (line) + (merge-pathnames line data-source)) + (file-lines data-source)))) + + (local-projects-system-pathnames (data-source) + (let ((files (directory (merge-pathnames "**/*.asd" + data-source)))) + (stable-sort (sort files #'string< :key #'namestring) + #'< + :key (lambda (file) + (length (namestring file)))))) + (initialize-local-projects-table (table data-source) + (system-table table (local-projects-system-pathnames data-source))) + + (make-table (&key data-source init-function) + (let ((table (make-hash-table :test 'equalp))) + (setf (gethash "/data-source" table) + data-source + (gethash "/timestamp" table) + (pathname-timestamp data-source) + (gethash "/init" table) + init-function) + table)) + + (tcall (table key &rest args) + (let ((fun (gethash key table))) + (unless (and fun (functionp fun)) + (error "Unknown function key ~S" key)) + (apply fun args))) + (created-timestamp (table) + (gethash "/timestamp" table)) + (data-source-timestamp (table) + (pathname-timestamp (data-source table))) + (data-source (table) + (gethash "/data-source" table)) + + (stalep (table) + ;; FIXME: Handle newly missing data sources? + (< (created-timestamp table) + (data-source-timestamp table))) + (meta-key-p (key) + (and (stringp key) + (< 0 (length key)) + (char= (char key 0) #\/))) + (clear (table) + ;; Don't clear "/foo" keys + (maphash (lambda (key value) + (declare (ignore value)) + (unless (meta-key-p key) + (remhash key table))) + table)) + (initialize (table) + (tcall table "/init" table (data-source table)) + (setf (gethash "/timestamp" table) + (pathname-timestamp (data-source table))) + table) + (update (table) + (clear table) + (initialize table)) + (lookup (system-name table) + (when (stalep table) + (update table)) + (values (gethash system-name table))) + + (search-function (system-name) + (let ((tables (get searcher-name indicator))) + (dolist (table tables) + (let* ((result (lookup system-name table)) + (probed (and result (probe-file result)))) + (when probed + (return probed)))))) + + (make-bundled-systems-table () + (initialize + (make-table :data-source (relative "system-index.txt") + :init-function #'initialize-bundled-systems-table))) + (make-bundled-local-projects-systems-table () + (let ((data-source (relative "bundled-local-projects/system-index.txt"))) + (when (probe-file data-source) + (initialize + (make-table :data-source data-source + :init-function #'initialize-bundled-systems-table))))) + (make-local-projects-table () + (initialize + (make-table :data-source (relative "local-projects/") + :init-function #'initialize-local-projects-table))) + + (=matching-data-sources (tables) + (let ((data-sources (mapcar #'data-source tables))) + (lambda (table) + (member (data-source table) data-sources + :test #'equalp)))) + + (check-for-existing-searcher (searchers) + (block done + (dolist (searcher searchers) + (when (symbolp searcher) + (let ((plist (symbol-plist searcher))) + (loop for key in plist by #'cddr + when + (and (symbolp key) (string= key indicator)) + do + (setf indicator key) + (setf searcher-name searcher) + (return-from done t))))))) + + (clear-asdf (table) + (maphash (lambda (system-name pathname) + (declare (ignore pathname)) + (asdf:clear-system system-name)) + table))) + + (let ((existing (check-for-existing-searcher + asdf:*system-definition-search-functions*))) + (let* ((local (make-local-projects-table)) + (bundled-local-projects + (make-bundled-local-projects-systems-table)) + (bundled (make-bundled-systems-table)) + (new-tables (remove nil (list local + bundled-local-projects + bundled))) + (existing-tables (get searcher-name indicator)) + (filter (=matching-data-sources new-tables))) + (setf (get searcher-name indicator) + (append new-tables (delete-if filter existing-tables))) + (map nil #'clear-asdf new-tables)) + (unless existing + (setf (symbol-function searcher-name) #'search-function) + (push searcher-name asdf:*system-definition-search-functions*))) + t)) diff --git a/sbcl/.quicklisp/quicklisp/bundle.lisp b/sbcl/.quicklisp/quicklisp/bundle.lisp new file mode 100644 index 0000000..bff9086 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/bundle.lisp @@ -0,0 +1,362 @@ +;;;; bundle.lisp + +(in-package #:ql-bundle) + +;;; Bundling is taking a set of Quicklisp-provided systems and +;;; creating a directory structure and metadata in which those systems +;;; can be loaded without involving Quicklisp. +;;; +;;; This works for systems provided directly Quicklisp, or systems in +;;; the Quicklisp local-projects directories (if +;;; :include-local-projects is specified). + +(defgeneric find-system (system bundle)) +(defgeneric add-system (system bundle)) +(defgeneric ensure-system (system bundle)) + +(defgeneric find-release (relase bundle)) +(defgeneric add-release (release bundle)) +(defgeneric ensure-release (release bundle)) + +(defgeneric write-loader-script (bundle stream)) +(defgeneric write-system-index (bundle stream)) + +(defgeneric unpack-release (release target)) +(defgeneric unpack-releases (bundle target)) + +(defgeneric write-bundle (bundle target)) + +(defvar *ignored-systems* + (list "asdf") + "Systems that might appear in depends-on lists in Quicklisp, but + which can't be bundled.") + +(defvar *bundle-progress-output* + (make-synonym-stream '*trace-output*) + "Informative output related to creating the bundle is sent to this + stream.") + +;;; Implementation + +;;; Conditions + +(define-condition bundle-error (error) ()) + +(define-condition object-not-found (bundle-error) + ((name + :initarg :name + :reader object-not-found-name) + (type + :initarg :type + :reader object-not-found-type)) + (:report + (lambda (condition stream) + (format stream "~A ~S not found" + (object-not-found-type condition) + (object-not-found-name condition)))) + (:default-initargs + :type "Object")) + +(define-condition system-not-found (object-not-found) + ((name + :reader system-not-found-system)) + (:default-initargs + :type "System")) + +(define-condition release-not-found (object-not-found) + () + (:default-initargs + :type "Release")) + +(define-condition bundle-directory-exists (bundle-error) + ((directory + :initarg :directory + :reader bundle-directory-exists-directory)) + (:report + (lambda (condition stream) + (format stream "Bundle directory ~A already exists" + (bundle-directory-exists-directory condition))))) + + +(defun iso8601-time-stamp (&optional (time (get-universal-time))) + (multiple-value-bind (second minute hour day month year) + (decode-universal-time time 0) + (format nil "~4,'0D-~2,'0D-~2,'0DT~ + ~2,'0D:~2,'0D:~2,'0DZ" + year month day + hour minute second))) + + +(defclass bundle () + ((requested-systems + :initarg :requested-systems + :reader requested-systems + :documentation "Names of the systems requested directly for + bundling.") + (creation-time + :initarg :creation-time + :reader creation-time) + (release-table + :initarg :release-table + :reader release-table) + (system-table + :initarg :system-table + :reader system-table)) + (:default-initargs + :requested-systems nil + :creation-time (iso8601-time-stamp) + :release-table (make-hash-table :test 'equalp) + :system-table (make-hash-table :test 'equalp))) + +(defmethod print-object ((bundle bundle) stream) + (print-unreadable-object (bundle stream :type t) + (format stream "~D release~:P, ~D system~:P" + (hash-table-count (release-table bundle)) + (hash-table-count (system-table bundle))))) + +(defmethod provided-releases ((bundle bundle)) + (let ((releases '())) + (maphash (lambda (name release) + (declare (ignore name)) + (push release releases)) + (release-table bundle)) + (sort releases 'string< :key 'name))) + +(defmethod provided-systems ((bundle bundle)) + (sort (mapcan #'provided-systems (provided-releases bundle)) + 'string< + :key 'name)) + +(defmethod find-system (name (bundle bundle)) + (values (gethash name (system-table bundle)))) + +(defmethod add-system (name (bundle bundle)) + (let ((system (ql-dist:find-system name))) + (unless system + (error 'system-not-found + :name name)) + (ensure-release (name (release system)) bundle) + system)) + +(defmethod ensure-system (name (bundle bundle)) + (or (find-system name bundle) + (add-system name bundle))) + +(defmethod find-release (name (bundle bundle)) + (values (gethash name (release-table bundle)))) + +(defmethod add-release (name (bundle bundle)) + (let ((release (ql-dist:find-release name))) + (unless release + (error 'release-not-found + :name name)) + (setf (gethash (name release) (release-table bundle)) release) + (let ((system-table (system-table bundle))) + (dolist (system (provided-systems release)) + (setf (gethash (name system) system-table) system))) + release)) + +(defmethod ensure-release (name (bundle bundle)) + (or (find-release name bundle) + (add-release name bundle))) + + +(defun add-systems-recursively (names bundle) + (with-consistent-dists + (labels ((add-one (name) + (unless (member name *ignored-systems* :test 'equalp) + (let ((system + (restart-case + (ensure-system name bundle) + (omit () + :report "Ignore this system and omit it from the bundle.")))) + (when system + (dolist (required-system-name (required-systems system)) + (add-one required-system-name))))))) + (map nil #'add-one names))) + bundle) + + +(defmethod unpack-release (release target) + (let ((*default-pathname-defaults* (truename + (ensure-directories-exist target))) + (archive (ensure-local-archive-file release)) + (temp-tar (ensure-directories-exist + (ql-setup:qmerge "tmp/bundle.tar")))) + (ql-gunzipper:gunzip archive temp-tar) + (ql-minitar:unpack-tarball temp-tar :directory "software/") + (delete-file temp-tar) + release)) + +(defmethod unpack-releases ((bundle bundle) target) + (dolist (release (provided-releases bundle)) + (unpack-release release target)) + bundle) + +(defmethod write-system-index ((bundle bundle) stream) + (dolist (release (provided-releases bundle)) + ;; Working with strings, here, intentionally not with pathnames + (let ((prefix (concatenate 'string "software/" (prefix release)))) + (dolist (system-file (system-files release)) + (format stream "~A/~A~%" prefix system-file))))) + +(defmethod write-loader-script ((bundle bundle) stream) + (let ((template-lines + (load-time-value + (with-open-file (stream #. (merge-pathnames "bundle-template" + (or *compile-file-truename* + *load-truename*))) + (loop for line = (read-line stream nil) + while line collect line))))) + (dolist (line template-lines) + (write-line line stream)))) + +(defun coerce-to-directory (pathname) + ;; Cribbed from quicklisp-bootstrap/quicklisp.lisp + (let ((name (file-namestring pathname))) + (if (or (null name) + (equal name "")) + pathname + (make-pathname :defaults pathname + :name nil + :type nil + :directory (append (pathname-directory pathname) + (list name)))))) + +(defun bundle-metadata-plist (bundle) + (list :creation-time (creation-time bundle) + :requested-systems (requested-systems bundle) + :lisp-info (list :machine-instance (machine-instance) + :machine-type (machine-type) + :machine-version (machine-version) + :lisp-implementation-type (lisp-implementation-type) + :lisp-implementation-version (lisp-implementation-version)) + :quicklisp-info (list :home (namestring ql:*quicklisp-home*) + :local-project-directories + (mapcar 'namestring ql:*local-project-directories*) + :dists + (loop for dist in (enabled-dists) + collect (list :name (name dist) + :dist-url + (canonical-distinfo-url dist) + :version (version dist)))))) + +(defmethod write-bundle ((bundle bundle) target) + (unpack-releases bundle target) + (let ((index-file (merge-pathnames "system-index.txt" target)) + (loader-file (merge-pathnames "bundle.lisp" target)) + (local-projects (merge-pathnames "local-projects/" target)) + (metadata-file (merge-pathnames "bundle-info.sexp" target))) + (ensure-directories-exist local-projects) + (with-open-file (stream index-file :direction :output + :if-exists :supersede) + (write-system-index bundle stream)) + (with-open-file (stream loader-file :direction :output + :if-exists :supersede) + (write-loader-script bundle stream)) + (with-open-file (stream metadata-file :direction :output + :if-exists :supersede) + (with-standard-io-syntax + (let ((*print-pretty* t)) + (prin1 (bundle-metadata-plist bundle) stream) + (terpri stream)))) + (probe-file loader-file))) + + +(defun copy-file (from-file to-file) + (with-open-file (from-stream from-file :element-type '(unsigned-byte 8) + :if-does-not-exist nil) + (when from-stream + (let ((buffer (make-array 10000 :element-type '(unsigned-byte 8)))) + (with-open-file (to-stream to-file + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (loop + (let ((end-index (read-sequence buffer from-stream))) + (when (zerop end-index) + (return to-file)) + (write-sequence buffer to-stream :end end-index)))))))) + +(defun copy-directory-tree (from-directory to-directory) + ;; Use the truename here to ensure that relative pathnames match up + ;; properly. For example, on SBCL, "~/foo/bar/" entries are not + ;; relative to "/home/baz/foo/bar/" entries. + (setf from-directory (truename from-directory)) + (map-directory-tree + from-directory + (lambda (from-pathname) + (when (probe-file from-pathname) + (let* ((relative (enough-namestring from-pathname from-directory)) + (relative-directory (pathname-directory relative)) + (to-pathname (merge-pathnames relative to-directory))) + (unless (or (null relative-directory) + (eql (first relative-directory) + :relative)) + (error "Expected relative pathname to copy from ~A ~ + - bad symlink? - ~S" + from-pathname + relative)) + (ensure-directories-exist to-pathname) + (copy-file from-pathname to-pathname)))))) + +(defun copy-local-projects-directories (local-projects-directories + to-directory) + "Copy the local-projects directories to TO-DIRECTORY. Each one gets + a distinct subdirectory." + (loop for prefix from 0 + for prefix-directory = (make-pathname :directory + (list :relative + (format nil "~4,'0X" prefix))) + for from-directory in local-projects-directories + for real-to-directory = (merge-pathnames prefix-directory to-directory) + do + (format *bundle-progress-output* + "~&; Copying ~A to bundle..." from-directory ) + (force-output *bundle-progress-output*) + (ensure-directories-exist real-to-directory) + (copy-directory-tree from-directory real-to-directory) + (format *bundle-progress-output* "done.~%") + (force-output *bundle-progress-output*))) + + +(defun ql:bundle-systems (system-names + &key include-local-projects to (overwrite t)) + "In the directory TO, construct a self-contained bundle of libraries +based on SYSTEM-NAMES. For each system named, and its recursive +required systems, unpack its release archive in TO/software/, and +write a system index, compatible with the output of +QL:WRITE-ASDF-MANIFEST-FILE, to TO/system-index.txt. Write a loader +script to TO/bundle.lisp that, when loaded via CL:LOAD, configures +ASDF to load systems from the bundle before any other system. + +SYSTEM-NAMES must name systems provided directly by Quicklisp. + +If INCLUDE-LOCAL-PROJECTS is true, each directory in +QL:*LOCAL-PROJECT-DIRECTORIES* is copied into the bundle and loaded +before any of the other bundled systems." + (unless to + (error "TO argument must be provided")) + (let* ((bundle (make-instance 'bundle + :requested-systems system-names)) + (to (coerce-to-directory to)) + (software (merge-pathnames "software/" to))) + (when (and (probe-directory to) + (not overwrite)) + (cerror "Overwrite it" + 'bundle-directory-exists + :directory to)) + (when (probe-directory software) + (delete-directory-tree software)) + (add-systems-recursively system-names bundle) + (let ((bundled-local-projects (merge-pathnames "bundled-local-projects/" + to))) + (when include-local-projects + (when (probe-directory bundled-local-projects) + (delete-directory-tree bundled-local-projects)) + (copy-local-projects-directories ql:*local-project-directories* + bundled-local-projects) + (ensure-directories-exist bundled-local-projects) + (ql::make-system-index bundled-local-projects))) + (values (write-bundle bundle to) + bundle))) diff --git a/sbcl/.quicklisp/quicklisp/cdb.lisp b/sbcl/.quicklisp/quicklisp/cdb.lisp new file mode 100644 index 0000000..8228348 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/cdb.lisp @@ -0,0 +1,356 @@ +;;;; cdb.lisp + +(in-package #:ql-cdb) + +(defconstant +initial-hash-value+ 5381) + +(defun cdb-hash (octets) + "http://cr.yp.to/cdb/cdb.txt" + (declare (type (simple-array (unsigned-byte 8) (*)) octets) + (optimize speed)) + (let ((h +initial-hash-value+)) + (declare (type (unsigned-byte 32) h)) + (dotimes (i (length octets) h) + (let ((c (aref octets i))) + (setf h (logand #xFFFFFFFF (+ h (ash h 5)))) + (setf h (logxor h c)))))) + +(defun make-growable-vector (&key + (size 10) (element-type t)) + (make-array size :fill-pointer 0 :adjustable t :element-type element-type)) + +(defun make-octet-vector (size) + (make-array size :element-type '(unsigned-byte 8))) + +(defun encode-string (string) + "Do a bare-bones ASCII encoding of STRING." + (map-into (make-octet-vector (length string)) + 'char-code + string)) + +(defun decode-octets (octets) + "Do a bare-bones ASCII decoding of OCTETS." + (map-into (make-string (length octets)) + 'code-char + octets)) + +(defun read-cdb-u32 (stream) + (logand #xFFFFFFFF + (logior (ash (read-byte stream) 0) + (ash (read-byte stream) 8) + (ash (read-byte stream) 16) + (ash (read-byte stream) 24)))) + +(defun lookup-record-at (position key stream) + (file-position stream position) + (let ((key-size (read-cdb-u32 stream)) + (value-size (read-cdb-u32 stream))) + (when (= key-size (length key)) + (let ((test-key (make-octet-vector key-size))) + (when (/= key-size (read-sequence test-key stream)) + (error "Could not read record key of size ~D from cdb stream" + key-size)) + (unless (mismatch test-key key :test #'=) + (let ((value (make-octet-vector value-size))) + (if (= value-size (read-sequence value stream)) + value + (error "Could not read record value of size ~D from cdb stream" + value-size)))))))) + +(defun table-slot-lookup (key hash table-position + initial-slot slot-count stream) + (let ((slot initial-slot)) + (loop + (file-position stream (+ table-position (* slot 8))) + (let ((test-hash (read-cdb-u32 stream)) + (record-position (read-cdb-u32 stream))) + (when (zerop record-position) + (return)) + (when (= hash test-hash) + (let ((value (lookup-record-at record-position key stream))) + (when value + (return value))))) + (setf slot (mod (1+ slot) slot-count))))) + +(defun stream-lookup (key stream) + (let* ((hash (cdb-hash key)) + (pointer-index (logand #xFF hash))) + (file-position stream (* pointer-index 8)) + (let ((table-position (read-cdb-u32 stream)) + (slot-count (read-cdb-u32 stream))) + (when (plusp slot-count) + (let ((initial-slot (mod (ash hash -8) slot-count))) + (table-slot-lookup key hash + table-position initial-slot slot-count stream)))))) + +(defun %lookup (key cdb) + "Return the value for KEY in CDB, or NIL if no matching key is +found. CDB should be a pathname or an open octet stream. The key +should be a vector of octets. The returned value will be a vector of +octets." + (if (streamp cdb) + (stream-lookup key cdb) + (with-open-file (stream cdb :element-type '(unsigned-byte 8)) + (stream-lookup key stream)))) + +(defun lookup (key cdb) + "Return the value for KEY in CDB, or NIL if no matching key is +found. CDB should be a pathname or an open octet stream. The key +should be an ASCII-encodable string. The returned value will be a +string." + (let ((value (%lookup (encode-string key) cdb))) + (when value + (decode-octets value)))) + +(defun stream-map-cdb (function stream) + (labels ((map-one-slot (i) + (file-position stream (* i 8)) + (let ((table-position (read-cdb-u32 stream)) + (slot-count (read-cdb-u32 stream))) + (when (plusp slot-count) + (map-one-table table-position slot-count)))) + (map-one-table (position count) + (dotimes (i count) + (file-position stream (+ position (* i 8))) + (let ((hash (read-cdb-u32 stream)) + (position (read-cdb-u32 stream))) + (declare (ignore hash)) + (when (plusp position) + (map-record position))))) + (map-record (position) + (file-position stream position) + (let* ((key-size (read-cdb-u32 stream)) + (value-size (read-cdb-u32 stream)) + (key (make-octet-vector key-size)) + (value (make-octet-vector value-size))) + (read-sequence key stream) + (read-sequence value stream) + (funcall function key value)))) + (dotimes (i 256) + (map-one-slot i)))) + +(defun %map-cdb (function cdb) + "Call FUNCTION once with each key and value in CDB." + (if (streamp cdb) + (stream-map-cdb function cdb) + (with-open-file (stream cdb :element-type '(unsigned-byte 8)) + (stream-map-cdb function stream)))) + +(defun map-cdb (function cdb) + (%map-cdb (lambda (key value) + (funcall function + (decode-octets key) + (decode-octets value))) + cdb)) + + +;;; Writing CDB files + +(defun write-cdb-u32 (u32 stream) + "Write an (unsigned-byte 32) value to STREAM in little-endian order." + (write-byte (ldb (byte 8 0) u32) stream) + (write-byte (ldb (byte 8 8) u32) stream) + (write-byte (ldb (byte 8 16) u32) stream) + (write-byte (ldb (byte 8 24) u32) stream)) + +(defclass record-pointer () + ((hash-value + :initarg :hash-value + :accessor hash-value + :documentation "The hash value of the record key.") + (record-position + :initarg :record-position + :accessor record-position + :documentation "The file position at which the record is stored.")) + (:default-initargs + :hash-value 0 + :record-position 0) + (:documentation "Every key/value record written to a CDB has a + corresponding record pointer, which tracks the key's hash value and + the record's position in the data file. When all records have been + written to the file, these record pointers are organized into hash + tables at the end of the cdb file.")) + +(defmethod print-object ((record-pointer record-pointer) stream) + (print-unreadable-object (record-pointer stream :type t) + (format stream "~8,'0X@~:D" + (hash-value record-pointer) + (record-position record-pointer)))) + +(defvar *empty-record-pointer* (make-instance 'record-pointer)) + + +(defclass hash-table-bucket () + ((table-position + :initarg :table-position + :accessor table-position + :documentation "The file position at which this table + is (eventually) slotted.") + (entries + :initarg :entries + :accessor entries + :documentation "A vector of record-pointers.")) + (:default-initargs + :table-position 0 + :entries (make-growable-vector)) + (:documentation "During construction of the CDB, record pointers are + accumulated into one of 256 hash table buckets, depending on the low + 8 bits of the hash value of the key. At the end of record writing, + these buckets are used to write out hash table vectors at the end of + the file, and write pointers to the hash table vectors at the start + of the file.")) + +(defgeneric entry-count (object) + (:method ((object hash-table-bucket)) + (length (entries object)))) + +(defgeneric slot-count (object) + (:method ((object hash-table-bucket)) + (* (entry-count object) 2))) + +(defun bucket-hash-vector (bucket) + "Create a hash vector for a bucket. A hash vector has 2x the entries +of the bucket, and is initialized to an empty record pointer. The high +24 bits of the hash value of a record pointer, mod the size of the +vector, is used as a starting slot, and the vector is walked (wrapping +at the end) to find the first free slot for positioning each record +pointer entry." + (let* ((size (slot-count bucket)) + (vector (make-array size :initial-element nil))) + (flet ((slot (record) + (let ((index (mod (ash (hash-value record) -8) size))) + (loop + (unless (aref vector index) + (return (setf (aref vector index) record))) + (setf index (mod (1+ index) size)))))) + (map nil #'slot (entries bucket))) + (nsubstitute *empty-record-pointer* nil vector))) + +(defmethod print-object ((bucket hash-table-bucket) stream) + (print-unreadable-object (bucket stream :type t) + (format stream "~D entr~:@P" (entry-count bucket)))) + + +(defclass cdb-writer () + ((buckets + :initarg :buckets + :accessor buckets) + (end-of-records-position + :initarg :end-of-records-position + :accessor end-of-records-position) + (output + :initarg :output + :accessor output)) + (:default-initargs + :end-of-records-position 2048 + :buckets (map-into (make-array 256) + (lambda () (make-instance 'hash-table-bucket))))) + + +(defun add-record (key value cdb-writer) + "Add KEY and VALUE to a cdb file. KEY and VALUE should both +be (unsigned-byte 8) vectors." + (let* ((output (output cdb-writer)) + (hash-value (cdb-hash key)) + (bucket-index (logand #xFF hash-value)) + (bucket (aref (buckets cdb-writer) bucket-index)) + (record-position (file-position output)) + (record-pointer (make-instance 'record-pointer + :record-position record-position + :hash-value hash-value))) + (vector-push-extend record-pointer (entries bucket)) + (write-cdb-u32 (length key) output) + (write-cdb-u32 (length value) output) + (write-sequence key output) + (write-sequence value output) + (force-output output) + (incf (end-of-records-position cdb-writer) + (+ 8 (length key) (length value))))) + +(defun write-bucket-hash-table (bucket stream) + "Write BUCKET's hash table vector to STREAM." + (map nil + (lambda (pointer) + (write-cdb-u32 (hash-value pointer) stream) + (write-cdb-u32 (record-position pointer) stream)) + (bucket-hash-vector bucket))) + +(defun write-hash-tables (cdb-writer) + "Write the traililng hash tables to the end of the cdb +file. Initializes the position of the buckets in the process." + (let ((stream (output cdb-writer))) + (map nil + (lambda (bucket) + (setf (table-position bucket) (file-position stream)) + (write-bucket-hash-table bucket stream)) + (buckets cdb-writer)))) + +(defun write-pointers (cdb-writer) + "Write the leading hash table pointers to the beginning of the cdb +file. Must be called after WRITE-HASH-TABLES, or the positions won't +be available." + (let ((stream (output cdb-writer))) + (file-position stream :start) + (map nil + (lambda (bucket) + (let ((position (table-position bucket)) + (count (slot-count bucket))) + (when (zerop position) + (error "Table positions not initialized correctly")) + (write-cdb-u32 position stream) + (write-cdb-u32 count stream))) + (buckets cdb-writer)))) + +(defun finish-cdb-writer (cdb-writer) + "Write the trailing hash tables and leading table pointers to the +cdb file." + (write-hash-tables cdb-writer) + (write-pointers cdb-writer) + (force-output (output cdb-writer))) + + +(defvar *pointer-padding* (make-array 2048 :element-type '( unsigned-byte 8))) + +(defun call-with-output-to-cdb (cdb-pathname temp-pathname fun) + "Call FUN with one argument, a CDB-WRITER instance to which records +can be added with ADD-RECORD." + (with-open-file (stream temp-pathname + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (let ((cdb (make-instance 'cdb-writer :output stream))) + (write-sequence *pointer-padding* stream) + (funcall fun cdb) + (finish-cdb-writer cdb))) + (values (rename-file temp-pathname cdb-pathname))) + +(defmacro with-output-to-cdb ((cdb file temp-file) &body body) + "Evaluate BODY with CDB bound to a CDB-WRITER object. The CDB in +progress is written to TEMP-FILE, and then when the CDB is +successfully written, TEMP-FILE is renamed to FILE. For atomic +operation, FILE and TEMP-FILE must be on the same filesystem." + `(call-with-output-to-cdb ,file ,temp-file + (lambda (,cdb) + ,@body))) + + +;;; Index file (systems.txt, releases.txt) conversion + +(defun convert-index-file (index-file + &key (cdb-file (make-pathname :type "cdb" + :defaults index-file)) + (index 0)) + (with-open-file (stream index-file) + (let ((header (read-line stream))) + (unless (and (plusp (length header)) + (char= (char header 0) #\#)) + (error "Bad header line in ~A -- ~S" + index-file header))) + (with-output-to-cdb (cdb cdb-file (make-pathname :type "cdb-tmp" + :defaults cdb-file)) + (loop for line = (read-line stream nil) + for words = (and line (ql-util:split-spaces line)) + while line do + (add-record (encode-string (elt words index)) + (encode-string line) + cdb))))) diff --git a/sbcl/.quicklisp/quicklisp/client-info.lisp b/sbcl/.quicklisp/quicklisp/client-info.lisp new file mode 100644 index 0000000..5cc972e --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/client-info.lisp @@ -0,0 +1,262 @@ +;;;; client-info.lisp + +(in-package #:quicklisp-client) + +(defparameter *client-base-url* "http://beta.quicklisp.org/") + +(defgeneric info-equal (info1 info2) + (:documentation "Return TRUE if INFO1 and INFO2 are 'equal' in some + important sense.")) + +;;; Information for checking the validity of files fetched for +;;; installing/updating the client code. + +(defclass client-file-info () + ((plist-key + :initarg :plist-key + :reader plist-key) + (file-url + :initarg :url + :reader file-url) + (name + :reader name + :initarg :name) + (size + :initarg :size + :reader size) + (md5 + :reader md5 + :initarg :md5) + (sha256 + :reader sha256 + :initarg :sha256) + (plist + :reader plist + :initarg :plist))) + +(defmethod print-object ((info client-file-info) stream) + (print-unreadable-object (info stream :type t) + (format stream "~S ~D ~S" + (name info) + (size info) + (md5 info)))) + +(defmethod info-equal ((info1 client-file-info) (info2 client-file-info)) + (and (eql (size info1) (size info2)) + (equal (name info1) (name info2)) + (equal (md5 info1) (md5 info2)))) + +(defclass asdf-file-info (client-file-info) + () + (:default-initargs + :plist-key :asdf + :name "asdf.lisp")) + +(defclass setup-file-info (client-file-info) + () + (:default-initargs + :plist-key :setup + :name "setup.lisp")) + +(defclass client-tar-file-info (client-file-info) + () + (:default-initargs + :plist-key :client-tar + :name "quicklisp.tar")) + +(define-condition invalid-client-file (error) + ((file + :initarg :file + :reader invalid-client-file-file))) + +(define-condition badly-sized-client-file (invalid-client-file) + ((expected-size + :initarg :expected-size + :reader badly-sized-client-file-expected-size) + (actual-size + :initarg :actual-size + :reader badly-sized-client-file-actual-size)) + (:report (lambda (condition stream) + (format stream "Unexpected file size for ~A ~ + - expected ~A but got ~A" + (invalid-client-file-file condition) + (badly-sized-client-file-expected-size condition) + (badly-sized-client-file-actual-size condition))))) + +(defun check-client-file-size (file expected-size) + (let ((actual-size (file-size file))) + (unless (eql expected-size actual-size) + (error 'badly-sized-client-file + :file file + :expected-size expected-size + :actual-size actual-size)))) + +;;; TODO: check cryptographic digests too. + +(defgeneric check-client-file (file client-file-info) + (:documentation + "Signal an INVALID-CLIENT-FILE error if FILE does not match the + metadata in CLIENT-FILE-INFO.") + (:method (file client-file-info) + (check-client-file-size file (size client-file-info)) + client-file-info)) + +;;; Structuring and loading information about the Quicklisp client +;;; code + +(defclass client-info () + ((setup-info + :reader setup-info + :initarg :setup-info) + (asdf-info + :reader asdf-info + :initarg :asdf-info) + (client-tar-info + :reader client-tar-info + :initarg :client-tar-info) + (canonical-client-info-url + :reader canonical-client-info-url + :initarg :canonical-client-info-url) + (version + :reader version + :initarg :version) + (subscription-url + :reader subscription-url + :initarg :subscription-url) + (plist + :reader plist + :initarg :plist) + (source-file + :reader source-file + :initarg :source-file))) + +(defmethod print-object ((client-info client-info) stream) + (print-unreadable-object (client-info stream :type t) + (prin1 (version client-info) stream))) + +(defmethod available-versions-url ((info client-info)) + (make-versions-url (subscription-url info))) + +(defgeneric extract-client-file-info (file-info-class plist) + (:method (file-info-class plist) + (let* ((instance (make-instance file-info-class)) + (key (plist-key instance)) + (file-info-plist (getf plist key))) + (unless file-info-plist + (error "Missing client-info data for ~S" key)) + (destructuring-bind (&key url size md5 sha256 &allow-other-keys) + file-info-plist + (unless (and url size md5 sha256) + (error "Missing client-info data for ~S" key)) + (reinitialize-instance instance + :plist file-info-plist + :url url + :size size + :md5 md5 + :sha256 sha256))))) + +(defun format-client-url (path &rest format-arguments) + (if format-arguments + (format nil "~A~{~}" *client-base-url* path format-arguments) + (format nil "~A~A" *client-base-url* path))) + +(defun client-info-url-from-version (version) + (format-client-url "client/~A/client-info.sexp" version)) + +(define-condition invalid-client-info (error) + ((plist + :initarg plist + :reader invalid-client-info-plist))) + +(defun load-client-info (file) + (let ((plist (safely-read-file file))) + (destructuring-bind (&key subscription-url + version + canonical-client-info-url + &allow-other-keys) + plist + (make-instance 'client-info + :setup-info (extract-client-file-info 'setup-file-info + plist) + :asdf-info (extract-client-file-info 'asdf-file-info + plist) + :client-tar-info + (extract-client-file-info 'client-tar-file-info + plist) + :canonical-client-info-url canonical-client-info-url + :version version + :subscription-url subscription-url + :plist plist + :source-file (probe-file file))))) + +(defun mock-client-info () + (flet ((mock-client-file-info (class) + (make-instance class + :size 0 + :url "" + :md5 "" + :sha256 "" + :plist nil))) + (make-instance 'client-info + :version ql-info:*version* + :subscription-url + (format-client-url "client/quicklisp.sexp") + :setup-info (mock-client-file-info 'setup-file-info) + :asdf-info (mock-client-file-info 'asdf-file-info) + :client-tar-info (mock-client-file-info + 'client-tar-file-info)))) + +(defun fetch-client-info (url) + (let ((info-file (qmerge "tmp/client-info.sexp"))) + (delete-file-if-exists info-file) + (fetch url info-file :quietly t) + (handler-case + (load-client-info info-file) + ;; FIXME: So many other things could go wrong here; I think it + ;; would be nice to catch and report them clearly as bogus URLs + (invalid-client-info () + (error "Invalid client info URL -- ~A" url))))) + +(defun local-client-info () + (let ((info-file (qmerge "client-info.sexp"))) + (if (probe-file info-file) + (load-client-info info-file) + (progn + (warn "Missing client-info.sexp, using mock info") + (mock-client-info))))) + +(defun newest-client-info (&optional (info (local-client-info))) + (let ((latest (subscription-url info))) + (when latest + (fetch-client-info latest)))) + +(defun client-version-lessp (client-info-1 client-info-2) + (string-lessp (version client-info-1) + (version client-info-2))) + +(defun client-version () + "Return the version for the current local client installation. May +or may not be suitable for passing as the :VERSION argument to +INSTALL-CLIENT, depending on if it's a standard Quicklisp-provided +client." + (version (local-client-info))) + +(defun client-url () + "Return an URL suitable for passing as the :URL argument to +INSTALL-CLIENT for the current local client installation." + (canonical-client-info-url (local-client-info))) + +(defun available-client-versions () + (let ((url (available-versions-url (local-client-info))) + (temp-file (qmerge "tmp/client-versions.sexp"))) + (when url + (handler-case + (progn + (maybe-fetch-gzipped url temp-file) + (prog1 + (with-open-file (stream temp-file) + (safely-read stream)) + (delete-file-if-exists temp-file))) + (unexpected-http-status (condition) + (unless (url-not-suitable-error-p condition) + (error condition))))))) diff --git a/sbcl/.quicklisp/quicklisp/client-update.lisp b/sbcl/.quicklisp/quicklisp/client-update.lisp new file mode 100644 index 0000000..1388c2e --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/client-update.lisp @@ -0,0 +1,106 @@ +;;;; client-update.lisp + +(in-package #:quicklisp-client) + +(defun fetch-client-file-info (client-file-info output-file) + (maybe-fetch-gzipped (file-url client-file-info) output-file) + (check-client-file output-file client-file-info) + (probe-file output-file)) + +(defun retirement-directory (base) + (let ((suffix 0)) + (loop + (incf suffix) + (let* ((try (format nil "~A-~D" base suffix)) + (dir (qmerge (make-pathname :directory + (list :relative "retired" try))))) + (unless (probe-directory dir) + (return dir)))))) + +(defun retire (directory base) + (let ((retirement-home (qmerge "retired/")) + (from (truename directory))) + (ensure-directories-exist retirement-home) + (let* ((*default-pathname-defaults* retirement-home) + (to (retirement-directory base))) + (rename-directory from to) + to))) + +(defun client-update-scratch-directory (client-info) + (qmerge (make-pathname :directory + (list :relative + "tmp" + "client-update" + (version client-info))))) + +(defun %install-client (new-info local-info) + (let* ((work-directory (client-update-scratch-directory new-info)) + (current-quicklisp-directory (qmerge "quicklisp/")) + (new-quicklisp-directory + (merge-pathnames "quicklisp/" work-directory)) + (local-temp-tar (merge-pathnames "quicklisp.tar" work-directory)) + (local-setup (merge-pathnames "setup.lisp" work-directory)) + (local-asdf (merge-pathnames "asdf.lisp" work-directory)) + (new-client-tar-p (not (info-equal (client-tar-info new-info) + (client-tar-info local-info)))) + (new-setup-p (not (info-equal (setup-info new-info) + (setup-info local-info)))) + (new-asdf-p (not (info-equal (asdf-info new-info) + (asdf-info local-info))))) + (ensure-directories-exist work-directory) + ;; Fetch and unpack quicklisp.tar if needed + (when new-client-tar-p + (fetch-client-file-info (client-tar-info new-info) local-temp-tar) + (unpack-tarball local-temp-tar :directory work-directory)) + ;; Fetch setup.lisp if needed + (when new-setup-p + (fetch-client-file-info (setup-info new-info) local-setup)) + ;; Fetch asdf.lisp if needed + (when new-asdf-p + (fetch-client-file-info (asdf-info new-info) local-asdf)) + ;; Everything fetched, so move the old stuff away and move the new + ;; stuff in + (when new-client-tar-p + (retire (qmerge "quicklisp/") + (format nil "quicklisp-~A" + (version local-info))) + (rename-directory new-quicklisp-directory current-quicklisp-directory)) + (when new-setup-p + (replace-file local-setup (qmerge "setup.lisp"))) + (when new-asdf-p + (replace-file local-asdf (qmerge "asdf.lisp"))) + ;; But unconditionally move the new client-info into place + (replace-file (source-file new-info) (qmerge "client-info.sexp")) + new-info)) + +(defun update-client (&key (prompt t)) + (let* ((local-info (local-client-info)) + (newest-info (newest-client-info local-info))) + (cond ((null newest-info) + (format t "No client update available.~%")) + ((client-version-lessp local-info newest-info) + (format t "Updating client from version ~A to version ~A.~%" + (version local-info) + (version newest-info)) + (when (or (not prompt) + (press-enter-to-continue)) + (%install-client newest-info local-info) + (format t "~&New Quicklisp client installed. ~ + It will take effect on restart.~%"))) + (t + (format t "The most up-to-date client, version ~A, ~ + is already installed.~%" + (version local-info))))) + t) + + +(defun install-client (&key url version) + (unless (or url version) + (error "One of ~S or ~S is required" :url :version)) + (when (and url version) + (error "Only one of ~S or ~S is allowed" :url :version)) + (when version + (setf url (client-info-url-from-version version))) + (let ((local-info (local-client-info)) + (new-info (fetch-client-info url))) + (%install-client new-info local-info))) diff --git a/sbcl/.quicklisp/quicklisp/client.lisp b/sbcl/.quicklisp/quicklisp/client.lisp new file mode 100644 index 0000000..9c25a3a --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/client.lisp @@ -0,0 +1,131 @@ +;;;; client.lisp + +(in-package #:quicklisp-client) + +(defvar *quickload-verbose* nil + "When NIL, show terse output when quickloading a system. Otherwise, + show normal compile and load output.") + +(defvar *quickload-prompt* nil + "When NIL, quickload systems without prompting for enter to + continue, otherwise proceed directly without user intervention.") + +(defvar *quickload-explain* t) + +(define-condition system-not-quickloadable (error) + ((system + :initarg :system + :reader not-quickloadable-system))) + +(defun maybe-silence (silent stream) + (or (and silent (make-broadcast-stream)) stream)) + +(defgeneric quickload (systems &key verbose silent prompt explain &allow-other-keys) + (:documentation + "Load SYSTEMS the quicklisp way. SYSTEMS is a designator for a list + of things to be loaded.") + (:method (systems &key + (prompt *quickload-prompt*) + (silent nil) + (verbose *quickload-verbose*) &allow-other-keys) + (let ((*standard-output* (maybe-silence silent *standard-output*)) + (*trace-output* (maybe-silence silent *trace-output*))) + (unless (listp systems) + (setf systems (list systems))) + (dolist (thing systems systems) + (flet ((ql () + (autoload-system-and-dependencies thing :prompt prompt))) + (if verbose + (ql) + (call-with-quiet-compilation #'ql))))))) + +(defmethod quickload :around (systems &key verbose prompt explain + &allow-other-keys) + (declare (ignorable systems verbose prompt explain)) + (with-consistent-dists + (call-next-method))) + +(defun system-list () + (provided-systems t)) + +(defun update-dist (dist &key (prompt t)) + (when (stringp dist) + (setf dist (find-dist dist))) + (let ((new (available-update dist))) + (cond (new + (show-update-report dist new) + (when (or (not prompt) (press-enter-to-continue)) + (update-in-place dist new))) + ((not (subscribedp dist)) + (format t "~&You are not subscribed to ~S." + (name dist))) + (t + (format t "~&You already have the latest version of ~S: ~A.~%" + (name dist) + (version dist)))))) + +(defun update-all-dists (&key (prompt t)) + (let ((dists (remove-if-not 'subscribedp (all-dists)))) + (format t "~&~D dist~:P to check.~%" (length dists)) + (dolist (old dists) + (with-simple-restart (skip "Skip update of dist ~S" (name old)) + (update-dist old :prompt prompt))))) + +(defun available-dist-versions (name) + (available-versions (find-dist-or-lose name))) + +(defun help () + "For help with Quicklisp, see http://www.quicklisp.org/beta/") + +(defun uninstall (system-name) + (let ((system (find-system system-name))) + (cond (system + (ql-dist:uninstall system)) + (t + (warn "Unknown system ~S" system-name) + nil)))) + +(defun uninstall-dist (name) + (let ((dist (find-dist name))) + (when dist + (ql-dist:uninstall dist)))) + +(defun write-asdf-manifest-file (output-file &key (if-exists :rename-and-delete) + exclude-local-projects) + "Write a list of system file pathnames to OUTPUT-FILE, one per line, +in order of descending QL-DIST:PREFERENCE." + (when (or (eql output-file nil) + (eql output-file t)) + (setf output-file (qmerge "manifest.txt"))) + (with-open-file (stream output-file + :direction :output + :if-exists if-exists) + (unless exclude-local-projects + (register-local-projects) + (dolist (system-file (list-local-projects)) + (let* ((enough (enough-namestring system-file output-file)) + (native (native-namestring enough))) + (write-line native stream)))) + (with-consistent-dists + (let ((systems (provided-systems t)) + (already-seen (make-hash-table :test 'equal))) + (dolist (system (sort systems #'> + :key #'preference)) + ;; FIXME: find-asdf-system-file does another find-system + ;; behind the scenes. Bogus. Should be a better way to go + ;; from system object to system file. + (let* ((system-file (find-asdf-system-file (name system))) + (enough (and system-file (enough-namestring system-file + output-file))) + (native (and enough (native-namestring enough)))) + (when (and native (not (gethash native already-seen))) + (setf (gethash native already-seen) native) + (format stream "~A~%" native))))))) + (probe-file output-file)) + +(defun where-is-system (name) + "Return the pathname to the source directory of ASDF system with the +given NAME, or NIL if no system by that name can be found known." + (let ((system (asdf:find-system name nil))) + (when system + (asdf:system-source-directory system)))) diff --git a/sbcl/.quicklisp/quicklisp/config.lisp b/sbcl/.quicklisp/quicklisp/config.lisp new file mode 100644 index 0000000..fd94790 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/config.lisp @@ -0,0 +1,40 @@ +;;;; config.lisp + +(in-package #:ql-config) + +(defun config-value-file-pathname (path) + (let ((bad-position (position #\Space path))) + (when bad-position + (error "Space not allowed at position ~D in ~S" + bad-position + path))) + (let* ((space-path (substitute #\Space #\/ path)) + (split (split-spaces space-path)) + (directory-parts (butlast split)) + (name (first (last split))) + (base (qmerge "config/"))) + (merge-pathnames + (make-pathname :name name + :type "txt" + :directory (list* :relative directory-parts)) + base))) + +(defun config-value (path) + (let ((file (config-value-file-pathname path))) + (with-open-file (stream file :if-does-not-exist nil) + (when stream + (values (read-line stream nil)))))) + +(defun (setf config-value) (new-value path) + (let ((file (config-value-file-pathname path))) + (typecase new-value + (null + (delete-file-if-exists file)) + (string + (ensure-directories-exist file) + (with-open-file (stream file :direction :output + :if-does-not-exist :create + :if-exists :rename-and-delete) + (write-line new-value stream))) + (t + (error "Bad config value ~S; must be a string or NIL" new-value))))) diff --git a/sbcl/.quicklisp/quicklisp/deflate.lisp b/sbcl/.quicklisp/quicklisp/deflate.lisp new file mode 100644 index 0000000..39129cf --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/deflate.lisp @@ -0,0 +1,785 @@ +;;;; Deflate --- RFC 1951 Deflate Decompression +;;;; +;;;; Copyright (C) 2000-2009 PMSF IT Consulting Pierre R. Mai. +;;;; +;;;; Permission is hereby granted, free of charge, to any person obtaining +;;;; a copy of this software and associated documentation files (the +;;;; "Software"), to deal in the Software without restriction, including +;;;; without limitation the rights to use, copy, modify, merge, publish, +;;;; distribute, sublicense, and/or sell copies of the Software, and to +;;;; permit persons to whom the Software is furnished to do so, subject to +;;;; the following conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;;; IN NO EVENT SHALL THE AUTHOR 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. +;;;; +;;;; Except as contained in this notice, the name of the author shall +;;;; not be used in advertising or otherwise to promote the sale, use or +;;;; other dealings in this Software without prior written authorization +;;;; from the author. +;;;; +;;;; $Id: 377d3a33e9db5a3b54c850619183ee555a41b894 $ + +(cl:in-package #:ql-gunzipper) + +;;;; %File Description: +;;;; +;;;; This file contains routines implementing the RFC 1951 Deflate +;;;; Compression and/or Decompression method, as used by e.g. gzip and +;;;; other compression and archiving tools and protocols. It also +;;;; implements handling routines for zlib-style (RFC 1950) and +;;;; gzip-style (RFC 1952) wrappers around raw Deflate streams. +;;;; +;;;; The main entry points are the functions inflate-stream, and its +;;;; cousins inflate-zlib-stream and inflate-gzip-stream, which take +;;;; an input-stream and an output-stream as their arguments, and +;;;; inflate the RFC 1951, RFC 1950 or RFC 1952-style deflate formats +;;;; from the input-stream to the output-stream. +;;;; + +;;; +;;; Conditions +;;; + +(define-condition decompression-error (simple-error) + ()) + +(define-condition deflate-decompression-error (decompression-error) + () + (:report + (lambda (c s) + (with-standard-io-syntax + (let ((*print-readably* nil)) + (format s + "Error detected during deflate decompression: ~?" + (simple-condition-format-control c) + (simple-condition-format-arguments c))))))) + +(define-condition zlib-decompression-error (decompression-error) + () + (:report + (lambda (c s) + (with-standard-io-syntax + (let ((*print-readably* nil)) + (format s + "Error detected during zlib decompression: ~?" + (simple-condition-format-control c) + (simple-condition-format-arguments c))))))) + +(define-condition gzip-decompression-error (decompression-error) + () + (:report + (lambda (c s) + (with-standard-io-syntax + (let ((*print-readably* nil)) + (format s + "Error detected during zlib decompression: ~?" + (simple-condition-format-control c) + (simple-condition-format-arguments c))))))) + +;;; +;;; Adler-32 Checksums +;;; + +(defconstant +adler-32-start-value+ 1 + "Start value for Adler-32 checksums as per RFC 1950.") + +(defconstant +adler-32-base+ 65521 + "Base value for Adler-32 checksums as per RFC 1950.") + +(declaim (ftype + (function ((unsigned-byte 32) (simple-array (unsigned-byte 8) (*)) fixnum) + (unsigned-byte 32)) + update-adler32-checksum)) +(defun update-adler32-checksum (crc buffer end) + (declare (type (unsigned-byte 32) crc) + (type (simple-array (unsigned-byte 8) (*)) buffer) + (type fixnum end) + (optimize (speed 3) (debug 0) (space 0) (safety 0)) + #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) + (let ((s1 (ldb (byte 16 0) crc)) + (s2 (ldb (byte 16 16) crc))) + (declare (type (unsigned-byte 32) s1 s2)) + (dotimes (i end) + (declare (type fixnum i)) + (setq s1 (mod (+ s1 (aref buffer i)) +adler-32-base+) + s2 (mod (+ s2 s1) +adler-32-base+))) + (dpb s2 (byte 16 16) s1))) + +;;; +;;; CRC-32 Checksums +;;; + +(defconstant +crc-32-start-value+ 0 + "Start value for CRC-32 checksums as per RFC 1952.") + +(defconstant +crc-32-polynomial+ #xedb88320 + "CRC-32 Polynomial as per RFC 1952.") + +(declaim (ftype #-lispworks (function () (simple-array (unsigned-byte 32) (256))) + #+lispworks (function () (sys:simple-int32-vector 256)) + generate-crc32-table)) +(defun generate-crc32-table () + (let ((result #-lispworks (make-array 256 :element-type '(unsigned-byte 32)) + #+lispworks (sys:make-simple-int32-vector 256))) + (dotimes (i #-lispworks (length result) #+lispworks 256 result) + (let ((cur i)) + (dotimes (k 8) + (setq cur (if (= 1 (logand cur 1)) + (logxor (ash cur -1) +crc-32-polynomial+) + (ash cur -1)))) + #-lispworks (setf (aref result i) cur) + #+lispworks (setf (sys:int32-aref result i) + (sys:integer-to-int32 + (dpb (ldb (byte 32 0) cur) (byte 32 0) + (if (logbitp 31 cur) -1 0)))))))) + +(declaim (ftype + (function ((unsigned-byte 32) (simple-array (unsigned-byte 8) (*)) fixnum) + (unsigned-byte 32)) + update-crc32-checksum)) +#-lispworks +(defun update-crc32-checksum (crc buffer end) + (declare (type (unsigned-byte 32) crc) + (type (simple-array (unsigned-byte 8) (*)) buffer) + (type fixnum end) + (optimize (speed 3) (debug 0) (space 0) (safety 0)) + #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) + (let ((table (load-time-value (generate-crc32-table))) + (cur (logxor crc #xffffffff))) + (declare (type (simple-array (unsigned-byte 32) (256)) table) + (type (unsigned-byte 32) cur)) + (dotimes (i end) + (declare (type fixnum i)) + (let ((index (logand #xff (logxor cur (aref buffer i))))) + (declare (type (unsigned-byte 8) index)) + (setq cur (logxor (aref table index) (ash cur -8))))) + (logxor cur #xffffffff))) + +#+lispworks +(defun update-crc32-checksum (crc buffer end) + (declare (type (unsigned-byte 32) crc) + (type (simple-array (unsigned-byte 8) (*)) buffer) + (type fixnum end) + (optimize (speed 3) (debug 0) (space 0) (safety 0) (float 0))) + (let ((table (load-time-value (generate-crc32-table))) + (cur (sys:int32-lognot (sys:integer-to-int32 + (dpb (ldb (byte 32 0) crc) (byte 32 0) + (if (logbitp 31 crc) -1 0)))))) + (declare (type (sys:simple-int32-vector 256) table) + (type sys:int32 cur)) + (dotimes (i end) + (declare (type fixnum i)) + (let ((index (sys:int32-to-integer + (sys:int32-logand #xff (sys:int32-logxor cur (aref buffer i)))))) + (declare (type fixnum index)) + (setq cur (sys:int32-logxor (sys:int32-aref table index) + (sys:int32-logand #x00ffffff + (sys:int32>> cur 8)))))) + (ldb (byte 32 0) (sys:int32-to-integer (sys:int32-lognot cur))))) + +;;; +;;; Helper Data Structures: Sliding Window Stream +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +sliding-window-size+ 32768 + "Size of sliding window for RFC 1951 Deflate compression scheme.")) + +(defstruct sliding-window-stream + (stream nil :type stream :read-only t) + (buffer (make-array +sliding-window-size+ :element-type '(unsigned-byte 8)) + :type (simple-array (unsigned-byte 8) (#.+sliding-window-size+)) :read-only t) + (buffer-end 0 :type fixnum) + (checksum nil :type symbol :read-only t) + (checksum-value 0 :type (unsigned-byte 32))) + +(declaim (inline sliding-window-stream-write-byte)) +(defun sliding-window-stream-write-byte (stream byte) + (declare (type sliding-window-stream stream) (type (unsigned-byte 8) byte) + #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) + "Write a single byte to the sliding-window-stream." + (let ((end (sliding-window-stream-buffer-end stream))) + (declare (type fixnum end)) + (unless (< end +sliding-window-size+) + (write-sequence (sliding-window-stream-buffer stream) + (sliding-window-stream-stream stream)) + (case (sliding-window-stream-checksum stream) + (:adler-32 (setf (sliding-window-stream-checksum-value stream) + (update-adler32-checksum + (sliding-window-stream-checksum-value stream) + (sliding-window-stream-buffer stream) + +sliding-window-size+))) + (:crc-32 (setf (sliding-window-stream-checksum-value stream) + (update-crc32-checksum + (sliding-window-stream-checksum-value stream) + (sliding-window-stream-buffer stream) + +sliding-window-size+)))) + (setq end 0)) + (setf (aref (sliding-window-stream-buffer stream) end) byte + (sliding-window-stream-buffer-end stream) (1+ end)))) + +(defun sliding-window-stream-flush (stream) + (declare (type sliding-window-stream stream)) + "Flush any remaining buffered bytes from the stream." + (let ((end (sliding-window-stream-buffer-end stream))) + (declare (type fixnum end)) + (unless (zerop end) + (case (sliding-window-stream-checksum stream) + (:adler-32 (setf (sliding-window-stream-checksum-value stream) + (update-adler32-checksum + (sliding-window-stream-checksum-value stream) + (sliding-window-stream-buffer stream) + end))) + (:crc-32 (setf (sliding-window-stream-checksum-value stream) + (update-crc32-checksum + (sliding-window-stream-checksum-value stream) + (sliding-window-stream-buffer stream) + end)))) + (write-sequence (sliding-window-stream-buffer stream) + (sliding-window-stream-stream stream) + :end end)))) + +(defun sliding-window-stream-copy-bytes (stream distance length) + (declare (type sliding-window-stream stream) (type fixnum distance length)) + "Copy a number of bytes from the current sliding window." + (let* ((end (sliding-window-stream-buffer-end stream)) + (start (mod (- end distance) +sliding-window-size+)) + (buffer (sliding-window-stream-buffer stream))) + (declare (type fixnum end start) + (type (simple-array (unsigned-byte 8) (#.+sliding-window-size+)) buffer)) + (dotimes (i length) + (sliding-window-stream-write-byte + stream + (aref buffer (mod (+ start i) +sliding-window-size+)))))) + +;;; +;;; Helper Data Structures: Bit-wise Input Stream +;;; + +(defstruct bit-stream + (stream nil :type stream :read-only t) + (next-byte 0 :type fixnum) + (bits 0 :type (unsigned-byte 29)) + (bit-count 0 :type (unsigned-byte 8))) + +(declaim (inline bit-stream-get-byte)) +(defun bit-stream-get-byte (stream) + (declare (type bit-stream stream)) + "Read another byte from the underlying stream." + (the (unsigned-byte 8) (read-byte (bit-stream-stream stream)))) + +(declaim (inline bit-stream-read-bits)) +(defun bit-stream-read-bits (stream bits) + (declare (type bit-stream stream) + ;; [quicklisp-added] + ;; FIXME: This might be fixed soon in ECL. + ;; http://article.gmane.org/gmane.lisp.ecl.general/7659 + #-ecl + (type (unsigned-byte 8) bits)) + "Read single or multiple bits from the given bit-stream." + (loop while (< (bit-stream-bit-count stream) bits) + do + ;; Fill bits + (setf (bit-stream-bits stream) + (logior (bit-stream-bits stream) + (the (unsigned-byte 29) + (ash (bit-stream-get-byte stream) + (bit-stream-bit-count stream)))) + (bit-stream-bit-count stream) (+ (bit-stream-bit-count stream) 8))) + ;; Return properly masked bits + (if (= (bit-stream-bit-count stream) bits) + (prog1 (bit-stream-bits stream) + (setf (bit-stream-bits stream) 0 + (bit-stream-bit-count stream) 0)) + (prog1 (ldb (byte bits 0) (bit-stream-bits stream)) + (setf (bit-stream-bits stream) (ash (bit-stream-bits stream) (- bits)) + (bit-stream-bit-count stream) (- (bit-stream-bit-count stream) bits))))) + +(declaim (inline bit-stream-copy-block)) +(defun bit-stream-copy-block (stream out-stream) + (declare (type bit-stream stream) (type sliding-window-stream out-stream) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + "Copy a given block of bytes directly from the underlying stream." + ;; Skip any remaining unprocessed bits + (setf (bit-stream-bits stream) 0 + (bit-stream-bit-count stream) 0) + ;; Get LEN/NLEN and copy bytes + (let* ((len (logior (bit-stream-get-byte stream) + (ash (bit-stream-get-byte stream) 8))) + (nlen (ldb (byte 16 0) + (lognot (logior (bit-stream-get-byte stream) + (ash (bit-stream-get-byte stream) 8)))))) + (unless (= len nlen) + (error 'deflate-decompression-error + :format-control + "Block length mismatch for stored block: LEN(~D) vs. NLEN(~D)!" + :format-arguments (list len nlen))) + (dotimes (i len) + (sliding-window-stream-write-byte out-stream (bit-stream-get-byte stream))))) + +;;; +;;; Huffman Coding +;;; + +;;; A decode-tree struct contains all information necessary to decode +;;; the given canonical huffman code. Note that length-count contains +;;; the number of codes with a given length for each length, whereas +;;; the code-symbols array contains the symbols corresponding to the +;;; codes in canoical order of the codes. +;;; +;;; Decoding then uses this information and the principles underlying +;;; canonical huffman codes to determine whether the currently +;;; collected word falls between the first code and the last code for +;;; the current length, and if so, uses the offset to determine the +;;; code's symbol. Otherwise more bits are needed. + +(defstruct decode-tree + (length-count (make-array 16 :element-type 'fixnum :initial-element 0) + :type (simple-array fixnum (*)) :read-only t) + (code-symbols (make-array 16 :element-type 'fixnum :initial-element 0) + :type (simple-array fixnum (*)))) + +(defun make-huffman-decode-tree (code-lengths) + "Construct a huffman decode-tree for the canonical huffman code with +the code lengths of each symbol given in the input array." + (let* ((max-length (reduce #'max code-lengths :initial-value 0)) + (next-code (make-array (1+ max-length) :element-type 'fixnum + :initial-element 0)) + (code-symbols (make-array (length code-lengths) :element-type 'fixnum + :initial-element 0)) + (length-count (make-array (1+ max-length) :element-type 'fixnum + :initial-element 0))) + ;; Count length occurences and calculate offsets of smallest codes + (loop for index from 1 to max-length + for code = 0 then (+ code (aref length-count (1- index))) + do + (setf (aref next-code index) code) + initially + ;; Count length occurences + (loop for length across code-lengths + do + (incf (aref length-count length)) + finally + (setf (aref length-count 0) 0))) + ;; Construct code symbols mapping + (loop for length across code-lengths + for index upfrom 0 + unless (zerop length) + do + (setf (aref code-symbols (aref next-code length)) index) + (incf (aref next-code length))) + ;; Return result + (make-decode-tree :length-count length-count :code-symbols code-symbols))) + +(declaim (inline read-huffman-code)) +(defun read-huffman-code (bit-stream decode-tree) + (declare (type bit-stream bit-stream) (type decode-tree decode-tree) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + "Read the next huffman code word from the given bit-stream and +return its decoded symbol, for the huffman code given by decode-tree." + (loop with length-count of-type (simple-array fixnum (*)) + = (decode-tree-length-count decode-tree) + with code-symbols of-type (simple-array fixnum (*)) + = (decode-tree-code-symbols decode-tree) + for code of-type fixnum = (bit-stream-read-bits bit-stream 1) + then (+ (* code 2) (bit-stream-read-bits bit-stream 1)) + for index of-type fixnum = 0 then (+ index count) + for first of-type fixnum = 0 then (* (+ first count) 2) + for length of-type fixnum upfrom 1 below (length length-count) + for count = (aref length-count length) + thereis (when (< code (the fixnum (+ first count))) + (aref code-symbols (+ index (- code first)))) + finally + (error 'deflate-decompression-error + :format-control + "Corrupted Data detected during decompression: ~ + Incorrect huffman code (~X) in huffman decode!" + :format-arguments (list code)))) + +;;; +;;; Standard Huffman Tables +;;; + +(defparameter *std-lit-decode-tree* + (make-huffman-decode-tree + (concatenate 'vector + (make-sequence 'vector 144 :initial-element 8) + (make-sequence 'vector 112 :initial-element 9) + (make-sequence 'vector 24 :initial-element 7) + (make-sequence 'vector 8 :initial-element 8)))) + +(defparameter *std-dist-decode-tree* + (make-huffman-decode-tree + (make-sequence 'vector 32 :initial-element 5))) + +;;; +;;; Dynamic Huffman Table Handling +;;; + +(defparameter *code-length-entry-order* + #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) + "Order of Code Length Tree Code Lengths.") + +(defun decode-code-length-entries (bit-stream count decode-tree) + "Decode the given number of code length entries from the bit-stream +using the given decode-tree, and return a corresponding array of code +lengths for further processing." + (do ((result (make-array count :element-type 'fixnum :initial-element 0)) + (index 0)) + ((>= index count) result) + (let ((code (read-huffman-code bit-stream decode-tree))) + (ecase code + ((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) + (setf (aref result index) code) + (incf index)) + (16 + (let ((length (+ 3 (bit-stream-read-bits bit-stream 2)))) + (dotimes (i length) + (setf (aref result (+ index i)) (aref result (1- index)))) + (incf index length))) + (17 + (let ((length (+ 3 (bit-stream-read-bits bit-stream 3)))) + (dotimes (i length) + (setf (aref result (+ index i)) 0)) + (incf index length))) + (18 + (let ((length (+ 11 (bit-stream-read-bits bit-stream 7)))) + (dotimes (i length) + (setf (aref result (+ index i)) 0)) + (incf index length))))))) + +(defun decode-huffman-tables (bit-stream) + "Decode the stored huffman tables from the given bit-stream, returning +the corresponding decode-trees for literals/length and distance codes." + (let* ((hlit (bit-stream-read-bits bit-stream 5)) + (hdist (bit-stream-read-bits bit-stream 5)) + (hclen (bit-stream-read-bits bit-stream 4))) + ;; Construct Code Length Decode Tree + (let ((cl-decode-tree + (loop with code-lengths = (make-array 19 :element-type '(unsigned-byte 8) + :initial-element 0) + for index from 0 below (+ hclen 4) + for code-length = (bit-stream-read-bits bit-stream 3) + for code-index = (aref *code-length-entry-order* index) + do + (setf (aref code-lengths code-index) code-length) + finally + (return (make-huffman-decode-tree code-lengths))))) + ;; Decode Code Length Table and generate separate huffman trees + (let ((entries (decode-code-length-entries bit-stream + (+ hlit 257 hdist 1) + cl-decode-tree))) + (values + (make-huffman-decode-tree (subseq entries 0 (+ hlit 257))) + (make-huffman-decode-tree (subseq entries (+ hlit 257)))))))) + +;;; +;;; Compressed Block Handling +;;; + +(declaim (inline decode-length-entry)) +(defun decode-length-entry (symbol bit-stream) + "Decode the given length symbol into a proper length specification." + (cond + ((<= symbol 264) (- symbol 254)) + ((<= symbol 268) (+ 11 (* (- symbol 265) 2) (bit-stream-read-bits bit-stream 1))) + ((<= symbol 272) (+ 19 (* (- symbol 269) 4) (bit-stream-read-bits bit-stream 2))) + ((<= symbol 276) (+ 35 (* (- symbol 273) 8) (bit-stream-read-bits bit-stream 3))) + ((<= symbol 280) (+ 67 (* (- symbol 277) 16) (bit-stream-read-bits bit-stream 4))) + ((<= symbol 284) + (+ 131 (* (- symbol 281) 32) (bit-stream-read-bits bit-stream 5))) + ((= symbol 285) 258) + (t + (error 'deflate-decompression-error + :format-control "Strange Length Code in bitstream: ~D" + :format-arguments (list symbol))))) + +(declaim (inline decode-distance-entry)) +(defun decode-distance-entry (symbol bit-stream) + "Decode the given distance symbol into a proper distance specification." + (cond + ((<= symbol 3) (1+ symbol)) + (t + (multiple-value-bind (order offset) (truncate symbol 2) + (let* ((extra-bits (1- order)) + (factor (ash 1 extra-bits))) + (+ (1+ (ash 1 order)) + (* offset factor) + (bit-stream-read-bits bit-stream extra-bits))))))) + +(defun decode-huffman-block (bit-stream window-stream + lit-decode-tree dist-decode-tree) + "Decode the huffman code block using the huffman codes given by +lit-decode-tree and dist-decode-tree." + (do ((symbol (read-huffman-code bit-stream lit-decode-tree) + (read-huffman-code bit-stream lit-decode-tree))) + ((= symbol 256)) + (cond + ((<= symbol 255) + (sliding-window-stream-write-byte window-stream symbol)) + (t + (let ((length (decode-length-entry symbol bit-stream)) + (distance (decode-distance-entry + (read-huffman-code bit-stream dist-decode-tree) bit-stream))) + (sliding-window-stream-copy-bytes window-stream distance length)))))) + +;;; +;;; Block Handling Code +;;; + +(defun decode-block (bit-stream window-stream) + "Decompress a block read from bit-stream into window-stream." + (let* ((finalp (not (zerop (bit-stream-read-bits bit-stream 1)))) + (type (bit-stream-read-bits bit-stream 2))) + (ecase type + (#b00 (bit-stream-copy-block bit-stream window-stream)) + (#b01 + (decode-huffman-block bit-stream window-stream + *std-lit-decode-tree* + *std-dist-decode-tree*)) + (#b10 + (multiple-value-bind (lit-decode-tree dist-decode-tree) + (decode-huffman-tables bit-stream) + (decode-huffman-block bit-stream window-stream + lit-decode-tree dist-decode-tree))) + (#b11 + (error 'deflate-decompression-error + :format-control "Encountered Reserved Block Type ~D!" + :format-arguments (list type)))) + (not finalp))) + +;;; +;;; ZLIB - RFC 1950 handling +;;; + +(defun parse-zlib-header (input-stream) + "Parse a ZLIB-style header as per RFC 1950 from the input-stream and +return the compression-method, compression-level dictionary-id and flags +fields of the header as return values. Checks the header for corruption +and signals a zlib-decompression-error in case of corruption." + (let ((compression-method (read-byte input-stream)) + (flags (read-byte input-stream))) + (unless (zerop (mod (+ (* compression-method 256) flags) 31)) + (error 'zlib-decompression-error + :format-control "Corrupted Header ~2,'0X,~2,'0X!" + :format-arguments (list compression-method flags))) + (let ((dict (unless (zerop (ldb (byte 1 5) flags)) + (parse-zlib-checksum input-stream)))) + (values (ldb (byte 4 0) compression-method) + (ldb (byte 4 4) compression-method) + dict + (ldb (byte 2 6) flags))))) + +(defun parse-zlib-checksum (input-stream) + (+ (* (read-byte input-stream) 256 256 256) + (* (read-byte input-stream) 256 256) + (* (read-byte input-stream) 256) + (read-byte input-stream))) + +(defun parse-zlib-footer (input-stream) + "Parse the ZLIB-style footer as per RFC 1950 from the input-stream and +return the Adler-32 checksum contained in the footer as its return value." + (parse-zlib-checksum input-stream)) + +;;; +;;; GZIP - RFC 1952 handling +;;; + +(defconstant +gzip-header-id1+ 31 + "GZIP Header Magic Value ID1 as per RFC 1952.") + +(defconstant +gzip-header-id2+ 139 + "GZIP Header Magic Value ID2 as per RFC 1952.") + +(defun parse-gzip-header (input-stream) + "Parse a GZIP-style header as per RFC 1952 from the input-stream and +return the compression-method, text-flag, modification time, XFLAGS, +OS, FEXTRA flags, filename, comment and CRC16 fields of the header as +return values (or nil if any given field is not present). Checks the +header for magic values and correct flags settings and signals a +gzip-decompression-error in case of incorrect or unsupported magic +values or flags." + (let ((id1 (read-byte input-stream)) + (id2 (read-byte input-stream)) + (compression-method (read-byte input-stream)) + (flags (read-byte input-stream))) + (unless (and (= id1 +gzip-header-id1+) (= id2 +gzip-header-id2+)) + (error 'gzip-decompression-error + :format-control + "Header missing magic values ~2,'0X,~2,'0X (got ~2,'0X,~2,'0X instead)!" + :format-arguments (list +gzip-header-id1+ +gzip-header-id2+ id1 id2))) + (unless (= compression-method 8) + (error 'gzip-decompression-error + :format-control "Unknown compression-method in Header ~2,'0X!" + :format-arguments (list compression-method))) + (unless (zerop (ldb (byte 3 5) flags)) + (error 'gzip-decompression-error + :format-control "Unknown flags in Header ~2,'0X!" + :format-arguments (list flags))) + (values compression-method + ;; FTEXT + (= 1 (ldb (byte 1 0) flags)) + ;; MTIME + (parse-gzip-mtime input-stream) + ;; XFLAGS + (read-byte input-stream) + ;; OS + (read-byte input-stream) + ;; FEXTRA + (unless (zerop (ldb (byte 1 2) flags)) + (parse-gzip-extra input-stream)) + ;; FNAME + (unless (zerop (ldb (byte 1 3) flags)) + (parse-gzip-string input-stream)) + ;; FCOMMENT + (unless (zerop (ldb (byte 1 4) flags)) + (parse-gzip-string input-stream)) + ;; CRC16 + (unless (zerop (ldb (byte 1 1) flags)) + (+ (read-byte input-stream) + (* (read-byte input-stream 256))))))) + +(defun parse-gzip-mtime (input-stream) + (let ((time (+ (read-byte input-stream) + (* (read-byte input-stream) 256) + (* (read-byte input-stream) 256 256) + (* (read-byte input-stream) 256 256 256)))) + (if (zerop time) + nil + (+ time 2208988800)))) + +(defun parse-gzip-extra (input-stream) + (let* ((length (+ (read-byte input-stream) (* (read-byte input-stream) 256))) + (result (make-array length :element-type '(unsigned-byte 8)))) + (read-sequence result input-stream) + result)) + +(defun parse-gzip-string (input-stream) + (with-output-to-string (string) + (loop for value = (read-byte input-stream) + until (zerop value) + do (write-char (code-char value) string)))) + +(defun parse-gzip-checksum (input-stream) + (+ (read-byte input-stream) + (* (read-byte input-stream) 256) + (* (read-byte input-stream) 256 256) + (* (read-byte input-stream) 256 256 256))) + +(defun parse-gzip-footer (input-stream) + "Parse the GZIP-style footer as per RFC 1952 from the input-stream and +return the CRC-32 checksum and ISIZE fields contained in the footer as +its return values." + (values (parse-gzip-checksum input-stream) + ;; ISIZE + (+ (read-byte input-stream) + (* (read-byte input-stream) 256) + (* (read-byte input-stream) 256 256) + (* (read-byte input-stream) 256 256 256)))) + +;;; +;;; Main Entry Points +;;; + +(defun inflate-stream (input-stream output-stream &key checksum) + "Inflate the RFC 1951 data from the given input stream into the +given output stream, which are required to have an element-type +of (unsigned-byte 8). If checksum is given, it indicates the +checksumming algorithm to employ in calculating a checksum of +the expanded content, which is then returned from this function. +Valid values are :adler-32 for Adler-32 checksum (see RFC 1950), +or :crc-32 for CRC-32 as per ISO 3309 (see RFC 1952, ZIP)." + (loop with window-stream = (make-sliding-window-stream :stream output-stream + :checksum checksum + :checksum-value + (ecase checksum + ((nil) 0) + (:crc-32 +crc-32-start-value+) + (:adler-32 +adler-32-start-value+))) + with bit-stream = (make-bit-stream :stream input-stream) + while (decode-block bit-stream window-stream) + finally (sliding-window-stream-flush window-stream) + (when checksum + (return (sliding-window-stream-checksum-value window-stream))))) + +(defun inflate-zlib-stream (input-stream output-stream &key check-checksum) + "Inflate the RFC 1950 zlib data from the given input stream into +the given output stream, which are required to have an element-type +of (unsigned-byte 8). This returns the Adler-32 checksum of the +file as its first return value, with the compression level as its +second return value. Note that it is the responsibility of the +caller to check whether the expanded data matches the Adler-32 +checksum, unless the check-checksum keyword argument is set to +true, in which case the checksum is checked internally and a +zlib-decompression-error is signalled if they don't match." + (multiple-value-bind (cm cinfo dictid flevel) (parse-zlib-header input-stream) + (unless (= cm 8) + (error 'zlib-decompression-error + :format-control "Unknown compression method ~D!" + :format-arguments (list cm))) + (unless (<= cinfo 7) + (error 'zlib-decompression-error + :format-control "Unsupported sliding window size 2^~D = ~D!" + :format-arguments (list (+ 8 cinfo) (expt 2 (+ 8 cinfo))))) + (unless (null dictid) + (error 'zlib-decompression-error + :format-control "Unknown preset dictionary id ~8,'0X!" + :format-arguments (list dictid))) + (let ((checksum-new (inflate-stream input-stream output-stream + :checksum (when check-checksum :adler-32))) + (checksum-old (parse-zlib-footer input-stream))) + (when (and check-checksum (not (= checksum-old checksum-new))) + (error 'zlib-decompression-error + :format-control + "Checksum mismatch for decompressed stream: ~8,'0X != ~8,'0X!" + :format-arguments (list checksum-old checksum-new))) + (values checksum-old flevel)))) + +(defun inflate-gzip-stream (input-stream output-stream &key check-checksum) + "Inflate the RFC 1952 gzip data from the given input stream into +the given output stream, which are required to have an element-type +of (unsigned-byte 8). This returns the CRC-32 checksum of the +file as its first return value, with any filename, modification time, +and comment fields as further return values or nil if not present. +Note that it is the responsibility of the caller to check whether the +expanded data matches the CRC-32 checksum, unless the check-checksum +keyword argument is set to true, in which case the checksum is checked +internally and a gzip-decompression-error is signalled if they don't +match." + (multiple-value-bind (cm ftext mtime xfl os fextra fname fcomment) + (parse-gzip-header input-stream) + (declare (ignore ftext xfl os fextra)) + (unless (= cm 8) + (error 'gzip-decompression-error + :format-control "Unknown compression method ~D!" + :format-arguments (list cm))) + (let ((checksum-new (inflate-stream input-stream output-stream + :checksum (when check-checksum :crc-32))) + (checksum-old (parse-gzip-footer input-stream))) + ;; Handle Checksums + (when (and check-checksum (not (= checksum-old checksum-new))) + (error 'gzip-decompression-error + :format-control + "Checksum mismatch for decompressed stream: ~8,'0X != ~8,'0X!" + :format-arguments (list checksum-old checksum-new))) + (values checksum-old fname mtime fcomment)))) + + +(defun gunzip (input-file output-file) + (with-open-file (input input-file + :element-type '(unsigned-byte 8)) + (with-open-file (output output-file + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (inflate-gzip-stream input output))) + (probe-file output-file)) diff --git a/sbcl/.quicklisp/quicklisp/dist-update.lisp b/sbcl/.quicklisp/quicklisp/dist-update.lisp new file mode 100644 index 0000000..0974eb4 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/dist-update.lisp @@ -0,0 +1,164 @@ +;;;; dist-update.lisp + +(in-package #:ql-dist) + +(defgeneric available-update (dist) + (:documentation "If an update is available for DIST, return the + update as an uninstalled dist object. Otherwise, return NIL.")) + +(defgeneric update-release-differences (old-dist new-dist) + (:documentation "Compare OLD-DIST to NEW-DIST and return three lists + as multiple values: new releases \(present in NEW-DIST but not + OLD-DIST), changed releases \(present in both dists but different in + some way), and removed releases \(present in OLD-DIST but not + NEW-DIST). The list of changed releases is a list of two-element + lists, with each two-element list having first the old release + object and then the new release object.")) + +(defgeneric show-update-report (old-dist new-dist) + (:documentation "Display a description of the update from OLD-DIST + to NEW-DIST.")) + +(defgeneric update-in-place (old-dist new-dist) + (:documentation "Update OLD-DIST to NEW-DIST in place.")) + +(defmethod available-update ((dist dist)) + (let ((url (distinfo-subscription-url dist)) + (target (qmerge "tmp/distinfo-update/distinfo.txt")) + (update-directory (qmerge "tmp/distinfo-update/"))) + (when (probe-directory update-directory) + (delete-directory-tree (qmerge "tmp/distinfo-update/"))) + (when url + (ensure-directories-exist target) + (fetch url target :quietly t) + (let ((new (make-dist-from-file target))) + (setf (base-directory new) + (make-pathname :name nil + :type nil + :version nil + :defaults target)) + (when (and (string= (name dist) (name new)) + (string/= (version dist) (version new))) + new))))) + +(defmethod update-release-differences ((old-dist dist) + (new-dist dist)) + (let ((old-releases (provided-releases old-dist)) + (new-releases (provided-releases new-dist)) + (new '()) + (updated '()) + (removed '()) + (old-by-name (make-hash-table :test 'equalp))) + (dolist (release old-releases) + (setf (gethash (name release) old-by-name) + release)) + (dolist (new-release new-releases) + (let* ((name (name new-release)) + (old-release (gethash name old-by-name))) + (remhash name old-by-name) + (cond ((not old-release) + (push new-release new)) + ((not (equal (archive-content-sha1 new-release) + (archive-content-sha1 old-release))) + (push (list old-release new-release) updated))))) + (maphash (lambda (name old-release) + (declare (ignore name)) + (push old-release removed)) + old-by-name) + (values (nreverse new) + (nreverse updated) + (sort removed #'string< :key #'prefix)))) + +(defmethod show-update-report ((old-dist dist) (new-dist dist)) + (multiple-value-bind (new updated removed) + (update-release-differences old-dist new-dist) + (format t "Changes from ~A ~A to ~A ~A:~%" + (name old-dist) + (version old-dist) + (name new-dist) + (version new-dist)) + (when new + (format t "~& New projects:~%") + (format t "~{ ~A~%~}" (mapcar #'prefix new))) + (when updated + (format t "~% Updated projects:~%") + (loop for (old-release new-release) in updated + do (format t " ~A -> ~A~%" + (prefix old-release) + (prefix new-release)))) + (when removed + (format t "~% Removed projects:~%") + (format t "~{ ~A~%~}" (mapcar #'prefix removed))))) + +(defun clear-dist-systems (dist) + (dolist (system (provided-systems dist)) + (asdf:clear-system (name system)))) + +(defmethod update-in-place :before ((old-dist dist) (new-dist dist)) + ;; Make sure ASDF will reload any systems at their new locations + (clear-dist-systems old-dist)) + +(defmethod update-in-place :after ((old-dist dist) (new-dist dist)) + (clean new-dist)) + +(defmethod update-in-place ((old-dist dist) (new-dist dist)) + (flet ((remove-installed (type) + (let ((wild (merge-pathnames (make-pathname :directory + (list :relative + "installed" + type) + :name :wild + :type "txt") + (base-directory old-dist)))) + (dolist (file (directory wild)) + (delete-file file))))) + (let ((reinstall-releases (installed-releases old-dist))) + (remove-installed "systems") + (remove-installed "releases") + (delete-file-if-exists (relative-to old-dist "releases.txt")) + (delete-file-if-exists (relative-to old-dist "systems.txt")) + (delete-file-if-exists (relative-to old-dist "releases.cdb")) + (delete-file-if-exists (relative-to old-dist "systems.cdb")) + (replace-file (local-distinfo-file new-dist) + (local-distinfo-file old-dist)) + (setf new-dist (find-dist (name new-dist))) + (dolist (old-release reinstall-releases) + (let* ((name (name old-release)) + (new-release (find-release-in-dist name new-dist))) + (if new-release + (ensure-installed new-release) + (warn "~S is not available in ~A" name new-dist))))))) + +(defun install-dist (url &key (prompt t) replace) + (block nil + (setf url (url url)) + (let ((temp-file (qmerge "tmp/install-dist-distinfo.txt"))) + (ensure-directories-exist temp-file) + (delete-file-if-exists temp-file) + (fetch url temp-file) + (let* ((new-dist (make-dist-from-file temp-file)) + (old-dist (find-dist (name new-dist)))) + (when old-dist + (if replace + (uninstall old-dist) + (restart-case + (error "A dist named ~S is already installed." + (name new-dist)) + (replace () + :report "Replace installed dist with new dist" + (uninstall old-dist))))) + (format t "Installing dist ~S version ~S.~%" + (name new-dist) + (version new-dist)) + (when (or (not prompt) + (press-enter-to-continue)) + (ensure-directories-exist (base-directory new-dist)) + (copy-file temp-file (relative-to new-dist "distinfo.txt")) + (ensure-release-index-file new-dist) + (ensure-system-index-file new-dist) + (enable new-dist) + (setf (preference new-dist) (get-universal-time)) + (when old-dist + (clear-dist-systems old-dist)) + (clear-dist-systems new-dist) + new-dist))))) diff --git a/sbcl/.quicklisp/quicklisp/dist.lisp b/sbcl/.quicklisp/quicklisp/dist.lisp new file mode 100644 index 0000000..960e2c9 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/dist.lisp @@ -0,0 +1,1168 @@ +;;;; dist.lisp + +(in-package #:ql-dist) + + +;;; Generic functions + +(defgeneric dist (object) + (:documentation + "Return the dist of OBJECT.")) + +(defgeneric available-versions (object) + (:documentation + "Return a list of version information for OBJECT.")) + +(defgeneric system-index-url (object) + (:documentation + "Return the URL for the system index of OBJECT.")) + +(defgeneric release-index-url (object) + (:documentation + "Return the URL for the release index of OBJECT.")) + +(defgeneric available-versions-url (object) + (:documentation + "Return the URL for the available versions data file of OBJECT.")) + +(defgeneric release (object) + (:documentation + "Return the release of OBJECT.")) + +(defgeneric system (object) + (:documentation + "Return the system of OBJECT.")) + +(defgeneric name (object) + (:documentation + "Return the name of OBJECT.")) + +(defgeneric find-system (name) + (:documentation + "Return a system with the given NAME, or NIL if no system is + found. If multiple systems have the same name, the one with the + highest preference is returned.")) + +(defgeneric find-release (name) + (:documentation + "Return a release with the given NAME, or NIL if no system is + found. If multiple releases have the same name, the one with the + highest preference is returned.")) + +(defgeneric find-systems-named (name) + (:documentation + "Return a list of all systems in all enabled dists with the given + NAME, sorted by preference.")) + +(defgeneric find-releases-named (name) + (:documentation + "Return a list of all releases in all enabled dists with the given + NAME, sorted by preference.")) + + +(defgeneric base-directory (object) + (:documentation + "Return the base directory pathname of OBJECT.") + (:method ((object pathname)) + (merge-pathnames object))) + +(defgeneric relative-to (object pathname) + (:documentation + "Merge PATHNAME with the base-directory of OBJECT.") + (:method (object pathname) + (merge-pathnames pathname (base-directory object)))) + + +(defgeneric enabledp (object) + (:documentation + "Return true if OBJECT is enabled.")) + +(defgeneric enable (object) + (:documentation + "Enable OBJECT.")) + +(defgeneric disable (object) + (:documentation + "Disable OBJECT.")) + +(defgeneric installedp (object) + (:documentation + "Return true if OBJECT is installed.")) + +(defgeneric install (object) + (:documentation + "Install OBJECT.")) + +(defgeneric ensure-installed (object) + (:documentation + "Ensure that OBJECT is installed.") + (:method (object) + (unless (installedp object) + (install object)) + object)) + +(defgeneric uninstall (object) + (:documentation + "Uninstall OBJECT.")) + +(defgeneric metadata-name (object) + (:documentation + "The metadata-name of an object is used to form the pathname for a + few different object metadata files.")) + +(defgeneric install-metadata-file (object) + (:documentation + "The pathname to a file describing the installation status of + OBJECT.")) + +(defgeneric subscription-inhibition-file (object) + (:documentation "The file whose presence indicates the inhibited + subscription status of OBJECT.") + (:method (object) + (relative-to object "subscription-inhibited.txt"))) + +(defgeneric inhibit-subscription (object) + (:documentation "Inhibit subscription for OBJECT.") + (:method (object) + (ensure-file-exists (subscription-inhibition-file object)))) + +(defgeneric uninhibit-subscription (object) + (:documentation "Remove inhibition of subscription for OBJECT.") + (:method (object) + (delete-file-if-exists (subscription-inhibition-file object)))) + +(defgeneric subscription-inhibited-p (object) + (:documentation "Return T if subscription to OBJECT is inhibited.") + (:method (object) + (not (not (probe-file (subscription-inhibition-file object)))))) + +(define-condition subscription-unavailable (error) + ((object + :initarg :object + :reader subscription-unavailable-object))) + +(defgeneric subscribedp (object) + (:documentation "Return true if OBJECT is subscribed to updates.")) + +(defgeneric subscribe (object) + (:documentation "Subscribe to updates of OBJECT, if possible. If no + updates are available, a condition of type SUBSCRIPTION-UNAVAILABLE + is raised.") + (:method (object) + (uninhibit-subscription object) + (unless (subscribedp object) + (error 'subscription-unavailable + :object object)) + t)) + +(defgeneric unsubscribe (object) + (:documentation "Unsubscribe from updates to OBJECT.") + (:method (object) + (inhibit-subscription object))) + + +(defgeneric preference-parent (object) + (:documentation + "Return a value suitable for checking if OBJECT has no specific + preference set.") + (:method (object) + (declare (ignore object)) + nil)) + +(defgeneric preference-file (object) + (:documentation + "Return the file from which preference information is loaded for + OBJECT.") + (:method (object) + (relative-to object "preference.txt"))) + +(defgeneric preference (object) + (:documentation + "Returns a value used when comparing multiple systems or releases + with the same name. Objects with higher preference are returned by + FIND-SYSTEM and FIND-RELEASE.") + (:method ((object null)) + 0) + (:method (object) + (with-open-file (stream (preference-file object) + :if-does-not-exist nil) + (if stream + (values (parse-integer (read-line stream))) + (preference (preference-parent object)))))) + +(defgeneric (setf preference) (preference object) + (:documentation + "Set the preference for OBJECT. Objects with higher preference are + returned by FIND-SYSTEM and FIND-RELEASE.") + (:method (preference object) + (check-type preference integer) + (let ((preference-file (preference-file object))) + (ensure-directories-exist preference-file) + (with-open-file (stream (preference-file object) + :direction :output + :if-exists :supersede) + (format stream "~D" preference))) + preference)) + +(defgeneric forget-preference (object) + (:documentation + "Remove specific preference information for OBJECT.") + (:method (object) + (delete-file-if-exists (preference-file object)))) + +(defgeneric short-description (object) + (:documentation "Return a short string describing OBJECT.")) + + +(defgeneric provided-releases (object) + (:documentation "Return a list of releases provided by OBJECT.")) + +(defgeneric provided-systems (object) + (:documentation "Return a list of systems provided by OBJECT.")) + +(defgeneric installed-releases (dist) + (:documentation + "Return a list of all releases installed for DIST.") + (:method (dist) + (remove-if-not #'installedp (provided-releases dist)))) + +(defgeneric installed-systems (dist) + (:documentation + "Return a list of all systems installed for DIST.") + (:method (dist) + (remove-if-not #'installedp (provided-systems dist)))) + +(defgeneric new-version-available-p (dist) + (:documentation + "Return true if a new version of DIST is available.")) + +(defgeneric find-system-in-dist (system-name dist) + (:documentation + "Return a system with the given NAME in DIST, or NIL if no system + is found.")) + +(defgeneric find-release-in-dist (release-name dist) + (:documentation + "Return a release with the given NAME in DIST, or NIL if no release + is found.")) + + +(defgeneric ensure-system-index-file (dist) + (:documentation + "Return the pathname for the system index file of DIST, fetching it + from a remote source first if necessary.")) + +(defgeneric ensure-system-cdb-file (dist) + (:documentation + "Return the pathname for the system cdb file of DIST, creating it + if necessary.")) + +(defgeneric ensure-release-index-file (dist) + (:documentation + "Return the pathname for the release index file of DIST, fetching + it from a remote source first if necessary.")) + +(defgeneric ensure-release-cdb-file (dist) + (:documentation + "Return the pathname for the release cdb file of DIST, creating it + if necessary.")) + + +(defgeneric initialize-release-index (dist) + (:documentation + "Initialize the release index of DIST.")) + +(defgeneric initialize-system-index (dist) + (:documentation + "Initialize the system index of DIST.")) + + +(defgeneric local-archive-file (release) + (:documentation + "Return the pathname to where the archive file of RELEASE should be + stored.")) + +(defgeneric ensure-local-archive-file (release) + (:documentation + "If the archive file for RELEASE is not available locally, fetch it + and return the pathname to it.")) + +(defgeneric check-local-archive-file (release) + (:documentation + "Check the local archive file of RELEASE for validity, including + size and signature checks. Signals errors in the case of invalid files.")) + + +(defgeneric archive-url (release) + (:documentation + "Return the full URL for fetching the archive file of RELEASE.")) + +(defgeneric installed-asdf-system-file (object) + (:documentation + "Return the path to the installed ASDF system file for OBJECT, or + NIL if there is no installed system file.")) + + + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro destructure-line (lambda-list line &body body) + `(destructuring-bind ,lambda-list + (split-spaces ,line) + ,@body)) + + (defun call-for-each-line (fun file) + (with-open-file (stream file) + (loop for line = (read-line stream nil) + while line do (funcall fun line)))) + + (defmacro for-each-line ((line file) &body body) + `(call-for-each-line (lambda (,line) ,@body) ,file))) + +(defun make-line-instance (line class &rest initargs) + "Create an instance from words in an index file line. The last initarg collects all the trailing arguments, if any." + (let* ((words (split-spaces line)) + (args (mapcan #'list + (butlast initargs) + words)) + (trailing (subseq words (1- (length initargs))))) + (apply #'make-instance class (first (last initargs)) trailing args))) + +(defun ignorable-line (line) + (labels ((blank-char-p (char) + (member char '(#\Space #\Tab))) + (blankp (line) + (every #'blank-char-p line)) + (ignorable (line) + (or (zerop (length line)) + (blankp line) + (eql (char line 0) #\#)))) + (ignorable line))) + +(defvar *initarg-case-converter* + (cond ((string= :string "string") + #'string-downcase) + ((string= :string "STRING") + #'string-upcase))) + +(defun config-file-initargs (file) + (flet ((initarg-keyword (string) + ;; A concession to mlisp + (intern (funcall *initarg-case-converter* string) + 'keyword))) + (let ((initargs '())) + (for-each-line (line file) + (unless (ignorable-line line) + (destructure-line (initarg value) + line + (let ((keyword (initarg-keyword (string-right-trim ":" initarg)))) + (push value initargs) + (push keyword initargs))))) + initargs))) + +;;; +;;; A few generic things +;;; + +(defmethod dist ((name symbol)) + (dist (string name))) + +(defmethod dist ((name string)) + (find-dist (string-downcase name))) + +(defmethod release ((name symbol)) + (release (string name))) + +(defmethod release ((name string)) + (find-release (string-downcase name))) + +(defmethod system ((name symbol)) + (system (string name))) + +(defmethod system ((name string)) + (find-system (string-downcase name))) + +;;; +;;; Dists +;;; +;;; A dist is a set of releases. +;;; + +(defclass dist () + ((base-directory + :initarg :base-directory + :accessor base-directory) + (name + :initarg :name + :accessor name) + (version + :initarg :version + :accessor version) + (system-index-url + :initarg :system-index-url + :accessor system-index-url) + (release-index-url + :initarg :release-index-url + :accessor release-index-url) + (available-versions-url + :initarg :available-versions-url + :accessor available-versions-url) + (archive-base-url + :initarg :archive-base-url + :accessor archive-base-url) + (canonical-distinfo-url + :initarg :canonical-distinfo-url + :accessor canonical-distinfo-url) + (distinfo-subscription-url + :initarg :distinfo-subscription-url + :accessor distinfo-subscription-url) + (system-index + :initarg :system-index + :accessor system-index) + (release-index + :initarg :release-index + :accessor release-index) + (provided-systems + :initarg :provided-systems + :accessor provided-systems) + (provided-releases + :initarg :provided-releases + :accessor provided-releases) + (local-distinfo-file + :initarg :local-distinfo-file + :accessor local-distinfo-file)) + (:default-initargs + :name "unnamed" + :version "unknown" + :distinfo-subscription-url nil)) + +(defmethod short-description ((dist dist)) + (format nil "~A ~A" (name dist) (version dist))) + +(defmethod print-object ((dist dist) stream) + (print-unreadable-object (dist stream :type t) + (write-string (short-description dist) stream))) + +(defun cdb-lookup (dist key cdb) + (ql-cdb:lookup key + (relative-to dist cdb))) + +(defmethod slot-unbound (class (dist dist) (slot (eql 'available-versions-url))) + (declare (ignore class)) + (setf (available-versions-url dist) + (make-versions-url (distinfo-subscription-url dist)))) + + +(defmethod ensure-system-index-file ((dist dist)) + (let ((pathname (relative-to dist "systems.txt"))) + (or (probe-file pathname) + (nth-value 1 (fetch (system-index-url dist) pathname))))) + +(defmethod ensure-system-cdb-file ((dist dist)) + (let* ((system-file (ensure-system-index-file dist)) + (cdb-file (make-pathname :type "cdb" :defaults system-file))) + (or (probe-file cdb-file) + (ql-cdb:convert-index-file system-file + :cdb-file cdb-file + :index 2)))) + +(defmethod ensure-release-index-file ((dist dist)) + (let ((pathname (relative-to dist "releases.txt"))) + (or (probe-file pathname) + (nth-value 1 (fetch (release-index-url dist) pathname))))) + +(defmethod ensure-release-cdb-file ((dist dist)) + (let* ((release-file (ensure-release-index-file dist)) + (cdb-file (make-pathname :type "cdb" :defaults release-file))) + (or (probe-file cdb-file) + (ql-cdb:convert-index-file release-file + :cdb-file cdb-file + :index 0)))) + +(defmethod slot-unbound (class (dist dist) (slot (eql 'provided-systems))) + (declare (ignore class)) + (initialize-system-index dist) + (setf (slot-value dist 'provided-systems) + (loop for system being each hash-value of (system-index dist) + collect system))) + +(defmethod slot-unbound (class (dist dist) (slot (eql 'provided-releases))) + (declare (ignore class)) + (initialize-release-index dist) + (setf (slot-value dist 'provided-releases) + (loop for system being each hash-value of (release-index dist) + collect system))) + + +(defun dist-name-pathname (name) + "Return the pathname that would be used for an installed dist with +the given NAME." + (qmerge (make-pathname :directory (list :relative "dists" name)))) + +(defmethod slot-unbound (class (dist dist) (slot (eql 'base-directory))) + (declare (ignore class)) + (setf (base-directory dist) (dist-name-pathname (name dist)))) + +(defun make-dist-from-file (file &key (class 'dist)) + "Load dist info from FILE and use it to create a dist instance." + (let ((initargs (config-file-initargs file))) + (apply #'make-instance class + :local-distinfo-file file + :allow-other-keys t + initargs))) + +(defmethod install-metadata-file ((dist dist)) + (relative-to dist "distinfo.txt")) + +(defun find-dist (name) + (find name (all-dists) + :key #'name + :test #'string=)) + +(defmethod enabledp ((dist dist)) + (not (not (probe-file (relative-to dist "enabled.txt"))))) + +(defmethod enable ((dist dist)) + (ensure-file-exists (relative-to dist "enabled.txt")) + t) + +(defmethod disable ((dist dist)) + (delete-file-if-exists (relative-to dist "enabled.txt")) + t) + +(defmethod installedp ((dist dist)) + (let ((installed (find-dist (name dist)))) + (equalp (version installed) (version dist)))) + +(defmethod uninstall ((dist dist)) + (when (installedp dist) + (dolist (system (provided-systems dist)) + (asdf:clear-system (name system))) + (ql-impl-util:delete-directory-tree (base-directory dist)) + t)) + + +(defun make-release-from-line (line dist) + (let ((release + (make-line-instance line 'release + :project-name + :archive-url + :archive-size + :archive-md5 + :archive-content-sha1 + :prefix + :system-files))) + (setf (dist release) dist) + (setf (archive-size release) + (parse-integer (archive-size release))) + release)) + +(defmethod find-release-in-dist (release-name (dist dist)) + (let* ((index (release-index dist)) + (release (gethash release-name index))) + (or release + (let ((line (cdb-lookup dist release-name + (ensure-release-cdb-file dist)))) + (when line + (setf (gethash release-name index) + (make-release-from-line line dist))))))) + + +(defparameter *dist-enumeration-functions* + '(standard-dist-enumeration-function) + "ALL-DISTS calls each function in this list with no arguments, and + appends the results into a list of dist objects, removing + duplicates. Functions might be called just once for a batch of + related operations; see WITH-CONSISTENT-DISTS.") + +(defun standard-dist-enumeration-function () + "The default function used for producing a list of dist objects." + (loop for file in (directory (qmerge "dists/*/distinfo.txt")) + collect (make-dist-from-file file))) + +(defun all-dists () + "Return a list of all known dists." + (remove-duplicates + (apply 'append (mapcar 'funcall *dist-enumeration-functions*)))) + +(defun enabled-dists () + "Return a list of all known dists for which ENABLEDP returns true." + (remove-if-not #'enabledp (all-dists))) + + +(defmethod install-metadata-file (object) + (relative-to (dist object) + (make-pathname :directory + (list :relative "installed" + (metadata-name object)) + :name (name object) + :type "txt"))) + + +(defclass preference-mixin () () + (:documentation + "Instances of this class have a special location for their + preference files.")) + +(defgeneric filesystem-name (object) + (:method (object) + ;; This is to work around system names like "foo/bar". + (let* ((name (name object)) + (slash (position #\/ name))) + (if slash + (subseq name 0 slash) + name)))) + +(defmethod preference-file ((object preference-mixin)) + (relative-to + (dist object) + (make-pathname :directory (list :relative + "preferences" + (metadata-name object)) + :name (filesystem-name object) + :type "txt"))) + +(defmethod distinfo-subscription-url :around ((dist dist)) + (unless (subscription-inhibited-p dist) + (call-next-method))) + +(defmethod subscribedp ((dist dist)) + (distinfo-subscription-url dist)) + +;;; +;;; Releases +;;; + +(defclass release (preference-mixin) + ((project-name + :initarg :project-name + :accessor name + :accessor project-name) + (dist + :initarg :dist + :accessor dist + :reader preference-parent) + (provided-systems + :initarg :provided-systems + :accessor provided-systems) + (archive-url + :initarg :archive-url + :accessor archive-url) + (archive-size + :initarg :archive-size + :accessor archive-size) + (archive-md5 + :initarg :archive-md5 + :accessor archive-md5) + (archive-content-sha1 + :initarg :archive-content-sha1 + :accessor archive-content-sha1) + (prefix + :initarg :prefix + :accessor prefix + :reader short-description) + (system-files + :initarg :system-files + :accessor system-files) + (metadata-name + :initarg :metadata-name + :accessor metadata-name)) + (:default-initargs + :metadata-name "releases") + (:documentation + "Instances of this class represent a snapshot of a project at some + point in time, which might be from version control, or from an + official release, or from some other source.")) + +(defmethod print-object ((release release) stream) + (print-unreadable-object (release stream :type t) + (format stream "~A / ~A" + (short-description release) + (short-description (dist release))))) + +(define-condition invalid-local-archive (error) + ((release + :initarg :release + :reader invalid-local-archive-release) + (file + :initarg :file + :reader invalid-local-archive-file)) + (:report + (lambda (condition stream) + (format stream "The archive file ~S for release ~S is invalid" + (file-namestring (invalid-local-archive-file condition)) + (name (invalid-local-archive-release condition)))))) + +(define-condition missing-local-archive (invalid-local-archive) + () + (:report + (lambda (condition stream) + (format stream "The archive file ~S for release ~S is missing" + (file-namestring (invalid-local-archive-file condition)) + (name (invalid-local-archive-release condition)))))) + +(define-condition badly-sized-local-archive (invalid-local-archive) + ((expected-size + :initarg :expected-size + :reader badly-sized-local-archive-expected-size) + (actual-size + :initarg :actual-size + :reader badly-sized-local-archive-actual-size)) + (:report + (lambda (condition stream) + (format stream "The archive file ~S for ~S is the wrong size: ~ + expected ~:D, got ~:D" + (file-namestring (invalid-local-archive-file condition)) + (name (invalid-local-archive-release condition)) + (badly-sized-local-archive-expected-size condition) + (badly-sized-local-archive-actual-size condition))))) + +(defmethod check-local-archive-file ((release release)) + (let ((file (local-archive-file release))) + (unless (probe-file file) + (error 'missing-local-archive + :file file + :release release)) + (let ((actual-size (file-size file)) + (expected-size (archive-size release))) + (unless (= actual-size expected-size) + (error 'badly-sized-local-archive + :file file + :release release + :actual-size actual-size + :expected-size expected-size))))) + +(defmethod local-archive-file ((release release)) + (relative-to (dist release) + (make-pathname :directory '(:relative "archives") + :defaults (file-namestring + (path (url (archive-url release))))))) + +(defmethod ensure-local-archive-file ((release release)) + (let ((pathname (local-archive-file release))) + (tagbody + :retry + (or (probe-file pathname) + (progn + (ensure-directories-exist pathname) + (fetch (archive-url release) pathname))) + (restart-case + (check-local-archive-file release) + (delete-and-retry (&optional v) + :report "Delete the archive file and fetch it again" + (declare (ignore v)) + (delete-file pathname) + (go :retry)))) + pathname)) + + +(defmethod base-directory ((release release)) + (relative-to + (dist release) + (make-pathname :directory (list :relative "software" (prefix release))))) + +(defmethod installedp ((release release)) + (and (probe-file (install-metadata-file release)) + (every #'installedp (provided-systems release)))) + +(defmethod install ((release release)) + (let ((archive (ensure-local-archive-file release)) + (tar (qmerge "tmp/release-install.tar")) + (output (relative-to (dist release) + (make-pathname :directory + (list :relative "software")))) + (tracking (install-metadata-file release))) + (ensure-directories-exist tar) + (ensure-directories-exist output) + (ensure-directories-exist tracking) + (gunzip archive tar) + (unpack-tarball tar :directory output) + (ensure-directories-exist tracking) + (with-open-file (stream tracking + :direction :output + :if-exists :supersede) + (write-line (qenough (base-directory release)) stream)) + (let ((provided (provided-systems release)) + (dist (dist release))) + (dolist (file (system-files release)) + (let ((system (find-system-in-dist (pathname-name file) dist))) + (unless (member system provided) + (error "FIND-SYSTEM-IN-DIST returned ~A but I expected one of ~A" + system provided)) + (let ((system-tracking (install-metadata-file system)) + (system-file (merge-pathnames file + (base-directory release)))) + (ensure-directories-exist system-tracking) + (unless (probe-file system-file) + (error "Release claims to have ~A, but I can't find it" + system-file)) + (with-open-file (stream system-tracking + :direction :output + :if-exists :supersede) + (write-line (qenough system-file) + stream)))))) + release)) + +(defmethod uninstall ((release release)) + (when (installedp release) + (dolist (system (installed-systems release)) + (asdf:clear-system (name system)) + (delete-file (install-metadata-file system))) + (delete-file (install-metadata-file release)) + (delete-file (local-archive-file release)) + (ql-impl-util:delete-directory-tree (base-directory release)) + t)) + + +(defun call-for-each-index-entry (file fun) + (labels ((blank-char-p (char) + (member char '(#\Space #\Tab))) + (blankp (line) + (every #'blank-char-p line)) + (ignorable (line) + (or (zerop (length line)) + (blankp line) + (eql (char line 0) #\#)))) + (with-open-file (stream file) + (loop for line = (read-line stream nil) + while line do + (unless (ignorable line) + (funcall fun line)))))) + +(defmethod slot-unbound (class (dist dist) (slot (eql 'release-index))) + (declare (ignore class)) + (setf (slot-value dist 'release-index) + (make-hash-table :test 'equal))) + + +;;; +;;; Systems +;;; +;;; A "system" in the defsystem sense. +;;; + +(defclass system (preference-mixin) + ((name + :initarg :name + :accessor name + :reader short-description) + (system-file-name + :initarg :system-file-name + :accessor system-file-name) + (release + :initarg :release + :accessor release + :reader preference-parent) + (dist + :initarg :dist + :accessor dist) + (required-systems + :initarg :required-systems + :accessor required-systems) + (metadata-name + :initarg :metadata-name + :accessor metadata-name)) + (:default-initargs + :metadata-name "systems")) + +(defmethod print-object ((system system) stream) + (print-unreadable-object (system stream :type t) + (format stream "~A / ~A / ~A" + (short-description system) + (short-description (release system)) + (short-description (dist system))))) + +(defmethod provided-systems ((system system)) + (list system)) + +(defmethod initialize-release-index ((dist dist)) + (let ((releases (ensure-release-index-file dist)) + (index (release-index dist))) + (call-for-each-index-entry + releases + (lambda (line) + (let ((instance (make-line-instance line 'release + :project-name + :archive-url + :archive-size + :archive-md5 + :archive-content-sha1 + :prefix + :system-files))) + ;; Don't clobber anything previously loaded via CDB + (unless (gethash (project-name instance) index) + (setf (dist instance) dist) + (setf (archive-size instance) + (parse-integer (archive-size instance))) + (setf (gethash (project-name instance) index) instance))))) + (setf (release-index dist) index))) + +(defmethod initialize-system-index ((dist dist)) + (initialize-release-index dist) + (let ((systems (ensure-system-index-file dist)) + (index (system-index dist))) + (call-for-each-index-entry + systems + (lambda (line) + (let ((instance (make-line-instance line 'system + :release + :system-file-name + :name + :required-systems))) + ;; Don't clobber anything previously loaded via CDB + (unless (gethash (name instance) index) + (let ((release (find-release-in-dist (release instance) dist))) + (setf (release instance) release) + (if (slot-boundp release 'provided-systems) + (pushnew instance (provided-systems release)) + (setf (provided-systems release) (list instance)))) + (setf (dist instance) dist) + (setf (gethash (name instance) index) instance))))) + (setf (system-index dist) index))) + +(defmethod slot-unbound (class (release release) (slot (eql 'provided-systems))) + (declare (ignore class)) + ;; FIXME: This isn't right, since the system index has systems that + ;; don't match the defining system file name. + (setf (slot-value release 'provided-systems) + (mapcar (lambda (system-file) + (find-system-in-dist (pathname-name system-file) + (dist release))) + (system-files release)))) + +(defmethod slot-unbound (class (dist dist) (slot (eql 'system-index))) + (declare (ignore class)) + (setf (slot-value dist 'system-index) + (make-hash-table :test 'equal))) + +(defun make-system-from-line (line dist) + (let ((system (make-line-instance line 'system + :release + :system-file-name + :name + :required-systems))) + (setf (dist system) dist) + (setf (release system) + (find-release-in-dist (release system) dist)) + system)) + +(defmethod find-system-in-dist (system-name (dist dist)) + (let* ((index (system-index dist)) + (system (gethash system-name index))) + (or system + (let ((line (cdb-lookup dist system-name + (ensure-system-cdb-file dist)))) + (when line + (setf (gethash system-name index) + (make-system-from-line line dist))))))) + +(defmethod preference ((system system)) + (if (probe-file (preference-file system)) + (call-next-method) + (preference (release system)))) + +(defun thing-name-designator (designator) + "Convert DESIGNATOR to a string naming a thing. Strings are used + as-is, symbols are converted to their downcased symbol-name." + (typecase designator + (string designator) + (symbol (string-downcase designator)) + (t + (error "~S is not a valid designator for a system or release" + designator)))) + +(defun find-thing-named (find-fun name) + (setf name (thing-name-designator name)) + (let ((result '())) + (dolist (dist (enabled-dists) (sort result #'> :key #'preference)) + (let ((thing (funcall find-fun name dist))) + (when thing + (push thing result)))))) + +(defmethod find-systems-named (name) + (find-thing-named #'find-system-in-dist name)) + +(defmethod find-releases-named (name) + (find-thing-named #'find-release-in-dist name)) + +(defmethod find-system (name) + (first (find-systems-named name))) + +(defmethod find-release (name) + (first (find-releases-named name))) + +(defmethod install ((system system)) + (ensure-installed (release system))) + + +(defmethod install-metadata-file ((system system)) + (relative-to (dist system) + (make-pathname :name (system-file-name system) + :type "txt" + :directory '(:relative "installed" "systems")))) + +(defmethod installed-asdf-system-file ((system system)) + (let ((metadata-file (install-metadata-file system))) + (when (probe-file metadata-file) + (with-open-file (stream metadata-file) + (let* ((relative (read-line stream)) + (full (qmerge relative))) + (when (probe-file full) + full)))))) + +(defmethod installedp ((system system)) + (installed-asdf-system-file system)) + +(defmethod uninstall ((system system)) + (uninstall (release system))) + +(defun find-asdf-system-file (name) + "Return the ASDF system file in which the system named NAME is defined." + (let ((system (find-system name))) + (when system + (installed-asdf-system-file system)))) + +(defun system-definition-searcher (name) + "Like FIND-ASDF-SYSTEM-FILE, but this function can be used in +ASDF:*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*; it will only return system +file names if they match NAME." + (let ((system-file (find-asdf-system-file name))) + (when (and system-file + (string= (pathname-name system-file) name)) + system-file))) + +(defun call-with-consistent-dists (fun) + "Take a snapshot of the available dists and return the same list +consistently each time ALL-DISTS is called in the dynamic scope of +FUN." + (let* ((all-dists (all-dists)) + (*dist-enumeration-functions* (list (constantly all-dists)))) + (funcall fun))) + +(defmacro with-consistent-dists (&body body) + "See CALL-WITH-CONSISTENT-DISTS." + `(call-with-consistent-dists (lambda () ,@body))) + + +(defgeneric dependency-tree (system) + (:method ((symbol symbol)) + (dependency-tree (string-downcase symbol))) + (:method ((string string)) + (let ((system (find-system string))) + (when system + (dependency-tree system)))) + (:method ((system system)) + (with-consistent-dists + (list* system + (remove nil + (mapcar 'dependency-tree (required-systems system))))))) + +(defmethod provided-systems ((object (eql t))) + (let ((systems (loop for dist in (enabled-dists) + appending (provided-systems dist)))) + (sort systems #'string< :key #'name))) + +(defmethod provided-releases ((object (eql t))) + (let ((releases (loop for dist in (enabled-dists) + appending (provided-releases dist)))) + (sort releases #'string< :key #'name))) + + +(defgeneric system-apropos-list (term) + (:method ((term symbol)) + (system-apropos-list (symbol-name term))) + (:method ((term string)) + (setf term (string-downcase term)) + (let ((result '())) + (dolist (system (provided-systems t) (nreverse result)) + (when (or (search term (name system)) + (search term (name (release system)))) + (push system result)))))) + +(defgeneric system-apropos (term) + (:method (term) + (map nil (lambda (system) + (format t "~A~%" system)) + (system-apropos-list term)) + (values))) + + +;;; +;;; Clean up things +;;; + +(defgeneric clean (object) + (:documentation "Remove any unneeded files or directories related to + OBJECT.")) + +(defmethod clean ((dist dist)) + (let* ((releases (provided-releases dist)) + (known-archives (mapcar 'local-archive-file releases)) + (known-directories (mapcar 'base-directory releases)) + (present-archives (mapcar 'truename + (directory-entries + (relative-to dist "archives/")))) + (present-directories (mapcar 'truename + (directory-entries + (relative-to dist "software/")))) + (garbage-archives + (set-difference present-archives known-archives + :test 'equalp)) + (garbage-directories + ;; Use the namestring here on the theory that pathnames with + ;; equalp namestrings are sufficiently the same. On + ;; LispWorks, for example, identical namestrings can still + ;; differ in :name, :type, and more. + (set-difference present-directories known-directories + :test 'equalp + :key 'namestring))) + (map nil 'delete-file garbage-archives) + (map nil 'delete-directory-tree garbage-directories))) + + +;;; +;;; Available versions +;;; + +(defmethod available-versions ((dist dist)) + (let ((temp (qmerge "tmp/dist-versions.txt")) + (versions '()) + (url (available-versions-url dist))) + (when url + (ensure-directories-exist temp) + (delete-file-if-exists temp) + (handler-case + (fetch url temp) + (unexpected-http-status () + (return-from available-versions nil))) + (with-open-file (stream temp) + (loop for line = (read-line stream nil) + while line do + (destructuring-bind (version url) + (split-spaces line) + (setf versions (acons version url versions))))) + versions))) + + +;;; +;;; User interface bits to re-export from QL +;;; + +(define-condition unknown-dist (error) + ((name + :initarg :name + :reader unknown-dist-name)) + (:report (lambda (condition stream) + (format stream "No dist known by that name -- ~S" + (unknown-dist-name condition))))) + +(defun find-dist-or-lose (name) + (let ((dist (find-dist name))) + (or dist + (error 'unknown-dist :name name)))) + +(defun dist-url (name) + (canonical-distinfo-url (find-dist-or-lose name))) + +(defun dist-version (name) + (version (find-dist-or-lose name))) diff --git a/sbcl/.quicklisp/quicklisp/fetch-gzipped.lisp b/sbcl/.quicklisp/quicklisp/fetch-gzipped.lisp new file mode 100644 index 0000000..b453803 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/fetch-gzipped.lisp @@ -0,0 +1,29 @@ +;;;; fetch-gzipped.lisp + +(in-package #:quicklisp-client) + +(defun gzipped-url (url) + (check-type url string) + (concatenate 'string url ".gz")) + +(defun fetch-gzipped-version (url file &key quietly) + (let ((gzipped (gzipped-url url)) + (gzipped-temp (merge-pathnames "gzipped.tmp" file))) + (fetch gzipped gzipped-temp :quietly quietly) + (gunzip gzipped-temp file) + (delete-file-if-exists gzipped-temp) + (probe-file file))) + +(defun url-not-suitable-error-p (condition) + (<= 400 (unexpected-http-status-code condition) 499)) + +(defun maybe-fetch-gzipped (url file &key quietly) + (handler-case + (fetch-gzipped-version url file :quietly quietly) + (unexpected-http-status (condition) + (cond ((url-not-suitable-error-p condition) + (fetch url file :quietly quietly) + (probe-file file)) + (t + (error condition)))))) + diff --git a/sbcl/.quicklisp/quicklisp/http.lisp b/sbcl/.quicklisp/quicklisp/http.lisp new file mode 100644 index 0000000..d942fb8 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/http.lisp @@ -0,0 +1,859 @@ +;;; +;;; A simple HTTP client +;;; + +(in-package #:ql-http) + +;;; Octet data + +(deftype octet () + '(unsigned-byte 8)) + +(defun make-octet-vector (size) + (make-array size :element-type 'octet + :initial-element 0)) + +(defun octet-vector (&rest octets) + (make-array (length octets) :element-type 'octet + :initial-contents octets)) + +;;; ASCII characters as integers + +(defun acode (char) + (cond ((eql char :cr) + 13) + ((eql char :lf) + 10) + (t + (let ((code (char-code char))) + (if (<= 0 code 127) + code + (error "Character ~S is not in the ASCII character set" + char)))))) + +(defvar *whitespace* + (list (acode #\Space) (acode #\Tab) (acode :cr) (acode :lf))) + +(defun whitep (code) + (member code *whitespace*)) + +(defun ascii-vector (string) + (let ((vector (make-octet-vector (length string)))) + (loop for char across string + for code = (char-code char) + for i from 0 + if (< 127 code) do + (error "Invalid character for ASCII -- ~A" char) + else + do (setf (aref vector i) code)) + vector)) + +(defun ascii-subseq (vector start end) + "Return a subseq of octet-specialized VECTOR as a string." + (let ((string (make-string (- end start)))) + (loop for i from 0 + for j from start below end + do (setf (char string i) (code-char (aref vector j)))) + string)) + +(defun ascii-downcase (code) + (if (<= 65 code 90) + (+ code 32) + code)) + +(defun ascii-equal (a b) + (eql (ascii-downcase a) (ascii-downcase b))) + +(defmacro acase (value &body cases) + (flet ((convert-case-keys (keys) + (mapcar (lambda (key) + (etypecase key + (integer key) + (character (char-code key)) + (symbol + (ecase key + (:cr 13) + (:lf 10) + ((t) t))))) + (if (consp keys) keys (list keys))))) + `(case ,value + ,@(mapcar (lambda (case) + (destructuring-bind (keys &rest body) + case + `(,(if (eql keys t) + t + (convert-case-keys keys)) + ,@body))) + cases)))) + +;;; Pattern matching (for finding headers) + +(defclass matcher () + ((pattern + :initarg :pattern + :reader pattern) + (pos + :initform 0 + :accessor match-pos) + (matchedp + :initform nil + :accessor matchedp))) + +(defun reset-match (matcher) + (setf (match-pos matcher) 0 + (matchedp matcher) nil)) + +(define-condition match-failure (error) ()) + +(defun match (matcher input &key (start 0) end error) + (let ((i start) + (end (or end (length input))) + (match-end (length (pattern matcher)))) + (with-slots (pattern pos) + matcher + (loop + (cond ((= pos match-end) + (let ((match-start (- i pos))) + (setf pos 0) + (setf (matchedp matcher) t) + (return (values match-start (+ match-start match-end))))) + ((= i end) + (return nil)) + ((= (aref pattern pos) + (aref input i)) + (incf i) + (incf pos)) + (t + (if error + (error 'match-failure) + (if (zerop pos) + (incf i) + (setf pos 0))))))))) + +(defun ascii-matcher (string) + (make-instance 'matcher + :pattern (ascii-vector string))) + +(defun octet-matcher (&rest octets) + (make-instance 'matcher + :pattern (apply 'octet-vector octets))) + +(defun acode-matcher (&rest codes) + (make-instance 'matcher + :pattern (make-array (length codes) + :element-type 'octet + :initial-contents + (mapcar 'acode codes)))) + + +;;; "Connection Buffers" are a kind of callback-driven, +;;; pattern-matching chunky stream. Callbacks can be called for a +;;; certain number of octets or until one or more patterns are seen in +;;; the input. cbufs automatically refill themselves from a +;;; connection as needed. + +(defvar *cbuf-buffer-size* 8192) + +(define-condition end-of-data (error) ()) + +(defclass cbuf () + ((data + :initarg :data + :accessor data) + (connection + :initarg :connection + :accessor connection) + (start + :initarg :start + :accessor start) + (end + :initarg :end + :accessor end) + (eofp + :initarg :eofp + :accessor eofp)) + (:default-initargs + :data (make-octet-vector *cbuf-buffer-size*) + :connection nil + :start 0 + :end 0 + :eofp nil) + (:documentation "A CBUF is a connection buffer that keeps track of + incoming data from a connection. Several functions make it easy to + treat a CBUF as a kind of chunky, callback-driven stream.")) + +(define-condition cbuf-progress () + ((size + :initarg :size + :accessor cbuf-progress-size + :initform 0))) + +(defun call-processor (fun cbuf start end) + (signal 'cbuf-progress :size (- end start)) + (funcall fun (data cbuf) start end)) + +(defun make-cbuf (connection) + (make-instance 'cbuf :connection connection)) + +(defun make-stream-writer (stream) + "Create a callback for writing data to STREAM." + (lambda (data start end) + (write-sequence data stream :start start :end end))) + +(defgeneric size (cbuf) + (:method ((cbuf cbuf)) + (- (end cbuf) (start cbuf)))) + +(defgeneric emptyp (cbuf) + (:method ((cbuf cbuf)) + (zerop (size cbuf)))) + +(defgeneric refill (cbuf) + (:method ((cbuf cbuf)) + (when (eofp cbuf) + (error 'end-of-data)) + (setf (start cbuf) 0) + (setf (end cbuf) + (read-octets (data cbuf) + (connection cbuf))) + (cond ((emptyp cbuf) + (setf (eofp cbuf) t) + (error 'end-of-data)) + (t (size cbuf))))) + +(defun process-all (fun cbuf) + (unless (emptyp cbuf) + (call-processor fun cbuf (start cbuf) (end cbuf)))) + +(defun multi-cmatch (matchers cbuf) + (let (start end) + (dolist (matcher matchers (values start end)) + (multiple-value-bind (s e) + (match matcher (data cbuf) + :start (start cbuf) + :end (end cbuf)) + (when (and s (or (null start) (< s start))) + (setf start s + end e)))))) + +(defun cmatch (matcher cbuf) + (if (consp matcher) + (multi-cmatch matcher cbuf) + (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)))) + +(defun call-until-end (fun cbuf) + (handler-case + (loop + (process-all fun cbuf) + (refill cbuf)) + (end-of-data () + (return-from call-until-end)))) + +(defun show-cbuf (context cbuf) + (format t "cbuf: ~A ~D - ~D~%" context (start cbuf) (end cbuf))) + +(defun call-for-n-octets (n fun cbuf) + (let ((remaining n)) + (loop + (when (<= remaining (size cbuf)) + (let ((end (+ (start cbuf) remaining))) + (call-processor fun cbuf (start cbuf) end) + (setf (start cbuf) end) + (return))) + (process-all fun cbuf) + (decf remaining (size cbuf)) + (refill cbuf)))) + +(defun call-until-matching (matcher fun cbuf) + (loop + (multiple-value-bind (start end) + (cmatch matcher cbuf) + (when start + (call-processor fun cbuf (start cbuf) end) + (setf (start cbuf) end) + (return))) + (process-all fun cbuf) + (refill cbuf))) + +(defun ignore-data (data start end) + (declare (ignore data start end))) + +(defun skip-until-matching (matcher cbuf) + (call-until-matching matcher 'ignore-data cbuf)) + + +;;; Creating HTTP requests as octet buffers + +(defclass octet-sink () + ((storage + :initarg :storage + :accessor storage)) + (:default-initargs + :storage (make-array 1024 :element-type 'octet + :fill-pointer 0 + :adjustable t)) + (:documentation "A simple stream-like target for collecting + octets.")) + +(defun add-octet (octet sink) + (vector-push-extend octet (storage sink))) + +(defun add-octets (octets sink &key (start 0) end) + (setf end (or end (length octets))) + (loop for i from start below end + do (add-octet (aref octets i) sink))) + +(defun add-string (string sink) + (loop for char across string + for code = (char-code char) + do (add-octet code sink))) + +(defun add-strings (sink &rest strings) + (mapc (lambda (string) (add-string string sink)) strings)) + +(defun add-newline (sink) + (add-octet 13 sink) + (add-octet 10 sink)) + +(defun sink-buffer (sink) + (subseq (storage sink) 0)) + +(defvar *proxy-url* (config-value "proxy-url")) + +(defun full-proxy-path (host port path) + (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A" + (eql port 443) + host + (or (null port) + (eql port 80) + (eql port 443)) + port + path)) + +(defun user-agent-string () + "Return a string suitable for using as the User-Agent value in HTTP +requests. Includes Quicklisp version and CL implementation and version +information." + (labels ((requires-encoding (char) + (not (or (alphanumericp char) + (member char '(#\. #\- #\_))))) + (encode (string) + (substitute-if #\_ #'requires-encoding string)) + (version-string (string) + (if (string-equal string nil) + "unknown" + (let* ((length (length string)) + (start (or (position-if #'digit-char-p string) + 0)) + (space (or (position #\Space string :start start) + length)) + (limit (min space length (+ start 24)))) + (encode (subseq string start limit)))))) + ;; FIXME: Be more configurable, and take/set the version from + ;; somewhere else. + (format nil "quicklisp-client/~A ~A/~A" + ql-info:*version* + (encode (lisp-implementation-type)) + (version-string (lisp-implementation-version))))) + +(defun make-request-buffer (host port path &key (method "GET")) + "Return an octet vector suitable for sending as an HTTP 1.1 request." + (setf method (string method)) + (when *proxy-url* + (setf path (full-proxy-path host port path))) + (let ((sink (make-instance 'octet-sink))) + (flet ((add-line (&rest strings) + (apply #'add-strings sink strings) + (add-newline sink))) + (add-line method " " path " HTTP/1.1") + (add-line "Host: " host (if (integerp port) + (format nil ":~D" port) + "")) + (add-line "Connection: close") + (add-line "User-Agent: " (user-agent-string)) + (add-newline sink) + (sink-buffer sink)))) + +(defun sink-until-matching (matcher cbuf) + (let ((sink (make-instance 'octet-sink))) + (call-until-matching + matcher + (lambda (buffer start end) + (add-octets buffer sink :start start :end end)) + cbuf) + (sink-buffer sink))) + + +;;; HTTP headers + +(defclass header () + ((data + :initarg :data + :accessor data) + (status + :initarg :status + :accessor status) + (name-starts + :initarg :name-starts + :accessor name-starts) + (name-ends + :initarg :name-ends + :accessor name-ends) + (value-starts + :initarg :value-starts + :accessor value-starts) + (value-ends + :initarg :value-ends + :accessor value-ends))) + +(defmethod print-object ((header header) stream) + (print-unreadable-object (header stream :type t) + (prin1 (status header) stream))) + +(defun matches-at (pattern target pos) + (= (mismatch pattern target :start2 pos) (length pattern))) + +(defun header-value-indexes (field-name header) + (loop with data = (data header) + with pattern = (ascii-vector (string-downcase field-name)) + for start across (name-starts header) + for i from 0 + when (matches-at pattern data start) + return (values (aref (value-starts header) i) + (aref (value-ends header) i)))) + +(defun ascii-header-value (field-name header) + (multiple-value-bind (start end) + (header-value-indexes field-name header) + (when start + (ascii-subseq (data header) start end)))) + +(defun all-field-names (header) + (map 'list + (lambda (start end) + (ascii-subseq (data header) start end)) + (name-starts header) + (name-ends header))) + +(defun headers-alist (header) + (mapcar (lambda (name) + (cons name (ascii-header-value name header))) + (all-field-names header))) + +(defmethod describe-object :after ((header header) stream) + (format stream "~&Decoded headers:~% ~S~%" (headers-alist header))) + +(defun content-length (header) + (let ((field-value (ascii-header-value "content-length" header))) + (when field-value + (let ((value (ignore-errors (parse-integer field-value)))) + (or value + (error "Content-Length header field value is not a number -- ~A" + field-value)))))) + +(defun chunkedp (header) + (string= (ascii-header-value "transfer-encoding" header) "chunked")) + +(defun location (header) + (ascii-header-value "location" header)) + +(defun status-code (vector) + (let* ((space (position (acode #\Space) vector)) + (c1 (- (aref vector (incf space)) 48)) + (c2 (- (aref vector (incf space)) 48)) + (c3 (- (aref vector (incf space)) 48))) + (+ (* c1 100) + (* c2 10) + (* c3 1)))) + +(defun force-downcase-field-names (header) + (loop with data = (data header) + for start across (name-starts header) + for end across (name-ends header) + do (loop for i from start below end + for code = (aref data i) + do (setf (aref data i) (ascii-downcase code))))) + +(defun skip-white-forward (pos vector) + (position-if-not 'whitep vector :start pos)) + +(defun skip-white-backward (pos vector) + (let ((nonwhite (position-if-not 'whitep vector :end pos :from-end t))) + (if nonwhite + (1+ nonwhite) + pos))) + +(defun contract-field-value-indexes (header) + "Header field values exclude leading and trailing whitespace; adjust +the indexes in the header accordingly." + (loop with starts = (value-starts header) + with ends = (value-ends header) + with data = (data header) + for i from 0 + for start across starts + for end across ends + do + (setf (aref starts i) (skip-white-forward start data)) + (setf (aref ends i) (skip-white-backward end data)))) + +(defun next-line-pos (vector) + (let ((pos 0)) + (labels ((finish (&optional (i pos)) + (return-from next-line-pos i)) + (after-cr (code) + (acase code + (:lf (finish pos)) + (t (finish (1- pos))))) + (pending (code) + (acase code + (:cr #'after-cr) + (:lf (finish pos)) + (t #'pending)))) + (let ((state #'pending)) + (loop + (setf state (funcall state (aref vector pos))) + (incf pos)))))) + +(defun make-hvector () + (make-array 16 :fill-pointer 0 :adjustable t)) + +(defun process-header (vector) + "Create a HEADER instance from the octet data in VECTOR." + (let* ((name-starts (make-hvector)) + (name-ends (make-hvector)) + (value-starts (make-hvector)) + (value-ends (make-hvector)) + (header (make-instance 'header + :data vector + :status 999 + :name-starts name-starts + :name-ends name-ends + :value-starts value-starts + :value-ends value-ends)) + (mark nil) + (pos (next-line-pos vector))) + (unless pos + (error "Unable to process HTTP header")) + (setf (status header) (status-code vector)) + (labels ((save (value vector) + (vector-push-extend value vector)) + (mark () + (setf mark pos)) + (clear-mark () + (setf mark nil)) + (finish () + (if mark + (save mark value-ends) + (save pos value-ends)) + (force-downcase-field-names header) + (contract-field-value-indexes header) + (return-from process-header header)) + (in-new-line (code) + (acase code + ((#\Tab #\Space) (setf mark nil) #'in-value) + (t + (when mark + (save mark value-ends)) + (clear-mark) + (save pos name-starts) + (in-name code)))) + (after-cr (code) + (acase code + (:lf #'in-new-line) + (t (in-new-line code)))) + (in-name (code) + (acase code + (#\: + (save pos name-ends) + (save (1+ pos) value-starts) + #'in-value) + ((:cr :lf) + (finish)) + ((#\Tab #\Space) + (error "Unexpected whitespace in header field name")) + (t + (unless (<= 0 code 127) + (error "Unexpected non-ASCII header field name")) + #'in-name))) + (in-value (code) + (acase code + (:lf (mark) #'in-new-line) + (:cr (mark) #'after-cr) + (t #'in-value)))) + (let ((state #'in-new-line)) + (loop + (incf pos) + (when (<= (length vector) pos) + (error "No header found in response")) + (setf state (funcall state (aref vector pos)))))))) + + +;;; HTTP URL parsing + +(defclass url () + ((scheme + :initarg :scheme + :accessor scheme + :initform nil) + (hostname + :initarg :hostname + :accessor hostname + :initform nil) + (port + :initarg :port + :accessor port + :initform nil) + (path + :initarg :path + :accessor path + :initform "/"))) + +(defun parse-urlstring (urlstring) + (setf urlstring (string-trim " " urlstring)) + (let* ((pos (position #\: urlstring)) + (scheme (or (and pos (subseq urlstring 0 pos)) "http")) + (pos (mismatch urlstring "://" :test 'char-equal :start1 pos)) + (mark pos) + (url (make-instance 'url))) + (setf (scheme url) scheme) + (labels ((save () + (subseq urlstring mark pos)) + (mark () + (setf mark pos)) + (finish () + (return-from parse-urlstring url)) + (hostname-char-p (char) + (position char "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." + :test 'char-equal)) + (at-start (char) + (case char + (#\/ + (setf (port url) nil) + (mark) + #'in-path) + (t + #'in-host))) + (in-host (char) + (case char + ((#\/ :end) + (setf (hostname url) (save)) + (mark) + #'in-path) + (#\: + (setf (hostname url) (save)) + (mark) + #'in-port) + (t + (unless (hostname-char-p char) + (error "~S is not a valid URL" urlstring)) + #'in-host))) + (in-port (char) + (case char + ((#\/ :end) + (setf (port url) + (parse-integer urlstring + :start (1+ mark) + :end pos)) + (mark) + #'in-path) + (t + (unless (digit-char-p char) + (error "Bad port in URL ~S" urlstring)) + #'in-port))) + (in-path (char) + (case char + ((#\# :end) + (setf (path url) (save)) + (finish))) + #'in-path)) + (let ((state #'at-start)) + (loop + (when (<= (length urlstring) pos) + (funcall state :end) + (finish)) + (setf state (funcall state (aref urlstring pos))) + (incf pos)))))) + +(defun url (thing) + (if (stringp thing) + (parse-urlstring thing) + thing)) + +(defgeneric request-buffer (method url) + (:method (method url) + (setf url (url url)) + (make-request-buffer (hostname url) (or (port url) 80) (path url) + :method method))) + +(defun urlstring (url) + (format nil "~@[~A://~]~@[~A~]~@[:~D~]~A" + (and (hostname url) (scheme url)) + (hostname url) + (port url) + (path url))) + +(defmethod print-object ((url url) stream) + (print-unreadable-object (url stream :type t) + (prin1 (urlstring url) stream))) + +(defun merge-urls (url1 url2) + (setf url1 (url url1)) + (setf url2 (url url2)) + (make-instance 'url + :scheme (or (scheme url1) + (scheme url2)) + :hostname (or (hostname url1) + (hostname url2)) + :port (or (port url1) + (port url2)) + :path (or (path url1) + (path url2)))) + + +;;; Requesting an URL and saving it to a file + +(defparameter *maximum-redirects* 10) +(defvar *default-url-defaults* (url "http://src.quicklisp.org/")) + +(defun read-http-header (cbuf) + (let ((header-data (sink-until-matching (list (acode-matcher :lf :lf) + (acode-matcher :cr :cr) + (acode-matcher :cr :lf :cr :lf)) + cbuf))) + (process-header header-data))) + +(defun read-chunk-header (cbuf) + (let* ((header-data (sink-until-matching (acode-matcher :cr :lf) cbuf)) + (end (or (position (acode :cr) header-data) + (position (acode #\;) header-data)))) + (values (parse-integer (ascii-subseq header-data 0 end) :radix 16)))) + +(defun save-chunk-response (stream cbuf) + "For a chunked response, read all chunks and write them to STREAM." + (let ((fun (make-stream-writer stream)) + (matcher (acode-matcher :cr :lf))) + (loop + (let ((chunk-size (read-chunk-header cbuf))) + (when (zerop chunk-size) + (return)) + (call-for-n-octets chunk-size fun cbuf) + (skip-until-matching matcher cbuf))))) + +(defun save-response (file header cbuf &key (if-exists :rename-and-delete)) + (with-open-file (stream file + :direction :output + :if-exists if-exists + :element-type 'octet) + (let ((content-length (content-length header))) + (cond ((chunkedp header) + (save-chunk-response stream cbuf)) + (content-length + (call-for-n-octets content-length + (make-stream-writer stream) + cbuf)) + (t + (call-until-end (make-stream-writer stream) cbuf)))))) + +(defun call-with-progress-bar (size fun) + (let ((progress-bar (make-progress-bar size))) + (start-display progress-bar) + (flet ((update (condition) + (update-progress progress-bar + (cbuf-progress-size condition)))) + (handler-bind ((cbuf-progress #'update)) + (funcall fun))) + (finish-display progress-bar))) + +(define-condition fetch-error (error) ()) + +(define-condition unexpected-http-status (fetch-error) + ((status-code + :initarg :status-code + :reader unexpected-http-status-code) + (url + :initarg :url + :reader unexpected-http-status-url)) + (:report + (lambda (condition stream) + (format stream "Unexpected HTTP status for ~A: ~A" + (unexpected-http-status-url condition) + (unexpected-http-status-code condition))))) + +(define-condition too-many-redirects (fetch-error) + ((url + :initarg :url + :reader too-many-redirects-url) + (redirect-count + :initarg :redirect-count + :reader too-many-redirects-count)) + (:report + (lambda (condition stream) + (format stream "Too many redirects (~:D) for ~A" + (too-many-redirects-count condition) + (too-many-redirects-url condition))))) + +(defvar *fetch-scheme-functions* + '(("http" . http-fetch)) + "assoc list to decide which scheme-function are called by FETCH function.") + +(defun fetch (url file &rest rest) + "Request URL and write the body of the response to FILE." + (let* ((url (merge-urls url *default-url-defaults*)) + (call (cdr (assoc (scheme url) *fetch-scheme-functions* :test 'equal)))) + (if call + (apply call (urlstring url) file rest) + (error "Unknown scheme ~S" url)))) + +(defun http-fetch (url file &key (follow-redirects t) quietly + (if-exists :rename-and-delete) + (maximum-redirects *maximum-redirects*)) + "default scheme-function for http protocol." + (setf url (merge-urls url *default-url-defaults*)) + (setf file (merge-pathnames file)) + (let ((redirect-count 0) + (original-url url) + (connect-url (or (url *proxy-url*) url)) + (stream (if quietly + (make-broadcast-stream) + *trace-output*))) + (loop + (when (<= maximum-redirects redirect-count) + (error 'too-many-redirects + :url original-url + :redirect-count redirect-count)) + (with-connection (connection (hostname connect-url) (or (port connect-url) 80)) + (let ((cbuf (make-instance 'cbuf :connection connection)) + (request (request-buffer "GET" url))) + (write-octets request connection) + (let ((header (read-http-header cbuf))) + (loop while (= (status header) 100) + do (setf header (read-http-header cbuf))) + (cond ((= (status header) 200) + (let ((size (content-length header))) + (format stream "~&; Fetching ~A~%" url) + (if (and (numberp size) + (plusp size)) + (format stream "; ~$KB~%" (/ size 1024)) + (format stream "; Unknown size~%")) + (if quietly + (save-response file header cbuf + :if-exists if-exists) + (call-with-progress-bar + (content-length header) + (lambda () + (save-response file header cbuf + :if-exists if-exists)))))) + ((not (<= 300 (status header) 399)) + (error 'unexpected-http-status + :url url + :status-code (status header)))) + (if (and follow-redirects (<= 300 (status header) 399)) + (let ((new-urlstring (ascii-header-value "location" header))) + (when (not new-urlstring) + (error "Redirect code ~D received, but no Location: header" + (status header))) + (incf redirect-count) + (setf url (merge-urls new-urlstring + url)) + (format stream "~&; Redirecting to ~A~%" url)) + (return (values header (and file (probe-file file))))))))))) diff --git a/sbcl/.quicklisp/quicklisp/impl-util.lisp b/sbcl/.quicklisp/quicklisp/impl-util.lisp new file mode 100644 index 0000000..654c217 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/impl-util.lisp @@ -0,0 +1,340 @@ +;;;; impl-util.lisp + +(in-package #:ql-impl-util) + +(definterface call-with-quiet-compilation (fun) + (:documentation + "Call FUN with warnings, style-warnings, and other verbose messages + suppressed.") + (:implementation t + (let ((*load-verbose* nil) + (*compile-verbose* nil) + (*load-print* nil) + (*compile-print* nil)) + (handler-bind ((warning #'muffle-warning)) + (funcall fun))))) + +(defimplementation (call-with-quiet-compilation :for sbcl :qualifier :around) + (fun) + (declare (ignore fun)) + (handler-bind ((ql-sbcl:compiler-note #'muffle-warning)) + (call-next-method))) + +(defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around) + (fun) + (declare (ignore fun)) + (let ((ql-cmucl:*gc-verbose* nil)) + (call-next-method))) + +(definterface rename-directory (from to) + (:implementation t + (rename-file from to) + (truename to)) + (:implementation cmucl + (rename-file from (string-right-trim "/" (namestring to))) + (truename to)) + (:implementation clisp + (ql-clisp:rename-directory from to) + (truename to))) + +(definterface probe-directory (pathname) + (:documentation "Return the truename of PATHNAME, if it exists and + is a directory, or NIL otherwise.") + (:implementation t + (let ((directory (probe-file pathname))) + (when directory + ;; probe-file is specified to return the truename of the path, + ;; but Allegro does not return the truename; truenamize it. + (truename directory)))) + (:implementation clisp + (let ((directory (ql-clisp:probe-pathname pathname))) + (when (and directory (ql-clisp:probe-directory directory)) + directory)))) + +(definterface init-file-name () + (:documentation "Return the init file name for the current implementation.") + (:implementation allegro + ".clinit.cl") + (:implementation abcl + ".abclrc") + (:implementation ccl + #+windows + "ccl-init.lisp" + #-windows + ".ccl-init.lisp") + (:implementation clasp + ".clasprc") + (:implementation clisp + ".clisprc.lisp") + (:implementation ecl + ".eclrc") + (:implementation mkcl + ".mkclrc") + (:implementation lispworks + ".lispworks") + (:implementation sbcl + ".sbclrc") + (:implementation cmucl + ".cmucl-init.lisp") + (:implementation scl + ".scl-init.lisp") + ) + +(defun init-file-name-for (&optional implementation-designator) + (let* ((class-name (find-symbol (string-upcase implementation-designator) + 'ql-impl)) + (class (find-class class-name nil))) + (when class + (let ((*implementation* (make-instance class))) + (init-file-name))))) + +(defun quicklisp-init-file-form () + "Return a form suitable for describing the location of the quicklisp + init file. If the file is available relative to the home directory, + returns a form that merges with the home directory instead of + specifying an absolute file." + (let* ((init-file (ql-setup:qmerge "setup.lisp")) + (enough (enough-namestring init-file (user-homedir-pathname)))) + (cond ((equal (pathname enough) (pathname init-file)) + ;; The init-file is somewhere outside of the home directory + (pathname enough)) + (t + `(merge-pathnames ,enough (user-homedir-pathname)))))) + +(defun write-init-forms (stream &key (indentation 0)) + (format stream "~%~v@T;;; The following lines added by ql:add-to-init-file:~%" + indentation) + (format stream "~v@T#-quicklisp~%" indentation) + (let ((*print-case* :downcase)) + (format stream "~v@T(let ((quicklisp-init ~S))~%" + indentation + (quicklisp-init-file-form))) + (format stream "~v@T (when (probe-file quicklisp-init)~%" indentation) + (format stream "~v@T (load quicklisp-init)))~%~%" indentation)) + +(defun suitable-lisp-init-file (implementation) + "Return the name of IMPLEMENTATION's init file. If IMPLEMENTAION is +a string or pathname, return its merged pathname instead." + (typecase implementation + ((or string pathname) + (merge-pathnames implementation)) + ((or null (eql t)) + (init-file-name)) + (t + (init-file-name-for implementation)))) + +(defun add-to-init-file (&optional implementation-or-file) + "Add forms to the Lisp implementation's init file that will load +quicklisp at CL startup." + (let ((init-file (suitable-lisp-init-file implementation-or-file))) + (unless init-file + (error "Don't know how to add to init file for your implementation.")) + (setf init-file (merge-pathnames init-file (user-homedir-pathname))) + (format *query-io* "~&I will append the following lines to ~S:~%" + init-file) + (write-init-forms *query-io* :indentation 2) + (when (ql-util:press-enter-to-continue) + (with-open-file (stream init-file + :direction :output + :if-does-not-exist :create + :if-exists :append) + (write-init-forms stream))) + init-file)) + + + +;;; +;;; Native namestrings. +;;; + +(definterface native-namestring (pathname) + (:documentation "In Clozure CL, #\\.s in pathname-names are escaped + in namestrings with #\\> on Windows and #\\\\ elsewhere. This can + cause a problem when using CL:NAMESTRING to store pathname data that + might be used by other implementations. NATIVE-NAMESTRING is + intended to provide a namestring that can be parsed as a same-enough + object on multiple implementations.") + (:implementation t + (namestring pathname)) + (:implementation ccl + (ql-ccl:native-translated-namestring pathname)) + (:implementation sbcl + (ql-sbcl:native-namestring pathname))) + + +;;; +;;; Directory write date +;;; + +(definterface directory-write-date (pathname) + (:documentation "Return the write-date of the directory designated + by PATHNAME as a universal time, like file-write-date.") + (:implementation t + (file-write-date pathname)) + (:implementation clisp + (nth-value 2 (ql-clisp:probe-pathname pathname)))) + + +;;; +;;; Deleting a directory tree +;;; + +(defvar *wild-entry* + (make-pathname :name :wild :type :wild :version :wild)) + +(defvar *wild-relative* + (make-pathname :directory '(:relative :wild))) + +(definterface directoryp (entry) + (:documentation "Return true if ENTRY refers to a directory.") + (:implementation t + (not (or (pathname-name entry) + (pathname-type entry)))) + (:implementation allegro + (ql-allegro:file-directory-p entry)) + (:implementation lispworks + (ql-lispworks:file-directory-p entry))) + +(definterface directory-entries (directory) + (:documentation "Return all directory entries of DIRECTORY as a + list, or NIL if there are no directory entries. Excludes the \".\" + and \"..\" entries.") + (:implementation allegro + (directory directory + #+allegro :directories-are-files + #+allegro nil + #+allegro :follow-symbolic-links + #+allegro nil)) + (:implementation abcl + (directory (merge-pathnames *wild-entry* directory) + #+abcl :resolve-symlinks #+abcl nil)) + (:implementation ccl + (directory (merge-pathnames *wild-entry* directory) + #+ccl :directories #+ccl t + #+ccl :follow-links #+ccl nil)) + (:implementation clasp + (nconc + (directory (merge-pathnames *wild-entry* directory) + #+clasp :resolve-symlinks #+clasp nil) + (directory (merge-pathnames *wild-relative* directory) + #+clasp :resolve-symlinks #+clasp nil))) + (:implementation clisp + ;; :full gives pathnames as well as truenames, BUT: it returns a + ;; singleton pathname, not a list, on dead symlinks. + (remove nil + (mapcar (lambda (entry) (and (listp entry) (first entry))) + (nconc (directory (merge-pathnames *wild-entry* directory) + #+clisp :full #+clisp t + #+clisp :if-does-not-exist #+clisp :keep) + (directory (merge-pathnames *wild-relative* directory) + #+clisp :full #+clisp t + #+clisp :if-does-not-exist #+clisp :keep))))) + (:implementation cmucl + (directory (merge-pathnames *wild-entry* directory) + #+cmucl :truenamep #+cmucl nil)) + (:implementation scl + (directory (merge-pathnames *wild-entry* directory) + #+scl :truenamep #+scl nil)) + (:implementation lispworks + (directory (merge-pathnames *wild-entry* directory) + #+lispworks :directories #+lispworks t + #+lispworks :link-transparency #+lispworks nil)) + (:implementation ecl + (nconc + (directory (merge-pathnames *wild-entry* directory) + #+ecl :resolve-symlinks #+ecl nil) + (directory (merge-pathnames *wild-relative* directory) + #+ecl :resolve-symlinks #+ecl nil))) + (:implementation mkcl + (setf directory (truename directory)) + (nconc + (directory (merge-pathnames *wild-entry* directory)) + (directory (merge-pathnames *wild-relative* directory)))) + (:implementation sbcl + (directory (merge-pathnames *wild-entry* directory) + #+sbcl :resolve-symlinks #+sbcl nil))) + +(defimplementation (directory-entries :qualifier :around) (directory) + ;; Don't return any entries when called with a non-directory + ;; argument + (if (directoryp directory) + (call-next-method) + (warn "directory-entries - not a directory -- ~S" directory))) + +(definterface delete-directory (entry) + (:documentation "Delete the directory ENTRY. Might signal an error + if it is not an empty directory.") + (:implementation t + (delete-file entry)) + (:implementation allegro + (ql-allegro:delete-directory entry)) + (:implementation ccl + (ql-ccl:delete-directory entry)) + (:implementation clasp + (ql-clasp:rmdir entry)) + (:implementation clisp + (ql-clisp:delete-directory entry)) + (:implementation cmucl + (ql-cmucl:unix-rmdir (namestring entry))) + (:implementation scl + (ql-scl:unix-rmdir (ql-scl:unix-namestring entry))) + (:implementation ecl + (ql-ecl:rmdir entry)) + (:implementation mkcl + (ql-mkcl:rmdir entry)) + (:implementation lispworks + (ql-lispworks:delete-directory entry)) + (:implementation sbcl + (ql-sbcl:rmdir entry))) + +(defimplementation (delete-directory :qualifier :around) (directory) + ;; Don't delete non-directories with delete-directory + (if (directoryp directory) + (call-next-method) + (error "delete-directory - not a directory -- ~A" directory))) + +(definterface delete-directory-tree (pathname) + (:documentation "Delete the directory tree rooted at PATHNAME.") + (:implementation t + (let ((directories-to-process (list (truename pathname))) + (directories-to-delete '())) + (loop + (unless directories-to-process + (return)) + (let* ((current (pop directories-to-process)) + (entries (directory-entries current))) + (push current directories-to-delete) + (dolist (entry entries) + (if (directoryp entry) + (push entry directories-to-process) + (delete-file entry))))) + (map nil 'delete-directory directories-to-delete))) + (:implementation allegro + (ql-allegro:delete-directory-and-files pathname)) + (:implementation ccl + (ql-ccl:delete-directory pathname))) + +(defimplementation (delete-directory-tree :qualifier :around) (pathname) + (if (directoryp pathname) + (call-next-method) + (progn + (warn "delete-directory-tree - not a directory, ~ + deleting anyway -- ~s" pathname) + (delete-file pathname)))) + +(defun map-directory-tree (directory fun) + "Call FUN for every file in directory and all its subdirectories, +recursively. Uses the truename of directory as a starting point. Does +not follow symlinks, but, on some implementations, DOES include +potentially dead symlinks." + (let ((directories-to-process (list (truename directory)))) + (loop + (unless directories-to-process + (return)) + (let* ((current (pop directories-to-process)) + (entries (directory-entries current))) + (dolist (entry entries) + (if (directoryp entry) + (push entry directories-to-process) + (funcall fun entry))))))) + diff --git a/sbcl/.quicklisp/quicklisp/impl.lisp b/sbcl/.quicklisp/quicklisp/impl.lisp new file mode 100644 index 0000000..8411375 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/impl.lisp @@ -0,0 +1,301 @@ +(in-package #:ql-impl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun error-unimplemented (&rest args) + (declare (ignore args)) + (error "Not implemented"))) + +(defvar *interfaces* (make-hash-table) + "A table of defined interfaces and their documentation.") + +(defun show-interfaces () + "Display information about what interfaces are defined." + (maphash (lambda (interface info) + (destructuring-bind (arguments docstring) + info + (let ((*package* (find-package :keyword))) + (format t "(~S ~:[()~;~:*~A~]~@[~% ~S~])~%" + interface arguments docstring)))) + *interfaces*)) + +(defmacro neuter-package (name) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((definition (fdefinition 'error-unimplemented))) + (do-external-symbols (symbol ,(string name)) + (unless (fboundp symbol) + (setf (fdefinition symbol) definition)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun feature-expression-passes-p (expression) + (cond ((keywordp expression) + (member expression *features*)) + ((consp expression) + (case (first expression) + (or + (some 'feature-expression-passes-p (rest expression))) + (and + (every 'feature-expression-passes-p (rest expression))))) + (t (error "Unrecognized feature expression -- ~S" expression))))) + + +(defmacro define-implementation-package (feature package-name &rest options) + (let* ((output-options '((:use) + (:export #:lisp))) + (prep (cdr (assoc :prep options))) + (class-option (cdr (assoc :class options))) + (class (first class-option)) + (superclasses (rest class-option)) + (import-options '()) + (effectivep (feature-expression-passes-p feature))) + (dolist (option options) + (ecase (first option) + ((:prep :class)) + ((:import-from + :import) + (push option import-options)) + ((:export + :shadow + :intern + :documentation) + (push option output-options)) + ((:reexport-from) + (push (cons :export (cddr option)) output-options) + (push (cons :import-from (cdr option)) import-options)))) + `(progn + ,@(when effectivep + `((eval-when (:compile-toplevel :load-toplevel :execute) + ,@prep))) + (defclass ,class ,superclasses ()) + (defpackage ,package-name ,@output-options + ,@(when effectivep + import-options)) + ,@(when effectivep + `((setf *implementation* (make-instance ',class)))) + ,@(unless effectivep + `((neuter-package ,package-name)))))) + +(defmacro definterface (name lambda-list &body options) + (let* ((doc-option (find :documentation options :key #'first)) + (doc (second doc-option))) + (setf (gethash name *interfaces*) (list lambda-list doc))) + (let* ((forbidden (intersection lambda-list lambda-list-keywords)) + (gf-options (remove :implementation options :key #'first)) + (implementations (set-difference options gf-options)) + (implementation-arg (copy-symbol '%implementation))) + (when forbidden + (error "~S not allowed in definterface lambda list" forbidden)) + (flet ((method-option (class body) + `(:method ((,implementation-arg ,class) ,@lambda-list) + ,@body))) + (let ((generic-name (intern (format nil "%~A" name)))) + `(progn + (defgeneric ,generic-name (lisp ,@lambda-list) + ,@gf-options + ,@(mapcan (lambda (implementation) + (destructuring-bind (class &rest body) + (rest implementation) + (mapcar (lambda (class) + (method-option class body)) + (if (consp class) + class + (list class))))) + implementations)) + (defun ,name ,lambda-list + (,generic-name *implementation* ,@lambda-list))))))) + +(defmacro defimplementation (name-and-options + lambda-list &body body) + (destructuring-bind (name &key (for t) qualifier) + (if (consp name-and-options) + name-and-options + (list name-and-options)) + (unless for + (error "You must specify an implementation name.")) + (let ((generic-name (find-symbol (format nil "%~A" name))) + (implementation-arg (copy-symbol '%implementation))) + (unless generic-name + (error "~S does not name an implementation function" name)) + `(defmethod ,generic-name + ,@(when qualifier (list qualifier)) + ,(list* `(,implementation-arg ,for) lambda-list) ,@body)))) + + +;;; Bootstrap implementations + +(defvar *implementation* nil) +(defclass lisp () ()) + + +;;; Allegro Common Lisp + +(define-implementation-package :allegro #:ql-allegro + (:documentation + "Allegro Common Lisp - http://www.franz.com/products/allegrocl/") + (:class allegro) + (:reexport-from #:socket + #:make-socket) + (:reexport-from #:excl + #:file-directory-p + #:delete-directory + #:delete-directory-and-files + #:read-vector)) + + +;;; Armed Bear Common Lisp + +(define-implementation-package :abcl #:ql-abcl + (:documentation + "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/") + (:class abcl) + (:reexport-from #:ext + #:make-socket + #:get-socket-stream)) + +;;; Clozure CL + +(define-implementation-package :ccl #:ql-ccl + (:documentation + "Clozure Common Lisp - http://www.clozure.com/clozurecl.html") + (:class ccl) + (:reexport-from #:ccl + #:delete-directory + #:make-socket + #:native-translated-namestring)) + +;;; CLASP + +(define-implementation-package :clasp #:ql-clasp + (:documentation "CLASP - http://github.com/drmeister/clasp") + (:class clasp) + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:si + #:rmdir + #:file-kind) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:host-ent-address + #:inet-socket + #:socket-connect + #:socket-make-stream)) + + +;;; GNU CLISP + +(define-implementation-package :clisp #:ql-clisp + (:documentation "GNU CLISP - http://clisp.cons.org/") + (:class clisp) + (:reexport-from #:socket + #:socket-connect) + (:reexport-from #:ext + #:delete-directory + #:rename-directory + #:probe-directory + #:probe-pathname + #:read-byte-sequence)) + + +;;; CMUCL + +(define-implementation-package :cmu #:ql-cmucl + (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/") + (:class cmucl) + (:reexport-from #:system + #:make-fd-stream) + (:reexport-from #:unix + #:unix-rmdir) + (:reexport-from #:extensions + #:connect-to-inet-socket + #:*gc-verbose*)) + +(defvar ql-cmucl:*gc-verbose*) + + +;;; Scieneer CL + +(define-implementation-package :scl #:ql-scl + (:documentation "Scieneer Common Lisp - http://www.scieneer.com/scl/") + (:class scl) + (:reexport-from #:system + #:make-fd-stream) + (:reexport-from #:unix + #:unix-rmdir) + (:reexport-from #:extensions + #:connect-to-inet-socket + #:unix-namestring)) + + +;;; LispWorks + +(define-implementation-package :lispworks #:ql-lispworks + (:documentation "LispWorks - http://www.lispworks.com/") + (:class lispworks) + (:prep + (require "comm")) + (:reexport-from #:lw + #:file-directory-p + #:delete-directory) + (:reexport-from #:comm + #:open-tcp-stream + #:get-host-entry)) + + +;;; ECL + +(define-implementation-package :ecl #:ql-ecl + (:documentation "ECL - http://ecls.sourceforge.net/") + (:class ecl) + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:si + #:rmdir + #:file-kind) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:host-ent-address + #:inet-socket + #:socket-connect + #:socket-make-stream)) + +;;; MKCL + +(define-implementation-package :mkcl #:ql-mkcl + (:documentation "ManKai Common Lisp - http://common-lisp.net/project/mkcl/") + (:class mkcl) + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:si + #:rmdir + #:file-kind) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:host-ent-address + #:inet-socket + #:socket-connect + #:socket-make-stream)) + + +;;; SBCL + +(define-implementation-package :sbcl #:ql-sbcl + (:class sbcl) + (:documentation + "Steel Bank Common Lisp - http://www.sbcl.org/") + (:prep + (require 'sb-posix) + (require 'sb-bsd-sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-posix + #:rmdir) + (:reexport-from #:sb-ext + #:compiler-note + #:native-namestring) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:inet-socket + #:host-ent-address + #:socket-connect + #:socket-make-stream)) diff --git a/sbcl/.quicklisp/quicklisp/local-projects.lisp b/sbcl/.quicklisp/quicklisp/local-projects.lisp new file mode 100644 index 0000000..a068c2e --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/local-projects.lisp @@ -0,0 +1,138 @@ +;;;; local-projects.lisp + +;;; +;;; Local project support. +;;; +;;; Local projects can be placed in /local-projects/. New +;;; entries in that directory are automatically scanned for system +;;; files for use with QL:QUICKLOAD. +;;; +;;; This works by keeping a cache of system file pathnames in +;;; /local-projects/system-index.txt. Whenever the +;;; timestamp on the local projects directory is newer than the +;;; timestamp on the system index file, the entire tree is re-scanned +;;; and cached. +;;; +;;; This will pick up system files that are created as a result of +;;; creating new project directory in /local-projects/, +;;; e.g. unpacking a tarball or zip file, checking out a project from +;;; version control, etc. It will NOT pick up a system file that is +;;; added sometime later in a subdirectory; for that, the +;;; REGISTER-LOCAL-PROJECTS function is needed to rebuild the system +;;; file index. +;;; +;;; In the event there are multiple systems of the same name in the +;;; directory tree, the one with the shortest pathname namestring is +;;; used. This is intended to ignore stuff like _darcs pristine +;;; directories. +;;; +;;; Work in progress! +;;; + +(in-package #:quicklisp-client) + +(defparameter *local-project-directories* + (list (qmerge "local-projects/")) + "The default local projects directory.") + +(defun system-index-file (pathname) + "Return the system index file for the directory PATHNAME." + (merge-pathnames "system-index.txt" pathname)) + +(defun matching-directory-files (directory fun) + (let ((result '())) + (map-directory-tree directory + (lambda (file) + (when (funcall fun file) + (push file result)))) + result)) + +(defun local-project-system-files (pathname) + "Return a list of system files under PATHNAME." + (let* ((files (matching-directory-files pathname + (lambda (file) + (equalp (pathname-type file) + "asd"))))) + (setf files (sort files + #'string< + :key #'namestring)) + (stable-sort files + #'< + :key (lambda (file) + (length (namestring file)))))) + +(defun make-system-index (pathname) + "Create a system index file for all system files under +PATHNAME. Current format is one native namestring per line." + (setf pathname (truename pathname)) + (with-open-file (stream (system-index-file pathname) + :direction :output + :if-exists :rename-and-delete) + (dolist (system-file (local-project-system-files pathname)) + (let ((system-path (enough-namestring system-file pathname))) + (write-line (native-namestring system-path) stream))) + (probe-file stream))) + +(defun find-valid-system-index (pathname) + "Find a valid system index file for PATHNAME; one that both exists +and has a newer timestamp than PATHNAME." + (let* ((file (system-index-file pathname)) + (probed (probe-file file))) + (when (and probed + (<= (directory-write-date pathname) + (file-write-date probed))) + probed))) + +(defun ensure-system-index (pathname) + "Find or create a system index file for PATHNAME." + (or (find-valid-system-index pathname) + (make-system-index pathname))) + +(defun find-system-in-index (system index-file) + "If any system pathname in INDEX-FILE has a pathname-name matching +SYSTEM, return its full pathname." + (with-open-file (stream index-file) + (loop for namestring = (read-line stream nil) + while namestring + when (string= system (pathname-name namestring)) + return (or (probe-file (merge-pathnames namestring index-file)) + ;; If the indexed .asd file doesn't exist anymore + ;; then regenerate the index and restart the search. + (find-system-in-index system (make-system-index (directory-namestring index-file))))))) + +(defun local-projects-searcher (system-name) + "This function is added to ASDF:*SYSTEM-DEFINITION-SEARCH-FUNCTIONS* +to use the local project directory and cache to find systems." + (dolist (directory *local-project-directories*) + (when (probe-directory directory) + (let ((system-index (ensure-system-index directory))) + (when system-index + (let ((system (find-system-in-index system-name system-index))) + (when system + (return system)))))))) + +(defun list-local-projects () + "Return a list of pathnames to local project system files." + (let ((result (make-array 16 :fill-pointer 0 :adjustable t)) + (seen (make-hash-table :test 'equal))) + (dolist (directory *local-project-directories* + (coerce result 'list)) + (let ((index (ensure-system-index directory))) + (when index + (with-open-file (stream index) + (loop for line = (read-line stream nil) + while line do + (let ((pathname (merge-pathnames line index))) + (unless (gethash (pathname-name pathname) seen) + (setf (gethash (pathname-name pathname) seen) t) + (vector-push-extend (merge-pathnames line index) + result)))))))))) + +(defun register-local-projects () + "Force a scan of the local projects directory to create the system +file index." + (map nil 'make-system-index *local-project-directories*)) + +(defun list-local-systems () + "Return a list of local project system names." + (mapcar #'pathname-name (list-local-projects))) diff --git a/sbcl/.quicklisp/quicklisp/minitar.lisp b/sbcl/.quicklisp/quicklisp/minitar.lisp new file mode 100644 index 0000000..49cde86 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/minitar.lisp @@ -0,0 +1,192 @@ +(in-package #:ql-minitar) + +(defconstant +block-size+ 512) +(defconstant +space-code+ 32) +(defconstant +newline-code+ 10) +(defconstant +equals-code+ 61) + +(defun make-block-buffer () + (make-array +block-size+ :element-type '(unsigned-byte 8) :initial-element 0)) + +(defun skip-n-blocks (n stream) + (let ((block (make-block-buffer))) + (dotimes (i n) + (read-sequence block stream)))) + +(defun read-octet-vector (length stream) + (let ((block (make-block-buffer)) + (vector (make-array length :element-type '(unsigned-byte 8))) + (offset 0) + (block-count (ceiling length +block-size+))) + (dotimes (i block-count) + (read-sequence block stream) + (replace vector block :start1 offset) + (incf offset +block-size+)) + vector)) + + +(defun decode-pax-header-record (vector offset) + "Decode VECTOR as pax extended header data. Returns the keyword and +value it specifies as multiple values." + ;; Vector format is: "%d %s=%s\n", , , + ;; See http://pubs.opengroup.org/onlinepubs/009695399/utilities/pax.html + (let* ((length-start offset) + (length-end (position +space-code+ vector :start length-start)) + (length-string (ascii-subseq vector length-start length-end)) + (length (parse-integer length-string)) + (keyword-start (1+ length-end)) + (keyword-end (position +equals-code+ vector :start keyword-start)) + (keyword (ascii-subseq vector keyword-start keyword-end)) + (value-start (1+ keyword-end)) + (value-end (1- (+ offset length))) + (value (ascii-subseq vector value-start value-end))) + (values keyword value (+ offset length)))) + +(defun decode-pax-header (vector) + "Decode VECTOR as a pax header and return it as an alist." + (let ((header nil) + (offset 0) + (length (length vector))) + (loop + (when (<= length offset) + (return header)) + (multiple-value-bind (keyword value new-offset) + (decode-pax-header-record vector offset) + (setf header (acons keyword value header)) + (setf offset new-offset))))) + +(defun pax-header-path (vector) + "Decode VECTOR as a pax header and return its 'path' value, if + any." + (let ((header-alist (decode-pax-header vector))) + (cdr (assoc "path" header-alist :test 'equal)))) + +(defun ascii-subseq (vector start end) + (let ((string (make-string (- end start)))) + (loop for i from 0 + for j from start below end + do (setf (char string i) (code-char (aref vector j)))) + string)) + +(defun block-asciiz-string (block start length) + (let* ((end (+ start length)) + (eos (or (position 0 block :start start :end end) + end))) + (ascii-subseq block start eos))) + +(defun prefix (header) + (when (plusp (aref header 345)) + (block-asciiz-string header 345 155))) + +(defun name (header) + (block-asciiz-string header 0 100)) + +(defun payload-size (header) + (values (parse-integer (block-asciiz-string header 124 12) :radix 8))) + +(defun nth-block (n file) + (with-open-file (stream file :element-type '(unsigned-byte 8)) + (let ((block (make-block-buffer))) + (skip-n-blocks (1- n) stream) + (read-sequence block stream) + block))) + +(defun payload-type (code) + (case code + (0 :file) + (48 :file) + (50 :symlink) + (76 :long-name) + (53 :directory) + (103 :global-header) + (120 :pax-extended-header) + (t :unsupported))) + +(defun full-path (header) + (let ((prefix (prefix header)) + (name (name header))) + (if prefix + (format nil "~A/~A" prefix name) + name))) + +(defun save-file (file size stream) + (multiple-value-bind (full-blocks partial) + (truncate size +block-size+) + (ensure-directories-exist file) + (with-open-file (outstream file + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (let ((block (make-block-buffer))) + (dotimes (i full-blocks) + (read-sequence block stream) + (write-sequence block outstream)) + (when (plusp partial) + (read-sequence block stream) + (write-sequence block outstream :end partial)))))) + +(defun gnu-long-name (size stream) + ;; GNU long names are simply the filename (null terminated) packed into the + ;; payload. + (let ((payload (read-octet-vector size stream))) + (ascii-subseq payload 0 (1- size)))) + +(defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*)) + (let ((block (make-block-buffer)) + (extended-path nil)) + (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) + (loop + (let ((size (read-sequence block stream))) + (when (zerop size) + (return)) + (unless (= size +block-size+) + (error "Bad size on tarfile")) + (when (every #'zerop block) + (return)) + (let* ((payload-code (aref block 156)) + (payload-type (payload-type payload-code)) + (tar-path (or (shiftf extended-path nil) + (full-path block))) + (full-path (merge-pathnames tar-path directory)) + (payload-size (payload-size block)) + (block-count (ceiling (payload-size block) +block-size+))) + (case payload-type + (:file + (save-file full-path payload-size stream)) + (:directory + (ensure-directories-exist full-path)) + ((:symlink :global-header) + ;; These block types aren't required for Quicklisp archives + (skip-n-blocks block-count stream)) + (:long-name + (setf extended-path (gnu-long-name payload-size stream))) + (:pax-extended-header + (let* ((pax-header-data (read-octet-vector payload-size stream)) + (path (pax-header-path pax-header-data))) + (when path + (setf extended-path path)))) + (t + (warn "Unknown tar block payload code -- ~D" payload-code) + (skip-n-blocks block-count stream))))))))) + +(defun contents (tarfile) + (let ((block (make-block-buffer)) + (result '())) + (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) + (loop + (let ((size (read-sequence block stream))) + (when (zerop size) + (return (nreverse result))) + (unless (= size +block-size+) + (error "Bad size on tarfile")) + (when (every #'zerop block) + (return (nreverse result))) + (let* ((payload-type (payload-type (aref block 156))) + (tar-path (full-path block)) + (payload-size (payload-size block))) + (skip-n-blocks (ceiling payload-size +block-size+) stream) + (case payload-type + (:file + (push tar-path result)) + (:directory + (push tar-path result))))))))) diff --git a/sbcl/.quicklisp/quicklisp/misc.lisp b/sbcl/.quicklisp/quicklisp/misc.lisp new file mode 100644 index 0000000..2cfabce --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/misc.lisp @@ -0,0 +1,19 @@ +;;;; misc.lisp + +(in-package #:quicklisp-client) + +;;; +;;; This stuff will probably end up somewhere else. +;;; + +(defun use-only-quicklisp-systems () + (asdf:initialize-source-registry + '(:source-registry :ignore-inherited-configuration)) + (asdf:map-systems 'asdf:clear-system) + t) + +(defun who-depends-on (system-name) + "Return a list of names of systems that depend on SYSTEM-NAME." + (loop for system in (provided-systems t) + when (member system-name (required-systems system) :test 'string=) + collect (name system))) diff --git a/sbcl/.quicklisp/quicklisp/network.lisp b/sbcl/.quicklisp/quicklisp/network.lisp new file mode 100644 index 0000000..d600fcc --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/network.lisp @@ -0,0 +1,137 @@ +;;; +;;; Low-level networking implementations +;;; + +(in-package #:ql-network) + +(definterface host-address (host) + (:implementation t + host) + (:implementation sbcl + (ql-sbcl:host-ent-address (ql-sbcl:get-host-by-name host)))) + +(definterface open-connection (host port) + (:documentation "Open and return a network connection to HOST on the + given PORT.") + (:implementation t + (declare (ignore host port)) + (error "Sorry, quicklisp in implementation ~S is not supported yet." + (lisp-implementation-type))) + (:implementation allegro + (ql-allegro:make-socket :remote-host host + :remote-port port)) + (:implementation abcl + (let ((socket (ql-abcl:make-socket host port))) + (ql-abcl:get-socket-stream socket :element-type '(unsigned-byte 8)))) + (:implementation ccl + (ql-ccl:make-socket :remote-host host + :remote-port port)) + (:implementation clasp + (let* ((endpoint (ql-clasp:host-ent-address + (ql-clasp:get-host-by-name host))) + (socket (make-instance 'ql-clasp:inet-socket + :protocol :tcp + :type :stream))) + (ql-clasp:socket-connect socket endpoint port) + (ql-clasp:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation clisp + (ql-clisp:socket-connect port host :element-type '(unsigned-byte 8))) + (:implementation cmucl + (let ((fd (ql-cmucl:connect-to-inet-socket host port))) + (ql-cmucl:make-fd-stream fd + :element-type '(unsigned-byte 8) + :binary-stream-p t + :input t + :output t))) + (:implementation scl + (let ((fd (ql-scl:connect-to-inet-socket host port))) + (ql-scl:make-fd-stream fd + :element-type '(unsigned-byte 8) + :input t + :output t))) + (:implementation ecl + (let* ((endpoint (ql-ecl:host-ent-address + (ql-ecl:get-host-by-name host))) + (socket (make-instance 'ql-ecl:inet-socket + :protocol :tcp + :type :stream))) + (ql-ecl:socket-connect socket endpoint port) + (ql-ecl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation mkcl + (let* ((endpoint (ql-mkcl:host-ent-address + (ql-mkcl:get-host-by-name host))) + (socket (make-instance 'ql-mkcl:inet-socket + :protocol :tcp + :type :stream))) + (ql-mkcl:socket-connect socket endpoint port) + (ql-mkcl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation lispworks + (ql-lispworks:open-tcp-stream host port + :direction :io + :errorp t + :read-timeout nil + :element-type '(unsigned-byte 8) + :timeout 5)) + (:implementation sbcl + (let* ((endpoint (ql-sbcl:host-ent-address + (ql-sbcl:get-host-by-name host))) + (socket (make-instance 'ql-sbcl:inet-socket + :protocol :tcp + :type :stream))) + (ql-sbcl:socket-connect socket endpoint port) + (ql-sbcl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full)))) + +(definterface read-octets (buffer connection) + (:documentation "Read from CONNECTION into BUFFER. Returns the + number of octets read.") + (:implementation t + (read-sequence buffer connection)) + (:implementation allegro + (ql-allegro:read-vector buffer connection)) + (:implementation clisp + (ql-clisp:read-byte-sequence buffer connection + :no-hang nil + :interactive t))) + +(definterface write-octets (buffer connection) + (:documentation "Write the contents of BUFFER to CONNECTION.") + (:implementation t + (write-sequence buffer connection) + (finish-output connection))) + +(definterface close-connection (connection) + (:implementation t + (ignore-errors (close connection)))) + +(definterface call-with-connection (host port fun) + (:documentation "Establish a network connection to HOST on PORT and + call FUN with that connection as the only argument. Unconditionally + closes the connection afterwareds via CLOSE-CONNECTION in an + unwind-protect. See also WITH-CONNECTION.") + (:implementation t + (let (connection) + (unwind-protect + (progn + (setf connection (open-connection host port)) + (funcall fun connection)) + (when connection + (close-connection connection)))))) + +(defmacro with-connection ((connection host port) &body body) + `(call-with-connection ,host ,port (lambda (,connection) ,@body))) diff --git a/sbcl/.quicklisp/quicklisp/package.lisp b/sbcl/.quicklisp/quicklisp/package.lisp new file mode 100644 index 0000000..da68cd2 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/package.lisp @@ -0,0 +1,340 @@ +;;;; package.lisp + +(defpackage #:ql-util + (:documentation + "Utility functions used in various places.") + (:use #:cl) + (:export #:write-line-to-file + #:without-prompting + #:press-enter-to-continue + #:replace-file + #:copy-file + #:delete-file-if-exists + #:ensure-file-exists + #:split-spaces + #:first-line + #:file-size + #:safely-read + #:safely-read-file + #:make-versions-url)) + +(defpackage #:ql-setup + (:documentation + "Functions and variables initialized early in the Quicklisp client + configuration.") + (:use #:cl) + (:export #:qmerge + #:qenough + #:*quicklisp-home*)) + +(defpackage #:ql-config + (:documentation + "Getting and setting persistent configuration values.") + (:use #:cl #:ql-util #:ql-setup) + (:export #:config-value)) + +(defpackage #:ql-impl + (:documentation + "Configuration of implementation-specific packages and interfaces.") + (:use #:cl) + (:export #:*implementation*) + (:export #:definterface + #:defimplementation + #:show-interfaces) + (:export #:lisp + #:abcl + #:allegro + #:ccl + #:clasp + #:clisp + #:cmucl + #:cormanlisp + #:ecl + #:gcl + #:lispworks + #:mkcl + #:scl + #:sbcl)) + +(defpackage #:ql-impl-util + (:documentation + "Utility functions that require implementation-specific + functionality.") + (:use #:cl #:ql-impl) + (:export #:call-with-quiet-compilation + #:add-to-init-file + #:rename-directory + #:delete-directory + #:probe-directory + #:directory-entries + #:delete-directory-tree + #:map-directory-tree + #:native-namestring + #:directory-write-date)) + +(defpackage #:ql-network + (:documentation + "Simple, low-level network access.") + (:use #:cl #:ql-impl) + (:export #:open-connection + #:write-octets + #:read-octets + #:close-connection + #:with-connection)) + +(defpackage #:ql-progress + (:documentation + "Displaying a progress bar.") + (:use #:cl) + (:export #:make-progress-bar + #:start-display + #:update-progress + #:finish-display)) + +(defpackage #:ql-http + (:documentation + "A simple HTTP client.") + (:use #:cl #:ql-network #:ql-progress #:ql-config) + (:export #:*proxy-url* + #:fetch + #:http-fetch + #:*fetch-scheme-functions* + #:scheme + #:hostname + #:port + #:path + #:url + #:*maximum-redirects* + #:*default-url-defaults*) + (:export #:fetch-error + #:unexpected-http-status + #:unexpected-http-status-code + #:unexpected-http-status-url + #:too-many-redirects + #:too-many-redirects-url + #:too-many-redirects-count)) + +(defpackage #:ql-minitar + (:documentation + "A simple implementation of unpacking the 'tar' file format.") + (:use #:cl) + (:export #:unpack-tarball)) + +(defpackage #:ql-gunzipper + (:documentation + "An implementation of gunzip.") + (:use #:cl) + (:export #:gunzip)) + +(defpackage #:ql-cdb + (:documentation + "Read and write CDB files; code adapted from ZCDB.") + (:use #:cl) + (:export #:lookup + #:map-cdb + #:convert-index-file)) + +(defpackage #:ql-dist + (:documentation + "Generic functions, variables, and classes for interacting with the + dist system. Documented, exported symbols are intended for public + use.") + (:use #:cl + #:ql-util + #:ql-http + #:ql-setup + #:ql-gunzipper + #:ql-minitar) + (:intern #:dist-version + #:dist-url) + (:import-from #:ql-impl-util + #:delete-directory-tree + #:directory-entries + #:probe-directory) + ;; Install/enable protocol + (:export #:installedp + #:install + #:uninstall + #:ensure-installed + #:enabledp + #:enable + #:disable) + ;; Preference protocol + (:export #:preference + #:preference-file + #:preference-parent + #:forget-preference) + ;; Generic + (:export #:all-dists + #:canonical-distinfo-url + #:enabled-dists + #:find-dist + #:find-dist-or-lose + #:find-system + #:find-release + #:dist + #:system + #:release + #:base-directory + #:relative-to + #:metadata-name + #:install-metadata-file + #:short-description + #:provided-releases + #:provided-systems + #:installed-releases + #:installed-systems + #:name) + ;; Dists + (:export #:dist + #:dist-merge + #:find-system-in-dist + #:find-release-in-dist + #:system-index-url + #:release-index-url + #:available-versions-url + #:available-versions + #:version + #:subscription-url + #:new-version-available-p + #:dist-difference + #:fetch-dist + #:initialize-release-index + #:initialize-system-index + #:with-consistent-dists) + ;; Dist updates + (:export #:available-update + #:update-release-differences + #:show-update-report + #:update-in-place + #:install-dist + #:subscription-inhibition-file + #:inhibit-subscription + #:uninhibit-subscription + #:subscription-inhibited-p + #:subscription-unavailable + #:subscribedp + #:subscribe + #:unsubscribe) + ;; Releases + (:export #:release + #:project-name + #:system-files + #:archive-url + #:archive-size + #:ensure-archive-file + #:archive-content-sha1 + #:archive-md5 + #:prefix + #:local-archive-file + #:ensure-local-archive-file + #:check-local-archive-file + #:invalid-local-archive + #:invalid-local-archive-file + #:invalid-local-archive-release + #:missing-local-archive + #:badly-sized-local-archive + #:delete-and-retry) + ;; Systems + (:export #:dist + #:release + #:preference + #:system-file-name + #:required-systems) + ;; Misc + (:export #:standard-dist-enumeration-function + #:*dist-enumeration-functions* + #:find-asdf-system-file + #:system-definition-searcher + #:system-apropos + #:system-apropos-list + #:dependency-tree + #:clean + #:unknown-dist)) + +(defpackage #:ql-dist-user + (:documentation + "A package that uses QL-DIST; useful for playing around in without + clobbering any QL-DIST internals.") + (:use #:cl + #:ql-dist)) + +(defpackage #:ql-bundle + (:documentation + "A package for supporting the QL:BUNDLE-SYSTEMS function.") + (:use #:cl #:ql-dist #:ql-impl-util) + (:shadow #:find-system + #:find-release) + (:export #:bundle + #:requested-systems + #:ensure-system + #:ensure-release + #:write-bundle + #:add-systems-recursively + #:object-not-found + #:system-not-found + #:system-not-found-system + #:release-not-found + #:bundle-directory-exists + #:bundle-directory-exists-directory)) + +(defpackage #:quicklisp-client + (:documentation + "The Quicklisp client package, intended for end-user Quicklisp + commands and configuration parameters.") + (:nicknames #:quicklisp #:ql) + (:use #:cl + #:ql-util + #:ql-impl-util + #:ql-dist + #:ql-http + #:ql-setup + #:ql-config + #:ql-minitar + #:ql-gunzipper) + (:shadow #:uninstall) + (:shadowing-import-from #:ql-dist + #:dist-version + #:dist-url) + (:export #:dist-version + #:dist-url) + (:export #:quickload + #:*quickload-prompt* + #:*quickload-verbose* + #:*quickload-explain* + #:system-not-found + #:system-not-found-name + #:uninstall + #:uninstall-dist + #:qmerge + #:*quicklisp-home* + #:*initial-dist-url* + #:*proxy-url* + #:config-value + #:setup + #:provided-systems + #:system-apropos + #:system-apropos-list + #:system-list + #:client-version + #:client-url + #:available-client-versions + #:install-client + #:update-client + #:update-dist + #:update-all-dists + #:available-dist-versions + #:add-to-init-file + #:use-only-quicklisp-systems + #:write-asdf-manifest-file + #:where-is-system + #:help + #:register-local-projects + #:local-projects-searcher + #:*local-project-directories* + #:list-local-projects + #:list-local-systems + #:who-depends-on + #:bundle-systems)) + +(in-package #:quicklisp-client) diff --git a/sbcl/.quicklisp/quicklisp/progress.lisp b/sbcl/.quicklisp/quicklisp/progress.lisp new file mode 100644 index 0000000..b4d57e2 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/progress.lisp @@ -0,0 +1,156 @@ +;;; +;;; A text progress bar +;;; + +(in-package #:ql-progress) + +(defclass progress-bar () + ((start-time + :initarg :start-time + :accessor start-time) + (end-time + :initarg :end-time + :accessor end-time) + (progress-character + :initarg :progress-character + :accessor progress-character) + (character-count + :initarg :character-count + :accessor character-count + :documentation "How many characters wide is the progress bar?") + (characters-so-far + :initarg :characters-so-far + :accessor characters-so-far) + (update-interval + :initarg :update-interval + :accessor update-interval + :documentation "Update the progress bar display after this many + internal-time units.") + (last-update-time + :initarg :last-update-time + :accessor last-update-time + :documentation "The display was last updated at this time.") + (total + :initarg :total + :accessor total + :documentation "The total number of units tracked by this progress bar.") + (progress + :initarg :progress + :accessor progress + :documentation "How far in the progress are we?") + (pending + :initarg :pending + :accessor pending + :documentation "How many raw units should be tracked in the next + display update?")) + (:default-initargs + :progress-character #\= + :character-count 50 + :characters-so-far 0 + :update-interval (floor internal-time-units-per-second 4) + :last-update-time 0 + :total 0 + :progress 0 + :pending 0)) + +(defgeneric start-display (progress-bar)) +(defgeneric update-progress (progress-bar unit-count)) +(defgeneric update-display (progress-bar)) +(defgeneric finish-display (progress-bar)) +(defgeneric elapsed-time (progress-bar)) +(defgeneric units-per-second (progress-bar)) + +(defmethod start-display (progress-bar) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (setf (start-time progress-bar) (get-internal-real-time)) + (fresh-line) + (finish-output)) + +(defmethod update-display (progress-bar) + (incf (progress progress-bar) (pending progress-bar)) + (setf (pending progress-bar) 0) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (let* ((showable (floor (character-count progress-bar) + (/ (total progress-bar) (progress progress-bar)))) + (needed (- showable (characters-so-far progress-bar)))) + (setf (characters-so-far progress-bar) showable) + (dotimes (i needed) + (write-char (progress-character progress-bar))) + (finish-output))) + +(defmethod update-progress (progress-bar unit-count) + (incf (pending progress-bar) unit-count) + (let ((now (get-internal-real-time))) + (when (< (update-interval progress-bar) + (- now (last-update-time progress-bar))) + (update-display progress-bar)))) + +(defmethod finish-display (progress-bar) + (update-display progress-bar) + (setf (end-time progress-bar) (get-internal-real-time)) + (terpri) + (format t "~:D bytes in ~$ seconds (~$KB/sec)~%" + (total progress-bar) + (elapsed-time progress-bar) + (/ (units-per-second progress-bar) 1024)) + (finish-output)) + +(defmethod elapsed-time (progress-bar) + (/ (- (end-time progress-bar) (start-time progress-bar)) + internal-time-units-per-second)) + +(defmethod units-per-second (progress-bar) + (if (plusp (elapsed-time progress-bar)) + (/ (total progress-bar) (elapsed-time progress-bar)) + 0)) + +(defun kb/sec (progress-bar) + (/ (units-per-second progress-bar) 1024)) + + + +(defparameter *uncertain-progress-chars* "?") + +(defclass uncertain-size-progress-bar (progress-bar) + ((progress-char-index + :initarg :progress-char-index + :accessor progress-char-index) + (units-per-char + :initarg :units-per-char + :accessor units-per-char)) + (:default-initargs + :total 0 + :progress-char-index 0 + :units-per-char (floor (expt 1024 2) 50))) + +(defmethod update-progress :after ((progress-bar uncertain-size-progress-bar) + unit-count) + (incf (total progress-bar) unit-count)) + +(defmethod progress-character ((progress-bar uncertain-size-progress-bar)) + (let ((index (progress-char-index progress-bar))) + (prog1 + (char *uncertain-progress-chars* index) + (setf (progress-char-index progress-bar) + (mod (1+ index) (length *uncertain-progress-chars*)))))) + +(defmethod update-display ((progress-bar uncertain-size-progress-bar)) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (multiple-value-bind (chars pend) + (floor (pending progress-bar) (units-per-char progress-bar)) + (setf (pending progress-bar) pend) + (dotimes (i chars) + (write-char (progress-character progress-bar)) + (incf (characters-so-far progress-bar)) + (when (<= (character-count progress-bar) + (characters-so-far progress-bar)) + (terpri) + (setf (characters-so-far progress-bar) 0) + (finish-output))) + (finish-output))) + +(defun make-progress-bar (total) + (if (or (not total) (zerop total)) + (make-instance 'uncertain-size-progress-bar) + (make-instance 'progress-bar :total total))) + diff --git a/sbcl/.quicklisp/quicklisp/quicklisp.asd b/sbcl/.quicklisp/quicklisp/quicklisp.asd new file mode 100644 index 0000000..158a1b4 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/quicklisp.asd @@ -0,0 +1,36 @@ +;;;; quicklisp.asd + +(defpackage #:ql-info + (:export #:*version*)) + +(defvar ql-info:*version* + (with-open-file (stream (merge-pathnames "version.txt" *load-truename*)) + (read-line stream))) + +(asdf:defsystem #:quicklisp + :description "The Quicklisp client application." + :author "Zach Beane " + :license "BSD-style" + :serial t + :version #.(remove-if-not #'digit-char-p ql-info:*version*) + :components ((:file "package") + (:file "utils") + (:file "config") + (:file "impl") + (:file "impl-util") + (:file "network") + (:file "progress") + (:file "http") + (:file "deflate") + (:file "minitar") + (:file "cdb") + (:file "dist") + (:file "setup") + (:file "client") + (:file "fetch-gzipped") + (:file "client-info") + (:file "client-update") + (:file "dist-update") + (:file "misc") + (:file "local-projects") + (:file "bundle"))) diff --git a/sbcl/.quicklisp/quicklisp/setup.lisp b/sbcl/.quicklisp/quicklisp/setup.lisp new file mode 100644 index 0000000..edbd4c6 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/setup.lisp @@ -0,0 +1,249 @@ +(in-package #:quicklisp) + +(defun show-wrapped-list (words &key (indent 4) (margin 60)) + (let ((*print-right-margin* margin) + (*print-pretty* t) + (*print-escape* nil) + (prefix (make-string indent :initial-element #\Space))) + (pprint-logical-block (nil words :per-line-prefix prefix) + (pprint-fill *standard-output* (sort (copy-seq words) #'string<) nil)) + (fresh-line) + (finish-output))) + +(defun recursively-install (name) + (labels ((recurse (name) + (let ((system (find-system name))) + (unless system + (error "Unknown system ~S" name)) + (ensure-installed system) + (mapcar #'recurse (required-systems system)) + name))) + (with-consistent-dists + (recurse name)))) + +(defclass load-strategy () + ((name + :initarg :name + :accessor name) + (asdf-systems + :initarg :asdf-systems + :accessor asdf-systems) + (quicklisp-systems + :initarg :quicklisp-systems + :accessor quicklisp-systems))) + +(defmethod print-object ((strategy load-strategy) stream) + (print-unreadable-object (strategy stream :type t) + (format stream "~S (~D asdf, ~D quicklisp)" + (name strategy) + (length (asdf-systems strategy)) + (length (quicklisp-systems strategy))))) + +(defgeneric quicklisp-releases (strategy) + (:method (strategy) + (remove-duplicates (mapcar 'release (quicklisp-systems strategy))))) + +(defgeneric quicklisp-release-table (strategy) + (:method ((strategy load-strategy)) + (let ((table (make-hash-table))) + (dolist (system (quicklisp-systems strategy)) + (push system (gethash (release system) table nil))) + table))) + +(define-condition system-not-found (error) + ((name + :initarg :name + :reader system-not-found-name)) + (:report (lambda (condition stream) + (format stream "System ~S not found" + (system-not-found-name condition)))) + (:documentation "This condition is signaled by QUICKLOAD when a + system given to load is not available via ASDF or a Quicklisp + dist.")) + +(defun compute-load-strategy (name) + (setf name (string-downcase name)) + (let ((asdf-systems '()) + (quicklisp-systems '())) + (labels ((recurse (name) + (let ((asdf-system (asdf:find-system name nil)) + (quicklisp-system (find-system name))) + (cond (asdf-system + (push asdf-system asdf-systems)) + (quicklisp-system + (push quicklisp-system quicklisp-systems) + (dolist (subname (required-systems quicklisp-system)) + (recurse subname))) + (t + (cerror "Try again" + 'system-not-found + :name name) + (recurse name)))))) + (with-consistent-dists + (recurse name))) + (make-instance 'load-strategy + :name name + :asdf-systems (remove-duplicates asdf-systems) + :quicklisp-systems (remove-duplicates quicklisp-systems)))) + +(defun show-load-strategy (strategy) + (format t "To load ~S:~%" (name strategy)) + (let ((asdf-systems (asdf-systems strategy)) + (releases (quicklisp-releases strategy))) + (when asdf-systems + (format t " Load ~D ASDF system~:P:~%" (length asdf-systems)) + (show-wrapped-list (mapcar 'asdf:component-name asdf-systems))) + (when releases + (format t " Install ~D Quicklisp release~:P:~%" (length releases)) + (show-wrapped-list (mapcar 'name releases))))) + +(defvar *macroexpand-progress-in-progress* nil) + +(defun macroexpand-progress-fun (old-hook &key (char #\.) + (chars-per-line 50) + (forms-per-char 250)) + (let ((output-so-far 0) + (seen-so-far 0)) + (labels ((finish-line () + (when (plusp output-so-far) + (dotimes (i (- chars-per-line output-so-far)) + (write-char char)) + (terpri) + (setf output-so-far 0))) + (show-string (string) + (let* ((length (length string)) + (new-output (+ length output-so-far))) + (cond ((< chars-per-line new-output) + (finish-line) + (write-string string) + (setf output-so-far length)) + (t + (write-string string) + (setf output-so-far new-output)))) + (finish-output)) + (show-package (name) + ;; Only show package markers when compiling. Showing + ;; them when loading shows a bunch of ASDF system + ;; package noise. + (when *compile-file-pathname* + (finish-line) + (show-string (format nil "[package ~(~A~)]" name))))) + (lambda (fun form env) + (when (and (consp form) + (eq (first form) 'cl:defpackage) + (ignore-errors (string (second form)))) + (show-package (second form))) + (incf seen-so-far) + (when (<= forms-per-char seen-so-far) + (setf seen-so-far 0) + (write-char char) + (finish-output) + (incf output-so-far) + (when (<= chars-per-line output-so-far) + (setf output-so-far 0) + (terpri) + (finish-output))) + (funcall old-hook fun form env))))) + +(defun call-with-macroexpand-progress (fun) + (let ((*macroexpand-hook* (if *macroexpand-progress-in-progress* + *macroexpand-hook* + (macroexpand-progress-fun *macroexpand-hook*))) + (*macroexpand-progress-in-progress* t)) + (funcall fun) + (terpri))) + +(defun apply-load-strategy (strategy) + (map nil 'ensure-installed (quicklisp-releases strategy)) + (call-with-macroexpand-progress + (lambda () + (format t "~&; Loading ~S~%" (name strategy)) + (asdf:load-system (name strategy) :verbose nil)))) + +(defun autoload-system-and-dependencies (name &key prompt) + "Try to load the system named by NAME, automatically loading any +Quicklisp-provided systems first, and catching ASDF missing +dependencies too if possible." + (setf name (string-downcase name)) + (with-simple-restart (abort "Give up on ~S" name) + (let ((tried-so-far (make-hash-table :test 'equalp))) + (tagbody + retry + (handler-case + (let ((strategy (compute-load-strategy name))) + (show-load-strategy strategy) + (when (or (not prompt) + (press-enter-to-continue)) + (apply-load-strategy strategy))) + (asdf:missing-dependency-of-version (c) + ;; Nothing Quicklisp can do to recover from this, so just + ;; resignal + (error c)) + (asdf:missing-dependency (c) + (let ((parent (asdf::missing-required-by c)) + (missing (asdf::missing-requires c))) + (typecase parent + ((or null asdf:system) + ;; NIL parent comes from :defsystem-depends-on failures + (if (gethash missing tried-so-far) + (error "Dependency looping -- already tried to load ~ + ~A" missing) + (setf (gethash missing tried-so-far) missing)) + (autoload-system-and-dependencies missing + :prompt prompt) + (go retry)) + (t + ;; Error isn't from a system dependency, so there's + ;; nothing to autoload + (error c)))))))) + name)) + +(defvar *initial-dist-url* + "http://beta.quicklisp.org/dist/quicklisp.txt") + +(defun dists-initialized-p () + (not (not (ignore-errors (truename (qmerge "dists/")))))) + +(defun quickstart-parameter (name &optional default) + (let* ((package (find-package '#:quicklisp-quickstart)) + (symbol (and package (find-symbol (string '#:*quickstart-parameters*) + package))) + (plist (and symbol (symbol-value symbol))) + (parameter (and plist (getf plist name)))) + (or parameter default))) + +(defun maybe-initial-setup () + "Run the steps needed when Quicklisp setup is run for the first time +after the quickstart installation." + (let ((quickstart-proxy-url (quickstart-parameter :proxy-url)) + (quickstart-initial-dist-url (quickstart-parameter :initial-dist-url))) + (when (and quickstart-proxy-url (not *proxy-url*)) + (setf *proxy-url* quickstart-proxy-url) + (setf (config-value "proxy-url") quickstart-proxy-url)) + (unless (dists-initialized-p) + (let ((target (qmerge "dists/quicklisp/distinfo.txt")) + (url (or quickstart-initial-dist-url + *initial-dist-url*))) + (ensure-directories-exist target) + (install-dist url :prompt nil))))) + +(defun setup () + (unless (member 'system-definition-searcher + asdf:*system-definition-search-functions*) + (setf asdf:*system-definition-search-functions* + (append asdf:*system-definition-search-functions* + (list 'local-projects-searcher + 'system-definition-searcher)))) + (let ((files (nconc (directory (qmerge "local-init/*.lisp")) + (directory (qmerge "local-init/*.cl"))))) + (with-simple-restart (abort "Stop loading local setup files") + (dolist (file (sort files #'string< :key #'pathname-name)) + (with-simple-restart (skip "Skip local setup file ~S" file) + ;; Don't try to load Emacs lock files, other hidden files + (unless (char= (char (pathname-name file) 0) + #\.) + (load file)))))) + (maybe-initial-setup) + (ensure-directories-exist (qmerge "local-projects/")) + (pushnew :quicklisp *features*) + t) diff --git a/sbcl/.quicklisp/quicklisp/utils.lisp b/sbcl/.quicklisp/quicklisp/utils.lisp new file mode 100644 index 0000000..71a89ef --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/utils.lisp @@ -0,0 +1,124 @@ +;;;; utils.lisp + +(in-package #:ql-util) + +(defun write-line-to-file (string file) + (with-open-file (stream file + :direction :output + :if-exists :supersede) + (write-line string stream))) + +(defvar *do-not-prompt* nil + "When *DO-NOT-PROMPT* is true, PRESS-ENTER-TO-CONTINUE returns true + without user interaction.") + +(defmacro without-prompting (&body body) + "Evaluate BODY in an environment where PRESS-ENTER-TO-CONTINUE + always returns true without prompting for the user to press enter." + `(let ((*do-not-prompt* t)) + ,@body)) + +(defun press-enter-to-continue () + (when *do-not-prompt* + (return-from press-enter-to-continue t)) + (format *query-io* "~&Press Enter to continue.~%") + (let ((result (read-line *query-io*))) + (zerop (length result)))) + +(defun replace-file (from to) + "Like RENAME-FILE, but deletes TO if it exists, first." + (when (probe-file to) + (delete-file to)) + (rename-file from to)) + +(defun copy-file (from to &key (if-exists :rename-and-delete)) + "Copy the file FROM to TO." + (let* ((buffer-size 8192) + (buffer (make-array buffer-size :element-type '(unsigned-byte 8)))) + (with-open-file (from-stream from :element-type '(unsigned-byte 8)) + (with-open-file (to-stream to :element-type '(unsigned-byte 8) + :direction :output + :if-exists if-exists) + (let ((length (file-length from-stream))) + (multiple-value-bind (full leftover) + (floor length buffer-size) + (dotimes (i full) + (read-sequence buffer from-stream) + (write-sequence buffer to-stream)) + (read-sequence buffer from-stream) + (write-sequence buffer to-stream :end leftover))))) + (probe-file to))) + +(defun ensure-file-exists (pathname) + (open pathname :direction :probe :if-does-not-exist :create)) + +(defun delete-file-if-exists (pathname) + (when (probe-file pathname) + (delete-file pathname))) + +(defun split-spaces (line) + (let ((words '()) + (mark 0) + (pos 0)) + (labels ((finish () + (setf pos (length line)) + (save) + (return-from split-spaces (nreverse words))) + (save () + (when (< mark pos) + (push (subseq line mark pos) words))) + (mark () + (setf mark pos)) + (in-word (char) + (case char + (#\Space + (save) + #'in-space) + (t + #'in-word))) + (in-space (char) + (case char + (#\Space + #'in-space) + (t + (mark) + #'in-word)))) + (let ((state #'in-word)) + (dotimes (i (length line) (finish)) + (setf pos i) + (setf state (funcall state (char line i)))))))) + +(defun first-line (file) + (with-open-file (stream file) + (values (read-line stream)))) + +(defun (setf first-line) (line file) + (with-open-file (stream file :direction :output + :if-exists :rename-and-delete) + (write-line line stream))) + +(defun file-size (file) + (with-open-file (stream file :element-type '(unsigned-byte 8)) + (file-length stream))) + +(defun safely-read (stream) + "Read one form from STREAM with *READ-EVAL* bound to NIL." + (let ((*read-eval* nil)) + (read stream))) + +(defun safely-read-file (file) + "Read the first form from FILE with SAFELY-READ." + (with-open-file (stream file) + (safely-read stream))) + +(defun make-versions-url (url) + "Given an URL that looks like http://foo/bar.ext, return +http://foo/bar-versions.txt." + (let ((suffix-pos (position #\. url :from-end t))) + (unless suffix-pos + (error "Can't make a versions URL from ~A" url)) + (let ((extension (subseq url suffix-pos))) + (concatenate 'string + (subseq url 0 suffix-pos) + "-versions" + extension)))) diff --git a/sbcl/.quicklisp/quicklisp/version.txt b/sbcl/.quicklisp/quicklisp/version.txt new file mode 100644 index 0000000..69bd127 --- /dev/null +++ b/sbcl/.quicklisp/quicklisp/version.txt @@ -0,0 +1 @@ +2020-01-04 diff --git a/sbcl/.quicklisp/setup.lisp b/sbcl/.quicklisp/setup.lisp new file mode 100644 index 0000000..0b2847d --- /dev/null +++ b/sbcl/.quicklisp/setup.lisp @@ -0,0 +1,135 @@ +(defpackage #:ql-setup + (:use #:cl) + (:export #:*quicklisp-home* + #:qmerge + #:qenough)) + +(in-package #:ql-setup) + +(unless *load-truename* + (error "This file must be LOADed to set up quicklisp.")) + +(defvar *quicklisp-home* + (make-pathname :name nil :type nil + :defaults *load-truename*)) + +(defun qmerge (pathname) + "Return PATHNAME merged with the base Quicklisp directory." + (merge-pathnames pathname *quicklisp-home*)) + +(defun qenough (pathname) + (enough-namestring pathname *quicklisp-home*)) + +;;; ASDF is a hard requirement of quicklisp. Make sure it's either +;;; already loaded or load it from quicklisp's bundled version. + +(defvar *required-asdf-version* "2.26") + +;;; Put ASDF's fasls in a separate directory + +(defun implementation-signature () + "Return a string suitable for discriminating different +implementations, or similar implementations with possibly-incompatible +FASLs." + ;; XXX Will this have problems with stuff like threads vs + ;; non-threads fasls? + (let ((*print-pretty* nil)) + (format nil "lisp-implementation-type: ~A~%~ + lisp-implementation-version: ~A~%~ + machine-type: ~A~%~ + machine-version: ~A~%" + (lisp-implementation-type) + (lisp-implementation-version) + (machine-type) + (machine-version)))) + +(defun dumb-string-hash (string) + "Produce a six-character hash of STRING." + (let ((hash #xD13CCD13)) + (loop for char across string + for value = (char-code char) + do + (setf hash (logand #xFFFFFFFF + (logxor (ash hash 5) + (ash hash -27) + value)))) + (subseq (format nil "~(~36,6,'0R~)" (mod hash 88888901)) + 0 6))) + +(defun asdf-fasl-pathname () + "Return a pathname suitable for storing the ASDF FASL, separated +from ASDF FASLs from incompatible implementations. Also, save a file +in the directory with the implementation signature, if it doesn't +already exist." + (let* ((implementation-signature (implementation-signature)) + (original-fasl (compile-file-pathname (qmerge "asdf.lisp"))) + (fasl + (qmerge (make-pathname + :defaults original-fasl + :directory + (list :relative + "cache" + "asdf-fasls" + (dumb-string-hash implementation-signature))))) + (signature-file (merge-pathnames "signature.txt" fasl))) + (ensure-directories-exist fasl) + (unless (probe-file signature-file) + (with-open-file (stream signature-file :direction :output) + (write-string implementation-signature stream))) + fasl)) + +(defun ensure-asdf-loaded () + "Try several methods to make sure that a sufficiently-new ASDF is +loaded: first try (require 'asdf), then loading the ASDF FASL, then +compiling asdf.lisp to a FASL and then loading it." + (let ((source (qmerge "asdf.lisp"))) + (labels ((asdf-symbol (name) + (let ((asdf-package (find-package '#:asdf))) + (when asdf-package + (find-symbol (string name) asdf-package)))) + (version-satisfies (version) + (let ((vs-fun (asdf-symbol '#:version-satisfies)) + (vfun (asdf-symbol '#:asdf-version))) + (when (and vs-fun vfun + (fboundp vs-fun) + (fboundp vfun)) + (funcall vs-fun (funcall vfun) version))))) + (block nil + (macrolet ((try (&body asdf-loading-forms) + `(progn + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + ,@asdf-loading-forms)) + (when (version-satisfies *required-asdf-version*) + (return t))))) + (try) + (try (require 'asdf)) + (let ((fasl (asdf-fasl-pathname))) + (try (load fasl :verbose nil)) + (try (load (compile-file source :verbose nil :output-file fasl)))) + (error "Could not load ASDF ~S or newer" *required-asdf-version*)))))) + +(ensure-asdf-loaded) + +;;; +;;; Quicklisp sometimes must upgrade ASDF. Ugrading ASDF will blow +;;; away existing ASDF methods, so e.g. FASL recompilation :around +;;; methods would be lost. This config file will make it possible to +;;; ensure ASDF can be configured before loading Quicklisp itself via +;;; ASDF. Thanks to Nikodemus Siivola for pointing out this issue. +;;; + +(let ((asdf-init (probe-file (qmerge "asdf-config/init.lisp")))) + (when asdf-init + (with-simple-restart (skip "Skip loading ~S" asdf-init) + (load asdf-init :verbose nil :print nil)))) + +(push (qmerge "quicklisp/") asdf:*central-registry*) + +(let ((*compile-print* nil) + (*compile-verbose* nil) + (*load-verbose* nil) + (*load-print* nil)) + (asdf:oos 'asdf:load-op "quicklisp" :verbose nil)) + +(quicklisp:setup) diff --git a/sbcl/.quicklisp/tmp/install-dist-distinfo.txt b/sbcl/.quicklisp/tmp/install-dist-distinfo.txt new file mode 100644 index 0000000..86798cc --- /dev/null +++ b/sbcl/.quicklisp/tmp/install-dist-distinfo.txt @@ -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 diff --git a/sbcl/.quicklisp/tmp/quicklisp.tar b/sbcl/.quicklisp/tmp/quicklisp.tar new file mode 100644 index 0000000..77e7ed7 Binary files /dev/null and b/sbcl/.quicklisp/tmp/quicklisp.tar differ diff --git a/sbcl/.quicklisp/tmp/release-install.tar b/sbcl/.quicklisp/tmp/release-install.tar new file mode 100644 index 0000000..6ad0c21 Binary files /dev/null and b/sbcl/.quicklisp/tmp/release-install.tar differ diff --git a/sbcl/.sbclrc b/sbcl/.sbclrc new file mode 100644 index 0000000..c6658cd --- /dev/null +++ b/sbcl/.sbclrc @@ -0,0 +1,8 @@ + +;;; The following lines added by ql:add-to-init-file: +#-quicklisp +(let ((quicklisp-init (merge-pathnames ".quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) + diff --git a/sbcl/quicklisp.lisp b/sbcl/quicklisp.lisp new file mode 100644 index 0000000..6cda472 --- /dev/null +++ b/sbcl/quicklisp.lisp @@ -0,0 +1,1757 @@ +;;;; +;;;; This is quicklisp.lisp, the quickstart file for Quicklisp. To use +;;;; it, start Lisp, then (load "quicklisp.lisp") +;;;; +;;;; Quicklisp is beta software and comes with no warranty of any kind. +;;;; +;;;; For more information about the Quicklisp beta, see: +;;;; +;;;; http://www.quicklisp.org/beta/ +;;;; +;;;; If you have any questions or comments about Quicklisp, please +;;;; contact: +;;;; +;;;; Zach Beane +;;;; + +(cl:in-package #:cl-user) +(cl:defpackage #:qlqs-user + (:use #:cl)) +(cl:in-package #:qlqs-user) + +(defpackage #:qlqs-info + (:export #:*version*)) + +(defvar qlqs-info:*version* "2015-01-28") + +(defpackage #:qlqs-impl + (:use #:cl) + (:export #:*implementation*) + (:export #:definterface + #:defimplementation) + (:export #:lisp + #:abcl + #:allegro + #:ccl + #:clasp + #:clisp + #:cmucl + #:cormanlisp + #:ecl + #:gcl + #:lispworks + #:mkcl + #:scl + #:sbcl)) + +(defpackage #:qlqs-impl-util + (:use #:cl #:qlqs-impl) + (:export #:call-with-quiet-compilation)) + +(defpackage #:qlqs-network + (:use #:cl #:qlqs-impl) + (:export #:open-connection + #:write-octets + #:read-octets + #:close-connection + #:with-connection)) + +(defpackage #:qlqs-progress + (:use #:cl) + (:export #:make-progress-bar + #:start-display + #:update-progress + #:finish-display)) + +(defpackage #:qlqs-http + (:use #:cl #:qlqs-network #:qlqs-progress) + (:export #:fetch + #:*proxy-url* + #:*maximum-redirects* + #:*default-url-defaults*)) + +(defpackage #:qlqs-minitar + (:use #:cl) + (:export #:unpack-tarball)) + +(defpackage #:quicklisp-quickstart + (:use #:cl #:qlqs-impl #:qlqs-impl-util #:qlqs-http #:qlqs-minitar) + (:export #:install + #:help + #:*proxy-url* + #:*asdf-url* + #:*quicklisp-tar-url* + #:*setup-url* + #:*help-message* + #:*after-load-message* + #:*after-initial-setup-message*)) + + +;;; +;;; Defining implementation-specific packages and functionality +;;; + +(in-package #:qlqs-impl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun error-unimplemented (&rest args) + (declare (ignore args)) + (error "Not implemented"))) + +(defmacro neuter-package (name) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((definition (fdefinition 'error-unimplemented))) + (do-external-symbols (symbol ,(string name)) + (unless (fboundp symbol) + (setf (fdefinition symbol) definition)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun feature-expression-passes-p (expression) + (cond ((keywordp expression) + (member expression *features*)) + ((consp expression) + (case (first expression) + (or + (some 'feature-expression-passes-p (rest expression))) + (and + (every 'feature-expression-passes-p (rest expression))))) + (t (error "Unrecognized feature expression -- ~S" expression))))) + + +(defmacro define-implementation-package (feature package-name &rest options) + (let* ((output-options '((:use) + (:export #:lisp))) + (prep (cdr (assoc :prep options))) + (class-option (cdr (assoc :class options))) + (class (first class-option)) + (superclasses (rest class-option)) + (import-options '()) + (effectivep (feature-expression-passes-p feature))) + (dolist (option options) + (ecase (first option) + ((:prep :class)) + ((:import-from + :import) + (push option import-options)) + ((:export + :shadow + :intern + :documentation) + (push option output-options)) + ((:reexport-from) + (push (cons :export (cddr option)) output-options) + (push (cons :import-from (cdr option)) import-options)))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(when effectivep + prep) + (defclass ,class ,superclasses ()) + (defpackage ,package-name ,@output-options + ,@(when effectivep + import-options)) + ,@(when effectivep + `((setf *implementation* (make-instance ',class)))) + ,@(unless effectivep + `((neuter-package ,package-name)))))) + +(defmacro definterface (name lambda-list &body options) + (let* ((forbidden (intersection lambda-list lambda-list-keywords)) + (gf-options (remove :implementation options :key #'first)) + (implementations (set-difference options gf-options))) + (when forbidden + (error "~S not allowed in definterface lambda list" forbidden)) + (flet ((method-option (class body) + `(:method ((*implementation* ,class) ,@lambda-list) + ,@body))) + (let ((generic-name (intern (format nil "%~A" name)))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defgeneric ,generic-name (lisp ,@lambda-list) + ,@gf-options + ,@(mapcar (lambda (implementation) + (destructuring-bind (class &rest body) + (rest implementation) + (method-option class body))) + implementations)) + (defun ,name ,lambda-list + (,generic-name *implementation* ,@lambda-list))))))) + +(defmacro defimplementation (name-and-options + lambda-list &body body) + (destructuring-bind (name &key (for t) qualifier) + (if (consp name-and-options) + name-and-options + (list name-and-options)) + (unless for + (error "You must specify an implementation name.")) + (let ((generic-name (find-symbol (format nil "%~A" name)))) + (unless (and generic-name + (fboundp generic-name)) + (error "~S does not name an implementation function" name)) + `(defmethod ,generic-name + ,@(when qualifier (list qualifier)) + ,(list* `(*implementation* ,for) lambda-list) ,@body)))) + + +;;; Bootstrap implementations + +(defvar *implementation* nil) +(defclass lisp () ()) + + +;;; Allegro Common Lisp + +(define-implementation-package :allegro #:qlqs-allegro + (:documentation + "Allegro Common Lisp - http://www.franz.com/products/allegrocl/") + (:class allegro) + (:reexport-from #:socket + #:make-socket) + (:reexport-from #:excl + #:read-vector)) + + +;;; Armed Bear Common Lisp + +(define-implementation-package :abcl #:qlqs-abcl + (:documentation + "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/") + (:class abcl) + (:reexport-from #:system + #:make-socket + #:get-socket-stream)) + +;;; Clozure CL + +(define-implementation-package :ccl #:qlqs-ccl + (:documentation + "Clozure Common Lisp - http://www.clozure.com/clozurecl.html") + (:class ccl) + (:reexport-from #:ccl + #:make-socket)) + + +;;; CLASP + +(define-implementation-package :clasp #:qlqs-clasp + (:documentation "CLASP - http://github.com/drmeister/clasp") + (:class clasp) + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:host-ent-address + #:socket-connect + #:socket-make-stream + #:inet-socket)) + + +;;; GNU CLISP + +(define-implementation-package :clisp #:qlqs-clisp + (:documentation "GNU CLISP - http://clisp.cons.org/") + (:class clisp) + (:reexport-from #:socket + #:socket-connect) + (:reexport-from #:ext + #:read-byte-sequence)) + + +;;; CMUCL + +(define-implementation-package :cmu #:qlqs-cmucl + (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/") + (:class cmucl) + (:reexport-from #:ext + #:*gc-verbose*) + (:reexport-from #:system + #:make-fd-stream) + (:reexport-from #:extensions + #:connect-to-inet-socket)) + +(defvar qlqs-cmucl:*gc-verbose* nil) + + +;;; Scieneer CL + +(define-implementation-package :scl #:qlqs-scl + (:documentation "Scieneer Common Lisp - http://www.scieneer.com/scl/") + (:class scl) + (:reexport-from #:system + #:make-fd-stream) + (:reexport-from #:extensions + #:connect-to-inet-socket)) + +;;; ECL + +(define-implementation-package :ecl #:qlqs-ecl + (:documentation "ECL - http://ecls.sourceforge.net/") + (:class ecl) + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:host-ent-address + #:socket-connect + #:socket-make-stream + #:inet-socket)) + + +;;; LispWorks + +(define-implementation-package :lispworks #:qlqs-lispworks + (:documentation "LispWorks - http://www.lispworks.com/") + (:class lispworks) + (:prep + (require "comm")) + (:reexport-from #:comm + #:open-tcp-stream + #:get-host-entry)) + + +;;; SBCL + +(define-implementation-package :sbcl #:qlqs-sbcl + (:class sbcl) + (:documentation + "Steel Bank Common Lisp - http://www.sbcl.org/") + (:prep + (require 'sb-bsd-sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-ext + #:compiler-note) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:inet-socket + #:host-ent-address + #:socket-connect + #:socket-make-stream)) + +;;; MKCL + +(define-implementation-package :mkcl #:qlqs-mkcl + (:class mkcl) + (:documentation + "ManKai Common Lisp - http://common-lisp.net/project/mkcl/") + (:prep + (require 'sockets)) + (:intern #:host-network-address) + (:reexport-from #:sb-bsd-sockets + #:get-host-by-name + #:inet-socket + #:host-ent-address + #:socket-connect + #:socket-make-stream)) + +;;; +;;; Utility function +;;; + +(in-package #:qlqs-impl-util) + +(definterface call-with-quiet-compilation (fun) + (:implementation t + (let ((*load-verbose* nil) + (*compile-verbose* nil) + (*load-print* nil) + (*compile-print* nil)) + (handler-bind ((warning #'muffle-warning)) + (funcall fun))))) + +(defimplementation (call-with-quiet-compilation :for sbcl :qualifier :around) + (fun) + (declare (ignorable fun)) + (handler-bind ((qlqs-sbcl:compiler-note #'muffle-warning)) + (call-next-method))) + +(defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around) + (fun) + (declare (ignorable fun)) + (let ((qlqs-cmucl:*gc-verbose* nil)) + (call-next-method))) + + +;;; +;;; Low-level networking implementations +;;; + +(in-package #:qlqs-network) + +(definterface host-address (host) + (:implementation t + host) + (:implementation mkcl + (qlqs-mkcl:host-ent-address (qlqs-mkcl:get-host-by-name host))) + (:implementation sbcl + (qlqs-sbcl:host-ent-address (qlqs-sbcl:get-host-by-name host)))) + +(definterface open-connection (host port) + (:implementation t + (declare (ignorable host port)) + (error "Sorry, quicklisp in implementation ~S is not supported yet." + (lisp-implementation-type))) + (:implementation allegro + (qlqs-allegro:make-socket :remote-host host + :remote-port port)) + (:implementation abcl + (let ((socket (qlqs-abcl:make-socket host port))) + (qlqs-abcl:get-socket-stream socket :element-type '(unsigned-byte 8)))) + (:implementation ccl + (qlqs-ccl:make-socket :remote-host host + :remote-port port)) + (:implementation clasp + (let* ((endpoint (qlqs-clasp:host-ent-address + (qlqs-clasp:get-host-by-name host))) + (socket (make-instance 'qlqs-clasp:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-clasp:socket-connect socket endpoint port) + (qlqs-clasp:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation clisp + (qlqs-clisp:socket-connect port host :element-type '(unsigned-byte 8))) + (:implementation cmucl + (let ((fd (qlqs-cmucl:connect-to-inet-socket host port))) + (qlqs-cmucl:make-fd-stream fd + :element-type '(unsigned-byte 8) + :binary-stream-p t + :input t + :output t))) + (:implementation scl + (let ((fd (qlqs-scl:connect-to-inet-socket host port))) + (qlqs-scl:make-fd-stream fd + :element-type '(unsigned-byte 8) + :input t + :output t))) + (:implementation ecl + (let* ((endpoint (qlqs-ecl:host-ent-address + (qlqs-ecl:get-host-by-name host))) + (socket (make-instance 'qlqs-ecl:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-ecl:socket-connect socket endpoint port) + (qlqs-ecl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation lispworks + (qlqs-lispworks:open-tcp-stream host port + :direction :io + :errorp t + :read-timeout nil + :element-type '(unsigned-byte 8) + :timeout 5)) + (:implementation mkcl + (let* ((endpoint (qlqs-mkcl:host-ent-address + (qlqs-mkcl:get-host-by-name host))) + (socket (make-instance 'qlqs-mkcl:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-mkcl:socket-connect socket endpoint port) + (qlqs-mkcl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full))) + (:implementation sbcl + (let* ((endpoint (qlqs-sbcl:host-ent-address + (qlqs-sbcl:get-host-by-name host))) + (socket (make-instance 'qlqs-sbcl:inet-socket + :protocol :tcp + :type :stream))) + (qlqs-sbcl:socket-connect socket endpoint port) + (qlqs-sbcl:socket-make-stream socket + :element-type '(unsigned-byte 8) + :input t + :output t + :buffering :full)))) + +(definterface read-octets (buffer connection) + (:implementation t + (read-sequence buffer connection)) + (:implementation allegro + (qlqs-allegro:read-vector buffer connection)) + (:implementation clisp + (qlqs-clisp:read-byte-sequence buffer connection + :no-hang nil + :interactive t))) + +(definterface write-octets (buffer connection) + (:implementation t + (write-sequence buffer connection) + (finish-output connection))) + +(definterface close-connection (connection) + (:implementation t + (ignore-errors (close connection)))) + +(definterface call-with-connection (host port fun) + (:implementation t + (let (connection) + (unwind-protect + (progn + (setf connection (open-connection host port)) + (funcall fun connection)) + (when connection + (close connection)))))) + +(defmacro with-connection ((connection host port) &body body) + `(call-with-connection ,host ,port (lambda (,connection) ,@body))) + + +;;; +;;; A text progress bar +;;; + +(in-package #:qlqs-progress) + +(defclass progress-bar () + ((start-time + :initarg :start-time + :accessor start-time) + (end-time + :initarg :end-time + :accessor end-time) + (progress-character + :initarg :progress-character + :accessor progress-character) + (character-count + :initarg :character-count + :accessor character-count + :documentation "How many characters wide is the progress bar?") + (characters-so-far + :initarg :characters-so-far + :accessor characters-so-far) + (update-interval + :initarg :update-interval + :accessor update-interval + :documentation "Update the progress bar display after this many + internal-time units.") + (last-update-time + :initarg :last-update-time + :accessor last-update-time + :documentation "The display was last updated at this time.") + (total + :initarg :total + :accessor total + :documentation "The total number of units tracked by this progress bar.") + (progress + :initarg :progress + :accessor progress + :documentation "How far in the progress are we?") + (pending + :initarg :pending + :accessor pending + :documentation "How many raw units should be tracked in the next + display update?")) + (:default-initargs + :progress-character #\= + :character-count 50 + :characters-so-far 0 + :update-interval (floor internal-time-units-per-second 4) + :last-update-time 0 + :total 0 + :progress 0 + :pending 0)) + +(defgeneric start-display (progress-bar)) +(defgeneric update-progress (progress-bar unit-count)) +(defgeneric update-display (progress-bar)) +(defgeneric finish-display (progress-bar)) +(defgeneric elapsed-time (progress-bar)) +(defgeneric units-per-second (progress-bar)) + +(defmethod start-display (progress-bar) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (setf (start-time progress-bar) (get-internal-real-time)) + (fresh-line) + (finish-output)) + +(defmethod update-display (progress-bar) + (incf (progress progress-bar) (pending progress-bar)) + (setf (pending progress-bar) 0) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (let* ((showable (floor (character-count progress-bar) + (/ (total progress-bar) (progress progress-bar)))) + (needed (- showable (characters-so-far progress-bar)))) + (setf (characters-so-far progress-bar) showable) + (dotimes (i needed) + (write-char (progress-character progress-bar))) + (finish-output))) + +(defmethod update-progress (progress-bar unit-count) + (incf (pending progress-bar) unit-count) + (let ((now (get-internal-real-time))) + (when (< (update-interval progress-bar) + (- now (last-update-time progress-bar))) + (update-display progress-bar)))) + +(defmethod finish-display (progress-bar) + (update-display progress-bar) + (setf (end-time progress-bar) (get-internal-real-time)) + (terpri) + (format t "~:D bytes in ~$ seconds (~$KB/sec)" + (total progress-bar) + (elapsed-time progress-bar) + (/ (units-per-second progress-bar) 1024)) + (finish-output)) + +(defmethod elapsed-time (progress-bar) + (/ (- (end-time progress-bar) (start-time progress-bar)) + internal-time-units-per-second)) + +(defmethod units-per-second (progress-bar) + (if (plusp (elapsed-time progress-bar)) + (/ (total progress-bar) (elapsed-time progress-bar)) + 0)) + +(defun kb/sec (progress-bar) + (/ (units-per-second progress-bar) 1024)) + + + +(defparameter *uncertain-progress-chars* "?") + +(defclass uncertain-size-progress-bar (progress-bar) + ((progress-char-index + :initarg :progress-char-index + :accessor progress-char-index) + (units-per-char + :initarg :units-per-char + :accessor units-per-char)) + (:default-initargs + :total 0 + :progress-char-index 0 + :units-per-char (floor (expt 1024 2) 50))) + +(defmethod update-progress :after ((progress-bar uncertain-size-progress-bar) + unit-count) + (incf (total progress-bar) unit-count)) + +(defmethod progress-character ((progress-bar uncertain-size-progress-bar)) + (let ((index (progress-char-index progress-bar))) + (prog1 + (char *uncertain-progress-chars* index) + (setf (progress-char-index progress-bar) + (mod (1+ index) (length *uncertain-progress-chars*)))))) + +(defmethod update-display ((progress-bar uncertain-size-progress-bar)) + (setf (last-update-time progress-bar) (get-internal-real-time)) + (multiple-value-bind (chars pend) + (floor (pending progress-bar) (units-per-char progress-bar)) + (setf (pending progress-bar) pend) + (dotimes (i chars) + (write-char (progress-character progress-bar)) + (incf (characters-so-far progress-bar)) + (when (<= (character-count progress-bar) + (characters-so-far progress-bar)) + (terpri) + (setf (characters-so-far progress-bar) 0) + (finish-output))) + (finish-output))) + +(defun make-progress-bar (total) + (if (or (not total) (zerop total)) + (make-instance 'uncertain-size-progress-bar) + (make-instance 'progress-bar :total total))) + +;;; +;;; A simple HTTP client +;;; + +(in-package #:qlqs-http) + +;;; Octet data + +(deftype octet () + '(unsigned-byte 8)) + +(defun make-octet-vector (size) + (make-array size :element-type 'octet + :initial-element 0)) + +(defun octet-vector (&rest octets) + (make-array (length octets) :element-type 'octet + :initial-contents octets)) + +;;; ASCII characters as integers + +(defun acode (char) + (cond ((eql char :cr) + 13) + ((eql char :lf) + 10) + (t + (let ((code (char-code char))) + (if (<= 0 code 127) + code + (error "Character ~S is not in the ASCII character set" + char)))))) + +(defvar *whitespace* + (list (acode #\Space) (acode #\Tab) (acode :cr) (acode :lf))) + +(defun whitep (code) + (member code *whitespace*)) + +(defun ascii-vector (string) + (let ((vector (make-octet-vector (length string)))) + (loop for char across string + for code = (char-code char) + for i from 0 + if (< 127 code) do + (error "Invalid character for ASCII -- ~A" char) + else + do (setf (aref vector i) code)) + vector)) + +(defun ascii-subseq (vector start end) + "Return a subseq of octet-specialized VECTOR as a string." + (let ((string (make-string (- end start)))) + (loop for i from 0 + for j from start below end + do (setf (char string i) (code-char (aref vector j)))) + string)) + +(defun ascii-downcase (code) + (if (<= 65 code 90) + (+ code 32) + code)) + +(defun ascii-equal (a b) + (eql (ascii-downcase a) (ascii-downcase b))) + +(defmacro acase (value &body cases) + (flet ((convert-case-keys (keys) + (mapcar (lambda (key) + (etypecase key + (integer key) + (character (char-code key)) + (symbol + (ecase key + (:cr 13) + (:lf 10) + ((t) t))))) + (if (consp keys) keys (list keys))))) + `(case ,value + ,@(mapcar (lambda (case) + (destructuring-bind (keys &rest body) + case + `(,(if (eql keys t) + t + (convert-case-keys keys)) + ,@body))) + cases)))) + +;;; Pattern matching (for finding headers) + +(defclass matcher () + ((pattern + :initarg :pattern + :reader pattern) + (pos + :initform 0 + :accessor match-pos) + (matchedp + :initform nil + :accessor matchedp))) + +(defun reset-match (matcher) + (setf (match-pos matcher) 0 + (matchedp matcher) nil)) + +(define-condition match-failure (error) ()) + +(defun match (matcher input &key (start 0) end error) + (let ((i start) + (end (or end (length input))) + (match-end (length (pattern matcher)))) + (with-slots (pattern pos) + matcher + (loop + (cond ((= pos match-end) + (let ((match-start (- i pos))) + (setf pos 0) + (setf (matchedp matcher) t) + (return (values match-start (+ match-start match-end))))) + ((= i end) + (return nil)) + ((= (aref pattern pos) + (aref input i)) + (incf i) + (incf pos)) + (t + (if error + (error 'match-failure) + (if (zerop pos) + (incf i) + (setf pos 0))))))))) + +(defun ascii-matcher (string) + (make-instance 'matcher + :pattern (ascii-vector string))) + +(defun octet-matcher (&rest octets) + (make-instance 'matcher + :pattern (apply 'octet-vector octets))) + +(defun acode-matcher (&rest codes) + (make-instance 'matcher + :pattern (make-array (length codes) + :element-type 'octet + :initial-contents + (mapcar 'acode codes)))) + + +;;; "Connection Buffers" are a kind of callback-driven, +;;; pattern-matching chunky stream. Callbacks can be called for a +;;; certain number of octets or until one or more patterns are seen in +;;; the input. cbufs automatically refill themselves from a +;;; connection as needed. + +(defvar *cbuf-buffer-size* 8192) + +(define-condition end-of-data (error) ()) + +(defclass cbuf () + ((data + :initarg :data + :accessor data) + (connection + :initarg :connection + :accessor connection) + (start + :initarg :start + :accessor start) + (end + :initarg :end + :accessor end) + (eofp + :initarg :eofp + :accessor eofp)) + (:default-initargs + :data (make-octet-vector *cbuf-buffer-size*) + :connection nil + :start 0 + :end 0 + :eofp nil) + (:documentation "A CBUF is a connection buffer that keeps track of + incoming data from a connection. Several functions make it easy to + treat a CBUF as a kind of chunky, callback-driven stream.")) + +(define-condition cbuf-progress () + ((size + :initarg :size + :accessor cbuf-progress-size + :initform 0))) + +(defun call-processor (fun cbuf start end) + (signal 'cbuf-progress :size (- end start)) + (funcall fun (data cbuf) start end)) + +(defun make-cbuf (connection) + (make-instance 'cbuf :connection connection)) + +(defun make-stream-writer (stream) + "Create a callback for writing data to STREAM." + (lambda (data start end) + (write-sequence data stream :start start :end end))) + +(defgeneric size (cbuf) + (:method ((cbuf cbuf)) + (- (end cbuf) (start cbuf)))) + +(defgeneric emptyp (cbuf) + (:method ((cbuf cbuf)) + (zerop (size cbuf)))) + +(defgeneric refill (cbuf) + (:method ((cbuf cbuf)) + (when (eofp cbuf) + (error 'end-of-data)) + (setf (start cbuf) 0) + (setf (end cbuf) + (read-octets (data cbuf) + (connection cbuf))) + (cond ((emptyp cbuf) + (setf (eofp cbuf) t) + (error 'end-of-data)) + (t (size cbuf))))) + +(defun process-all (fun cbuf) + (unless (emptyp cbuf) + (call-processor fun cbuf (start cbuf) (end cbuf)))) + +(defun multi-cmatch (matchers cbuf) + (let (start end) + (dolist (matcher matchers (values start end)) + (multiple-value-bind (s e) + (match matcher (data cbuf) + :start (start cbuf) + :end (end cbuf)) + (when (and s (or (null start) (< s start))) + (setf start s + end e)))))) + +(defun cmatch (matcher cbuf) + (if (consp matcher) + (multi-cmatch matcher cbuf) + (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)))) + +(defun call-until-end (fun cbuf) + (handler-case + (loop + (process-all fun cbuf) + (refill cbuf)) + (end-of-data () + (return-from call-until-end)))) + +(defun show-cbuf (context cbuf) + (format t "cbuf: ~A ~D - ~D~%" context (start cbuf) (end cbuf))) + +(defun call-for-n-octets (n fun cbuf) + (let ((remaining n)) + (loop + (when (<= remaining (size cbuf)) + (let ((end (+ (start cbuf) remaining))) + (call-processor fun cbuf (start cbuf) end) + (setf (start cbuf) end) + (return))) + (process-all fun cbuf) + (decf remaining (size cbuf)) + (refill cbuf)))) + +(defun call-until-matching (matcher fun cbuf) + (loop + (multiple-value-bind (start end) + (cmatch matcher cbuf) + (when start + (call-processor fun cbuf (start cbuf) end) + (setf (start cbuf) end) + (return))) + (process-all fun cbuf) + (refill cbuf))) + +(defun ignore-data (data start end) + (declare (ignore data start end))) + +(defun skip-until-matching (matcher cbuf) + (call-until-matching matcher 'ignore-data cbuf)) + + +;;; Creating HTTP requests as octet buffers + +(defclass octet-sink () + ((storage + :initarg :storage + :accessor storage)) + (:default-initargs + :storage (make-array 1024 :element-type 'octet + :fill-pointer 0 + :adjustable t)) + (:documentation "A simple stream-like target for collecting + octets.")) + +(defun add-octet (octet sink) + (vector-push-extend octet (storage sink))) + +(defun add-octets (octets sink &key (start 0) end) + (setf end (or end (length octets))) + (loop for i from start below end + do (add-octet (aref octets i) sink))) + +(defun add-string (string sink) + (loop for char across string + for code = (char-code char) + do (add-octet code sink))) + +(defun add-strings (sink &rest strings) + (mapc (lambda (string) (add-string string sink)) strings)) + +(defun add-newline (sink) + (add-octet 13 sink) + (add-octet 10 sink)) + +(defun sink-buffer (sink) + (subseq (storage sink) 0)) + +(defvar *proxy-url* nil) + +(defun full-proxy-path (host port path) + (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A" + (= port 443) + host + (or (= port 80) + (= port 443)) + port + path)) + +(defun make-request-buffer (host port path &key (method "GET")) + (setf method (string method)) + (when *proxy-url* + (setf path (full-proxy-path host port path))) + (let ((sink (make-instance 'octet-sink))) + (flet ((add-line (&rest strings) + (apply #'add-strings sink strings) + (add-newline sink))) + (add-line method " " path " HTTP/1.1") + (add-line "Host: " host (if (= port 80) "" + (format nil ":~D" port))) + (add-line "Connection: close") + ;; FIXME: get this version string from somewhere else. + (add-line "User-Agent: quicklisp-bootstrap/" + qlqs-info:*version*) + (add-newline sink) + (sink-buffer sink)))) + +(defun sink-until-matching (matcher cbuf) + (let ((sink (make-instance 'octet-sink))) + (call-until-matching + matcher + (lambda (buffer start end) + (add-octets buffer sink :start start :end end)) + cbuf) + (sink-buffer sink))) + + +;;; HTTP headers + +(defclass header () + ((data + :initarg :data + :accessor data) + (status + :initarg :status + :accessor status) + (name-starts + :initarg :name-starts + :accessor name-starts) + (name-ends + :initarg :name-ends + :accessor name-ends) + (value-starts + :initarg :value-starts + :accessor value-starts) + (value-ends + :initarg :value-ends + :accessor value-ends))) + +(defmethod print-object ((header header) stream) + (print-unreadable-object (header stream :type t) + (prin1 (status header) stream))) + +(defun matches-at (pattern target pos) + (= (mismatch pattern target :start2 pos) (length pattern))) + +(defun header-value-indexes (field-name header) + (loop with data = (data header) + with pattern = (ascii-vector (string-downcase field-name)) + for start across (name-starts header) + for i from 0 + when (matches-at pattern data start) + return (values (aref (value-starts header) i) + (aref (value-ends header) i)))) + +(defun ascii-header-value (field-name header) + (multiple-value-bind (start end) + (header-value-indexes field-name header) + (when start + (ascii-subseq (data header) start end)))) + +(defun all-field-names (header) + (map 'list + (lambda (start end) + (ascii-subseq (data header) start end)) + (name-starts header) + (name-ends header))) + +(defun headers-alist (header) + (mapcar (lambda (name) + (cons name (ascii-header-value name header))) + (all-field-names header))) + +(defmethod describe-object :after ((header header) stream) + (format stream "~&Decoded headers:~% ~S~%" (headers-alist header))) + +(defun content-length (header) + (let ((field-value (ascii-header-value "content-length" header))) + (when field-value + (let ((value (ignore-errors (parse-integer field-value)))) + (or value + (error "Content-Length header field value is not a number -- ~A" + field-value)))))) + +(defun chunkedp (header) + (string= (ascii-header-value "transfer-encoding" header) "chunked")) + +(defun location (header) + (ascii-header-value "location" header)) + +(defun status-code (vector) + (let* ((space (position (acode #\Space) vector)) + (c1 (- (aref vector (incf space)) 48)) + (c2 (- (aref vector (incf space)) 48)) + (c3 (- (aref vector (incf space)) 48))) + (+ (* c1 100) + (* c2 10) + (* c3 1)))) + +(defun force-downcase-field-names (header) + (loop with data = (data header) + for start across (name-starts header) + for end across (name-ends header) + do (loop for i from start below end + for code = (aref data i) + do (setf (aref data i) (ascii-downcase code))))) + +(defun skip-white-forward (pos vector) + (position-if-not 'whitep vector :start pos)) + +(defun skip-white-backward (pos vector) + (let ((nonwhite (position-if-not 'whitep vector :end pos :from-end t))) + (if nonwhite + (1+ nonwhite) + pos))) + +(defun contract-field-value-indexes (header) + "Header field values exclude leading and trailing whitespace; adjust +the indexes in the header accordingly." + (loop with starts = (value-starts header) + with ends = (value-ends header) + with data = (data header) + for i from 0 + for start across starts + for end across ends + do + (setf (aref starts i) (skip-white-forward start data)) + (setf (aref ends i) (skip-white-backward end data)))) + +(defun next-line-pos (vector) + (let ((pos 0)) + (labels ((finish (&optional (i pos)) + (return-from next-line-pos i)) + (after-cr (code) + (acase code + (:lf (finish pos)) + (t (finish (1- pos))))) + (pending (code) + (acase code + (:cr #'after-cr) + (:lf (finish pos)) + (t #'pending)))) + (let ((state #'pending)) + (loop + (setf state (funcall state (aref vector pos))) + (incf pos)))))) + +(defun make-hvector () + (make-array 16 :fill-pointer 0 :adjustable t)) + +(defun process-header (vector) + "Create a HEADER instance from the octet data in VECTOR." + (let* ((name-starts (make-hvector)) + (name-ends (make-hvector)) + (value-starts (make-hvector)) + (value-ends (make-hvector)) + (header (make-instance 'header + :data vector + :status 999 + :name-starts name-starts + :name-ends name-ends + :value-starts value-starts + :value-ends value-ends)) + (mark nil) + (pos (next-line-pos vector))) + (unless pos + (error "Unable to process HTTP header")) + (setf (status header) (status-code vector)) + (labels ((save (value vector) + (vector-push-extend value vector)) + (mark () + (setf mark pos)) + (clear-mark () + (setf mark nil)) + (finish () + (if mark + (save mark value-ends) + (save pos value-ends)) + (force-downcase-field-names header) + (contract-field-value-indexes header) + (return-from process-header header)) + (in-new-line (code) + (acase code + ((#\Tab #\Space) (setf mark nil) #'in-value) + (t + (when mark + (save mark value-ends)) + (clear-mark) + (save pos name-starts) + (in-name code)))) + (after-cr (code) + (acase code + (:lf #'in-new-line) + (t (in-new-line code)))) + (pending-value (code) + (acase code + ((#\Tab #\Space) #'pending-value) + (:cr #'after-cr) + (:lf #'in-new-line) + (t (save pos value-starts) #'in-value))) + (in-name (code) + (acase code + (#\: + (save pos name-ends) + (save (1+ pos) value-starts) + #'in-value) + ((:cr :lf) + (finish)) + ((#\Tab #\Space) + (error "Unexpected whitespace in header field name")) + (t + (unless (<= 0 code 127) + (error "Unexpected non-ASCII header field name")) + #'in-name))) + (in-value (code) + (acase code + (:lf (mark) #'in-new-line) + (:cr (mark) #'after-cr) + (t #'in-value)))) + (let ((state #'in-new-line)) + (loop + (incf pos) + (when (<= (length vector) pos) + (error "No header found in response")) + (setf state (funcall state (aref vector pos)))))))) + + +;;; HTTP URL parsing + +(defclass url () + ((hostname + :initarg :hostname + :accessor hostname + :initform nil) + (port + :initarg :port + :accessor port + :initform 80) + (path + :initarg :path + :accessor path + :initform "/"))) + +(defun parse-urlstring (urlstring) + (setf urlstring (string-trim " " urlstring)) + (let* ((pos (mismatch urlstring "http://" :test 'char-equal)) + (mark pos) + (url (make-instance 'url))) + (labels ((save () + (subseq urlstring mark pos)) + (mark () + (setf mark pos)) + (finish () + (return-from parse-urlstring url)) + (hostname-char-p (char) + (position char "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." + :test 'char-equal)) + (at-start (char) + (case char + (#\/ + (setf (port url) nil) + (mark) + #'in-path) + (t + #'in-host))) + (in-host (char) + (case char + ((#\/ :end) + (setf (hostname url) (save)) + (mark) + #'in-path) + (#\: + (setf (hostname url) (save)) + (mark) + #'in-port) + (t + (unless (hostname-char-p char) + (error "~S is not a valid URL" urlstring)) + #'in-host))) + (in-port (char) + (case char + ((#\/ :end) + (setf (port url) + (parse-integer urlstring + :start (1+ mark) + :end pos)) + (mark) + #'in-path) + (t + (unless (digit-char-p char) + (error "Bad port in URL ~S" urlstring)) + #'in-port))) + (in-path (char) + (case char + ((#\# :end) + (setf (path url) (save)) + (finish))) + #'in-path)) + (let ((state #'at-start)) + (loop + (when (<= (length urlstring) pos) + (funcall state :end) + (finish)) + (setf state (funcall state (aref urlstring pos))) + (incf pos)))))) + +(defun url (thing) + (if (stringp thing) + (parse-urlstring thing) + thing)) + +(defgeneric request-buffer (method url) + (:method (method url) + (setf url (url url)) + (make-request-buffer (hostname url) (port url) (path url) + :method method))) + +(defun urlstring (url) + (format nil "~@[http://~A~]~@[:~D~]~A" + (hostname url) + (and (/= 80 (port url)) (port url)) + (path url))) + +(defmethod print-object ((url url) stream) + (print-unreadable-object (url stream :type t) + (prin1 (urlstring url) stream))) + +(defun merge-urls (url1 url2) + (setf url1 (url url1)) + (setf url2 (url url2)) + (make-instance 'url + :hostname (or (hostname url1) + (hostname url2)) + :port (or (port url1) + (port url2)) + :path (or (path url1) + (path url2)))) + + +;;; Requesting an URL and saving it to a file + +(defparameter *maximum-redirects* 10) +(defvar *default-url-defaults* (url "http://src.quicklisp.org/")) + +(defun read-http-header (cbuf) + (let ((header-data (sink-until-matching (list (acode-matcher :lf :lf) + (acode-matcher :cr :cr) + (acode-matcher :cr :lf :cr :lf)) + cbuf))) + (process-header header-data))) + +(defun read-chunk-header (cbuf) + (let* ((header-data (sink-until-matching (acode-matcher :cr :lf) cbuf)) + (end (or (position (acode :cr) header-data) + (position (acode #\;) header-data)))) + (values (parse-integer (ascii-subseq header-data 0 end) :radix 16)))) + +(defun save-chunk-response (stream cbuf) + "For a chunked response, read all chunks and write them to STREAM." + (let ((fun (make-stream-writer stream)) + (matcher (acode-matcher :cr :lf))) + (loop + (let ((chunk-size (read-chunk-header cbuf))) + (when (zerop chunk-size) + (return)) + (call-for-n-octets chunk-size fun cbuf) + (skip-until-matching matcher cbuf))))) + +(defun save-response (file header cbuf) + (with-open-file (stream file + :direction :output + :if-exists :supersede + :element-type 'octet) + (let ((content-length (content-length header))) + (cond ((chunkedp header) + (save-chunk-response stream cbuf)) + (content-length + (call-for-n-octets content-length + (make-stream-writer stream) + cbuf)) + (t + (call-until-end (make-stream-writer stream) cbuf)))))) + +(defun call-with-progress-bar (size fun) + (let ((progress-bar (make-progress-bar size))) + (start-display progress-bar) + (flet ((update (condition) + (update-progress progress-bar + (cbuf-progress-size condition)))) + (handler-bind ((cbuf-progress #'update)) + (funcall fun))) + (finish-display progress-bar))) + +(defun fetch (url file &key (follow-redirects t) quietly + (maximum-redirects *maximum-redirects*)) + "Request URL and write the body of the response to FILE." + (setf url (merge-urls url *default-url-defaults*)) + (setf file (merge-pathnames file)) + (let ((redirect-count 0) + (original-url url) + (connect-url (or (url *proxy-url*) url)) + (stream (if quietly + (make-broadcast-stream) + *trace-output*))) + (loop + (when (<= maximum-redirects redirect-count) + (error "Too many redirects for ~A" original-url)) + (with-connection (connection (hostname connect-url) (port connect-url)) + (let ((cbuf (make-instance 'cbuf :connection connection)) + (request (request-buffer "GET" url))) + (write-octets request connection) + (let ((header (read-http-header cbuf))) + (loop while (= (status header) 100) + do (setf header (read-http-header cbuf))) + (cond ((= (status header) 200) + (let ((size (content-length header))) + (format stream "~&; Fetching ~A~%" url) + (if (and (numberp size) + (plusp size)) + (format stream "; ~$KB~%" (/ size 1024)) + (format stream "; Unknown size~%")) + (if quietly + (save-response file header cbuf) + (call-with-progress-bar (content-length header) + (lambda () + (save-response file header cbuf)))))) + ((not (<= 300 (status header) 399)) + (error "Unexpected status for ~A: ~A" + url (status header)))) + (if (and follow-redirects (<= 300 (status header) 399)) + (let ((new-urlstring (ascii-header-value "location" header))) + (when (not new-urlstring) + (error "Redirect code ~D received, but no Location: header" + (status header))) + (incf redirect-count) + (setf url (merge-urls new-urlstring + url)) + (format stream "~&; Redirecting to ~A~%" url)) + (return (values header (and file (probe-file file))))))))))) + + +;;; A primitive tar unpacker + +(in-package #:qlqs-minitar) + +(defun make-block-buffer () + (make-array 512 :element-type '(unsigned-byte 8) :initial-element 0)) + +(defun skip-n-blocks (n stream) + (let ((block (make-block-buffer))) + (dotimes (i n) + (read-sequence block stream)))) + +(defun ascii-subseq (vector start end) + (let ((string (make-string (- end start)))) + (loop for i from 0 + for j from start below end + do (setf (char string i) (code-char (aref vector j)))) + string)) + +(defun block-asciiz-string (block start length) + (let* ((end (+ start length)) + (eos (or (position 0 block :start start :end end) + end))) + (ascii-subseq block start eos))) + +(defun prefix (header) + (when (plusp (aref header 345)) + (block-asciiz-string header 345 155))) + +(defun name (header) + (block-asciiz-string header 0 100)) + +(defun payload-size (header) + (values (parse-integer (block-asciiz-string header 124 12) :radix 8))) + +(defun nth-block (n file) + (with-open-file (stream file :element-type '(unsigned-byte 8)) + (let ((block (make-block-buffer))) + (skip-n-blocks (1- n) stream) + (read-sequence block stream) + block))) + +(defun payload-type (code) + (case code + (0 :file) + (48 :file) + (53 :directory) + (t :unsupported))) + +(defun full-path (header) + (let ((prefix (prefix header)) + (name (name header))) + (if prefix + (format nil "~A/~A" prefix name) + name))) + +(defun save-file (file size stream) + (multiple-value-bind (full-blocks partial) + (truncate size 512) + (ensure-directories-exist file) + (with-open-file (outstream file + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (let ((block (make-block-buffer))) + (dotimes (i full-blocks) + (read-sequence block stream) + (write-sequence block outstream)) + (when (plusp partial) + (read-sequence block stream) + (write-sequence block outstream :end partial)))))) + +(defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*)) + (let ((block (make-block-buffer))) + (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) + (loop + (let ((size (read-sequence block stream))) + (when (zerop size) + (return)) + (unless (= size 512) + (error "Bad size on tarfile")) + (when (every #'zerop block) + (return)) + (let* ((payload-code (aref block 156)) + (payload-type (payload-type payload-code)) + (tar-path (full-path block)) + (full-path (merge-pathnames tar-path directory)) + (payload-size (payload-size block))) + (case payload-type + (:file + (save-file full-path payload-size stream)) + (:directory + (ensure-directories-exist full-path)) + (t + (warn "Unknown tar block payload code -- ~D" payload-code) + (skip-n-blocks (ceiling (payload-size block) 512) stream))))))))) + +(defun contents (tarfile) + (let ((block (make-block-buffer)) + (result '())) + (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) + (loop + (let ((size (read-sequence block stream))) + (when (zerop size) + (return (nreverse result))) + (unless (= size 512) + (error "Bad size on tarfile")) + (when (every #'zerop block) + (return (nreverse result))) + (let* ((payload-type (payload-type (aref block 156))) + (tar-path (full-path block)) + (payload-size (payload-size block))) + (skip-n-blocks (ceiling payload-size 512) stream) + (case payload-type + (:file + (push tar-path result)) + (:directory + (push tar-path result))))))))) + + +;;; +;;; The actual bootstrapping work +;;; + +(in-package #:quicklisp-quickstart) + +(defvar *home* + (merge-pathnames (make-pathname :directory '(:relative "quicklisp")) + (user-homedir-pathname))) + +(defun qmerge (pathname) + (merge-pathnames pathname *home*)) + +(defun renaming-fetch (url file) + (let ((tmpfile (qmerge "tmp/fetch.dat"))) + (fetch url tmpfile) + (rename-file tmpfile file))) + +(defvar *quickstart-parameters* nil + "This plist is populated with parameters that may carry over to the + initial configuration of the client, e.g. :proxy-url + or :initial-dist-url") + +(defvar *quicklisp-hostname* "beta.quicklisp.org") + +(defvar *client-info-url* + (format nil "http://~A/client/quicklisp.sexp" + *quicklisp-hostname*)) + +(defclass client-info () + ((setup-url + :reader setup-url + :initarg :setup-url) + (asdf-url + :reader asdf-url + :initarg :asdf-url) + (client-tar-url + :reader client-tar-url + :initarg :client-tar-url) + (version + :reader version + :initarg :version) + (plist + :reader plist + :initarg :plist) + (source-file + :reader source-file + :initarg :source-file))) + +(defmethod print-object ((client-info client-info) stream) + (print-unreadable-object (client-info stream :type t) + (prin1 (version client-info) stream))) + +(defun safely-read (stream) + (let ((*read-eval* nil)) + (read stream))) + +(defun fetch-client-info-plist (url) + "Fetch and return the client info data at URL." + (let ((local-client-info-file (qmerge "tmp/client-info.sexp"))) + (ensure-directories-exist local-client-info-file) + (renaming-fetch url local-client-info-file) + (with-open-file (stream local-client-info-file) + (list* :source-file local-client-info-file + (safely-read stream))))) + +(defun fetch-client-info (url) + (let ((plist (fetch-client-info-plist url))) + (destructuring-bind (&key setup asdf client-tar version + source-file + &allow-other-keys) + plist + (unless (and setup asdf client-tar version) + (error "Invalid data from client info URL -- ~A" url)) + (make-instance 'client-info + :setup-url (getf setup :url) + :asdf-url (getf asdf :url) + :client-tar-url (getf client-tar :url) + :version version + :plist plist + :source-file source-file)))) + +(defun client-info-url-from-version (version) + (format nil "http://~A/client/~A/client-info.sexp" + *quicklisp-hostname* + version)) + +(defun distinfo-url-from-version (version) + (format nil "http://~A/dist/~A/distinfo.txt" + *quicklisp-hostname* + version)) + +(defvar *help-message* + (format nil "~&~% ==== quicklisp quickstart install help ====~%~% ~ + quicklisp-quickstart:install can take the following ~ + optional arguments:~%~% ~ + :path \"/path/to/installation/\"~%~% ~ + :proxy \"http://your.proxy:port/\"~%~% ~ + :client-url ~%~% ~ + :client-version ~%~% ~ + :dist-url ~%~% ~ + :dist-version ~%~%")) + +(defvar *after-load-message* + (format nil "~&~% ==== quicklisp quickstart ~A loaded ====~%~% ~ + To continue with installation, evaluate: (quicklisp-quickstart:install)~%~% ~ + For installation options, evaluate: (quicklisp-quickstart:help)~%~%" + qlqs-info:*version*)) + +(defvar *after-initial-setup-message* + (with-output-to-string (*standard-output*) + (format t "~&~% ==== quicklisp installed ====~%~%") + (format t " To load a system, use: (ql:quickload \"system-name\")~%~%") + (format t " To find systems, use: (ql:system-apropos \"term\")~%~%") + (format t " To load Quicklisp every time you start Lisp, use: (ql:add-to-init-file)~%~%") + (format t " For more information, see http://www.quicklisp.org/beta/~%~%"))) + +(defun initial-install (&key (client-url *client-info-url*) dist-url) + (setf *quickstart-parameters* + (list :proxy-url *proxy-url* + :initial-dist-url dist-url)) + (ensure-directories-exist (qmerge "tmp/")) + (let ((client-info (fetch-client-info client-url)) + (tmptar (qmerge "tmp/quicklisp.tar")) + (setup (qmerge "setup.lisp")) + (asdf (qmerge "asdf.lisp"))) + (renaming-fetch (client-tar-url client-info) tmptar) + (unpack-tarball tmptar :directory (qmerge "./")) + (renaming-fetch (setup-url client-info) setup) + (renaming-fetch (asdf-url client-info) asdf) + (rename-file (source-file client-info) (qmerge "client-info.sexp")) + (load setup :verbose nil :print nil) + (write-string *after-initial-setup-message*) + (finish-output))) + +(defun help () + (write-string *help-message*) + t) + +(defun non-empty-file-namestring (pathname) + (let ((string (file-namestring pathname))) + (unless (or (null string) + (equal string "")) + string))) + +(defun install (&key ((:path *home*) *home*) + ((:proxy *proxy-url*) *proxy-url*) + client-url + client-version + dist-url + dist-version) + (setf *home* (merge-pathnames *home* (truename *default-pathname-defaults*))) + (let ((name (non-empty-file-namestring *home*))) + (when name + (warn "Making ~A part of the install pathname directory" + name) + ;; This corrects a pathname like "/foo/bar" to "/foo/bar/" and + ;; "foo" to "foo/" + (setf *home* + (make-pathname :defaults *home* + :directory (append (pathname-directory *home*) + (list name)))))) + (let ((setup-file (qmerge "setup.lisp"))) + (when (probe-file setup-file) + (multiple-value-bind (result proceed) + (with-simple-restart (load-setup "Load ~S" setup-file) + (error "Quicklisp has already been installed. Load ~S instead." + setup-file)) + (declare (ignore result)) + (when proceed + (return-from install (load setup-file)))))) + (if (find-package '#:ql) + (progn + (write-line "!!! Quicklisp has already been set up. !!!") + (write-string *after-initial-setup-message*) + t) + (call-with-quiet-compilation + (lambda () + (let ((client-url (or client-url + (and client-version + (client-info-url-from-version client-version)) + *client-info-url*)) + ;; It's ok for dist-url to be nil; there's a default in + ;; the client + (dist-url (or dist-url + (and dist-version + (distinfo-url-from-version dist-version))))) + (initial-install :client-url client-url + :dist-url dist-url)))))) + +(write-string *after-load-message*) + +;;; End of quicklisp.lisp diff --git a/vim/.vimrc b/vim/.vimrc index d742d12..5f6c995 100755 --- a/vim/.vimrc +++ b/vim/.vimrc @@ -31,8 +31,9 @@ Plug 'wolf-dog/lightline-sceaduhelm.vim' Plug 'unblevable/quick-scope' Plug 'tpope/vim-fugitive' + Plug 'l04m33/vlime', {'rtp': 'vim/'} + Plug 'kovisoft/paredit' " Plug 'metakirby5/codi.vim' - call plug#end() "}}}