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

Vim window logic, slimv

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

4
sbcl/.quicklisp/dists/quicklisp/software/let-plus-20191130-git/.gitignore vendored Normal file
View file

@ -0,0 +1,4 @@
*.fasl
*~
unit-tests/test-results/
README.html

23
sbcl/.quicklisp/dists/quicklisp/software/let-plus-20191130-git/LICENSE_1_0.txt Normal file
View file

@ -0,0 +1,23 @@
Boost Software License - Version 1.0 - August 17th, 2003
Permission is hereby granted, free of charge, to any person or organization
obtaining a copy of the software and accompanying documentation covered by
this license (the "Software") to use, reproduce, display, distribute,
execute, and transmit the Software, and to prepare derivative works of the
Software, and to permit third-parties to whom the Software is furnished to
do so, all subject to the following:
The copyright notices in the Software and this entire statement, including
the above license grant, this restriction and the following disclaimer,
must be included in all copies of the Software, in whole or in part, and
all derivative works of the Software, unless such copies or derivative
works are solely in the form of machine-executable object code generated by
a source language processor.
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, TITLE AND NON-INFRINGEMENT. IN NO EVENT
SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE
FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.

194
sbcl/.quicklisp/dists/quicklisp/software/let-plus-20191130-git/README.org Normal file
View file

@ -0,0 +1,194 @@
#+TITLE: =let+=: destructuring extension of =let*=
#+AUTHOR: Tamás K. Papp
This library implements the =let+= macro, which is a dectructuring
extension of =let*=.
* Highlights
- clean, consistent syntax and small implementation (less than 300 LOC, not counting tests)
- placeholder macros allow editor hints and syntax highlighting
- =&ign= for ignored values (in forms where that makes sense)
- very easy to extend
* Similar libraries
This library was inspired by Gary King's excellent [[http://common-lisp.net/project/metabang-bind/][metabang-bind]]. I
have been using the latter for years now, but at some point I decided
to write a library of my own, aiming for a cleaner syntax, more
concise implementation and a more consistent interface (whether I have
succeeded is of course a matter of judgement --- try [[http://common-lisp.net/project/metabang-bind/][metabang-bind]] to
see if you like it better).
In my opinion the main advantages of this library, compared to
[[http://common-lisp.net/project/metabang-bind/][metabang-bind]], are the placeholder macros which provide editor hints
and the more consistent syntax of destructuring forms. In particular,
when both read-write and read-only forms are available the latter
always have the =-r/o= suffix, =&flet= and =&labels= resemble the
Common Lisp syntax more closely, and the library should be easier to
extend.
You can find other pattern matching libraries on [[http://www.cliki.net/pattern%20matching][cliki]].
* Syntax
#+BEGIN_SRC lisp
let+ ({binding}*) body*
#+END_SRC
where
#+BEGIN_SRC lisp
binding ::= symbol || (form [init-form])
#+END_SRC
=LET+= is recursive: each binding is in the scope of the previous
ones. Forms ignore =&ign= variables (where applicable).
** Built-in forms
Forms which provide both read-write and read-only access are available as =&form= and =&form-r/o=. The first one always uses symbol macros, so you can use =setf=. The second one reads the values at the beginning of the list from value: you can change these variables after that without having any effect on the original value. Read-only forms may also provide a slight increase in speed, and promote good style --- you can use them to signal that you will not change the original structure.
The following forms are defined:
- =var=, =(var)=, =(var value)= :: These behave just like they do in =let*=.
- =(list value)= :: When =list= is not recognized as any of the forms below, it is simply destructured using =destructuring-bind=. =&ign= are ignored. Example:
#+BEGIN_SRC lisp
(let+ (((a (b &optional (c 3)) &ign &key (d 1 d?)) '(1 (2) 7 :d 4)))
(list a b c d d?)) ; => (1 2 3 4 T)
#+END_SRC
- =((&slots slot*) value)=, also =&slots-r/o= :: Similarly to =with-slots=, each =slot= has the syntax =variable= or =(variable)= (for these, the variable name is also used for the slot name) or =(variable slot-name)=. =&slots-r/o= provides read-only bindings.
Example:
#+BEGIN_SRC lisp
(defclass foo-class ()
((a :accessor a :initarg :a)
(b :accessor b-accessor :initarg :b)))
(let+ (((&slots a (my-b b)) (make-instance 'foo-class :a 1 :b 2)))
(list a my-b)) ; => (1 2)
#+END_SRC
- =((&accessors accessor*) value)=, also =&accessors-r/o= :: Syntax similar to =&slots=, but uses accessors. Continuing the example above:
#+BEGIN_SRC lisp
(let+ (((&accessors a (b b-accessor)) (make-instance 'foo-class :a 1 :b 2)))
(list a b)) ; => (1 2)
#+END_SRC
- =((&structure conc-name slot*) value)=, also =&structure-r/o= :: Slot access for structures. =Conc-name= is prepended to the accessors (you need to include the =-= if there is one). Example:
#+BEGIN_SRC lisp
(defstruct foo-struct c d)
(let+ (((&structure foo-struct- c (my-d d)) (make-foo-struct :c 3 :d 4)))
(list c my-d)) ; => (3 4)
#+END_SRC
- =((&values value*) form)= :: Similar to =multiple-value-bind=. =&ign= are ignored. Example:
#+BEGIN_SRC lisp
(let+ (((&values a &ign b) (values 1 2 3)))
(list a b)) ; => (1 3)
#+END_SRC
- =(array value)= (only read-only version) :: The array is
destructured to the given elements, =&ign= are ignored. Indexes
use row-major access, determined at macroexpansion time.
Example:
#+BEGIN_SRC lisp
(let+ ((#(a &ign b) (vector 1 2 3)))
(list a b)) ; => (1 3)
#+END_SRC
- =((&array-elements (variable subscript*)*) value)=, also =&array-elements-r/o= :: Array elements with given subscripts are assigned to the variables. Example:
#+BEGIN_SRC lisp
(let+ (((&array-elements (a 0 1)
(b 2 0))
#2A((0 1)
(2 3)
(4 5))))
(list a b)) ; => (1 4)
#+END_SRC
- =((&flet name lambda-list forms*))=, also =&labels= :: Function bindings. These have no value form. =&labels= allows the function to refer to itself -- note that since =let+= is always recursive, this is the only difference between the two forms. Example:
#+BEGIN_SRC lisp
(let+ (((&flet add2 (x)
(+ x 2))))
(add2 5)) ; => 7
#+END_SRC
- =((&plist (variable key [default])*)=, also =&plist-r/o= :: Access to property lists. When =key= is not given, =variable= is used instead, and =default= is used if the element does not exist in the value (note that default may be evaluated multiple times when using the read-write form which uses =symbol-macrolet=). Example:
#+BEGIN_SRC lisp
(let+ (((&plist a (my-b b) (c nil 3)) '(a 1 b 2)))
(list a my-b c)) ; => (1 2 3)
#+END_SRC
- =(((&hash-table (variable key [default])*)=, also =&hash-table-r/o= :: Access to the elements of hash tables, the semantics is the same as =&plist=.
- =(&complex real imaginary)= :: Destructures complex numbers.
** Nesting
You can nest =let+= expressions when it makes sense (it doesn't always, especially for read/write slots, the read only form should work). For example,
#+BEGIN_SRC lisp
(let+ ((#((&complex a b)) (vector (complex 1 2))))
(list a b))
#+END_SRC
should destructure the complex number that is the single element in the vector.
If you find that =let+= does not nest properly, please report it as a bug.
** Convenience macros
- =(defun+ name (argument*) form*)=, also =(lambda (argument*) form*)= :: Work like =defun= and =lambda=, but arguments are destructured using =let+=. Example:
#+BEGIN_SRC lisp
(defun+ foo ((&plist a b c) #(d e))
(list a b c d e))
(foo '(a 1 b 2 c 3) #(4 5)) ; => (1 2 3 4 5)
#+END_SRC
See also =&labels+= and =&lambda+=.
- =define-structure-let+= :: Can be used to provide destructuring forms for structures.
** Other forms
- =(&once-only symbols ...)= and =(&with-gensyms symbols)= are useful for writing macros.
* Extensions
Extending =let-plus= is very easy: if you want to use a form that
resembles a list, you just have to define a method for
=let+-expansion-for-list=. There is a macro that helps you with that,
called =define-let+-expansion=. If the library didn't have
=&complex=, we could define destructuring for the form like this:
#+BEGIN_SRC lisp
(define-let+-expansion (&complex (x y))
"Access real and imaginary part of the value. Read-only."
`(let ((,x (realpart ,value))
(,y (imagpart ,value)))
,@body))
#+END_SRC
Some highlights:
- this macro defines a "placeholder" macro =&complex= that should
help with editor hints, but has no other purpose (it is not used in
the expansion),
- the macro is anaphoric, capturing =value= (the value form) and
=body= (the body inside the =let+= form), you can customize both of
this using keyword arguments,
- unless required otherwise, =value= is wrapped in =once-only=
preventing multiple evaluations of the same form. See the arguments =:uses-value?= and =:once-only?= for =define-let+-expansion=.
If you want to extend =let+= with forms that are not lists (eg like
the array syntax above), have a look at =let+-expansion=.
* Reporting bugs
Please open an [[https://github.com/sharplispers/let-plus/issues][issue]] on Github for bugs. Extensions are also welcome,
either as forks or small code snippets submitted as issues. Wishlist
items are also welcome!
I ask you not to report bugs via e-mail if you can avoid it. Tracking
bugs on Github makes it less likely that they get lost.

90
sbcl/.quicklisp/dists/quicklisp/software/let-plus-20191130-git/extensions.lisp Normal file
View file

@ -0,0 +1,90 @@
;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*-
(in-package #:let-plus)
(defun destructured-lambda-list-forms (lambda-list body)
"Return a list that can be spliced into function definitions (eg DEFUN, LAMBDA, FLET, LABELS).
The list starts with a lambda list, and is followed by a docstring (when provided), then a LET+ form that wraps declarations (when provided) and BODY.
Used internally, not exported."
(let+ (((&values body declarations documentation)
(parse-body body :documentation t))
((&values arguments bindings ignores)
(loop :for parameter :in lambda-list
:for argument = (gensym)
:collect argument :into arguments
:if (eq parameter '&ign) :collect argument :into ignores
:else :collect (list parameter argument) :into bindings
:finally (return (values arguments bindings ignores)))))
`(,arguments
,@(when documentation `(,documentation))
,@(when ignores `((declare (ignore ,@ignores))))
(let+ ,bindings
,@declarations
,@body))))
(define-let+-expansion (&flet+ (function-name lambda-list
&body function-body)
:uses-value? nil)
"&FLET that destructures its arguments using LET+."
`(let+ (((&flet ,function-name
,@(destructured-lambda-list-forms lambda-list function-body))))
,@body))
(define-let+-expansion (&labels+ (function-name lambda-list
&body function-body)
:uses-value? nil)
"&LABELS that destructures its arguments using LET+."
`(let+ (((&labels ,function-name
,@(destructured-lambda-list-forms lambda-list function-body))))
,@body))
(defmacro lambda+ (lambda-list &body body)
"LAMBDA that destructures its arguments using LET+."
`(lambda ,@(destructured-lambda-list-forms lambda-list body)))
(defmacro defun+ (name lambda-list &body body)
"DEFUN that destructures its arguments using LET+."
`(defun ,name ,@(destructured-lambda-list-forms lambda-list body)))
(defmacro define-structure-let+ ((name
&key (conc-name (symbolicate name #\-))
(r/w (symbolicate #\& name))
(r/o (symbolicate #\& name '#:-r/o)))
&rest slot-names)
"Define a LET+ expansion for accessing slots of a structure in a fixed order."
(let ((variable-name-pairs
(loop for slot-name in slot-names collect
``(,,slot-name ,',slot-name))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(define-let+-expansion (,r/w (,@slot-names))
,(format nil "LET+ form for slots of the structure ~A." name)
`(let+ (((&structure ,',conc-name ,,@variable-name-pairs) ,value))
,@body))
(define-let+-expansion (,r/o (,@slot-names))
,(format nil "LET+ form for slots of the structure ~A. Read-only."
name)
`(let+ (((&structure-r/o ,',conc-name ,,@variable-name-pairs)
,value))
,@body)))))
(define-let+-expansion (&fwrap (name))
"Wrap closure in the local function NAME. Calls to NAME will call the closure."
`(let+ (((&flet ,name (&rest arguments)
(apply ,value arguments))))
,@body))
(define-let+-expansion (&once-only specs :uses-value? nil)
"Expand to (ONCE-ONLY SPECS ...)."
`(once-only ,specs ,@body))
(define-let+-expansion (&with-gensyms names :uses-value? nil)
"Expand to (WITH-GENSYMS NAMES ...)."
`(with-gensyms ,names ,@body))
(define-let+-expansion (&complex (x y))
"Access real and imaginary part of the value. Read-only."
`(let ((,x (realpart ,value))
(,y (imagpart ,value)))
,@body))

25
sbcl/.quicklisp/dists/quicklisp/software/let-plus-20191130-git/let-plus.asd Normal file
View file

@ -0,0 +1,25 @@
(defsystem "let-plus"
:description "Destructuring extension of LET*."
:author "Tamas K. Papp <tkpapp@gmail.com>."
:maintainer "Sharp Lispers <sharplispers@googlegroups.com>"
:license "Boost Software License - Version 1.0"
:version "0.2"
:serial t
:components ((:file "package")
(:file "let-plus")
(:file "extensions"))
:depends-on ("alexandria"
"anaphora")
:in-order-to ((test-op (test-op "let-plus/tests"))))
(defsystem "let-plus/tests"
:description "Tests for the LET-PLUS library."
:author "Tamas K. Papp <tkpapp@gmail.com>."
:maintainer "Sharp Lispers <sharplispers@googlegroups.com>"
:license "Same as LET-PLUS -- this is part of the latter."
:serial t
:components ((:file "tests"))
:depends-on ("lift"
"let-plus")
:perform (test-op (operation component)
(uiop:symbol-call '#:let-plus-tests '#:run)))

336
sbcl/.quicklisp/dists/quicklisp/software/let-plus-20191130-git/let-plus.lisp Normal file
View file

@ -0,0 +1,336 @@
;;;; let-plus.lisp
(in-package #:let-plus)
;;; LET+ recognizes three general kinds of syntax for accessing elements in
;;; some structure (in the abstract sense):
;;;
;;; 1. "slots", of the form (VARIABLE &optional (SLOT VARIABLE)) SLOT is used
;;; in the general sense, it can also be an accessor. This is similar to
;;; the syntax of WITH-SLOTS etc.
;;;
;;; 2. "entries", of the form (VARIABLE &optional (KEY VARIABLE) DEFAULT),
;;; which allows a default value. This is used for hash tables, property
;;; lists, etc. If KEY is NIL, VARIABLE is used instead, if another
;;; symbol, it is quoted.
;;;
;;; 3. array-like reference (VARIABLE &rest SUBSCRIPTS). This is used for
;;; array elements.
;;;
;;; If a single symbol is given, it is used as a variable for entries and
;;; slots.
;;; Ignored variables
;;;
;;; The preferred method is expanding into LET+ forms which handle ignored
;;; values automatically -- LET+ just ignores these variables. Use
;;; REPLACE-IGNORED only when this is not feasible or desirable (eg using
;;; destructuring provided by CL).
(defun ignored? (symbol)
"Return a boolean determining if a variable is to be ignored.
NOTE: It is unlikely that you need to used this function, see the note above its definition."
(eq symbol '&ign))
(defun replace-ignored (tree)
"Replace ignored variables in TREE with a gensym, return a list of these as the second value.
NOTE: It is unlikely that you need to used this function, see the note above its definition."
(let (ignored)
(labels ((traverse (tree)
(if (atom tree)
(if (ignored? tree)
(aprog1 (gensym)
(push it ignored))
tree)
(cons (traverse (car tree))
(awhen (cdr tree) (traverse it))))))
(values (traverse tree) (nreverse ignored)))))
;;; LET+ uses generic functions for expansion. They are dispatched on the
;;; FORM, and further on the first element if it is a list. LET+-EXPANSION
;;; should wrap BODY in the desired forms, implementing the expansion. The
;;; recursive expansion of multiple forms is done by the LET+ macro.
;;;
;;; LET+ forms start with & (except for those expanding into LET(*) and
;;; DESTRUCTURING-BIND), although this convention is not enfored.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun &-symbol? (symbol)
"Test whether the symbol's name starts with a & character."
(char= (aref (symbol-name symbol) 0) #\&)))
(defgeneric let+-expansion (form value body)
(:documentation "Return an expansion for a LET+ form.")
(:method (form value body)
(declare (ignore value body))
(error "LET+ could not recognize ~A." form))
(:method ((variable null) value body)
`(destructuring-bind nil ,value
,@body))
(:method ((variable symbol) value body)
(cond
((ignored? variable) `(locally ,@body))
((&-symbol? variable)
(warn "Possibly left out one level of nesting in LET+ form (~A ~A)."
variable value))
(t `(let ((,variable ,@(when value `(,value))))
,@body))))
(:method ((form list) value body)
(let+-expansion-for-list (first form) (rest form) value body)))
(defgeneric let+-expansion-for-list (first rest value body)
(:documentation "LET+-EXPANSION calls this for lists, see the latter for semantics of returned values.")
(:method (first rest value body)
;; forms not recognized as anything else are destructured
(when (and (symbolp first) (not (ignored? first)) (&-symbol? first)
(not (find first lambda-list-keywords)))
(warn "~A looks like a LET+ keyword, but it has no expansion method defined. Treating it as a lambda list." first))
(let ((form (cons first rest)))
(multiple-value-bind (form ignored) (replace-ignored form)
`(destructuring-bind ,form ,value
(declare (ignore ,@ignored))
,@body)))))
(defmacro let+ (bindings &body body)
"Destructuring bindings. See the documentation of the LET-PLUS library. Most accepted forms start with &."
(labels ((expand (bindings)
(destructuring-bind (binding &rest other-bindings) bindings
(destructuring-bind (form &optional value)
(ensure-list binding)
(let+-expansion form value (aif other-bindings
(list (expand it))
body))))))
(if bindings
(expand bindings)
`(locally ,@body))))
(defmacro define-let+-expansion ((name arguments &key
(value-var 'value)
(body-var 'body)
(uses-value? t)
(once-only? uses-value?))
&body body)
"Define an expansion for LET+ forms which are lists, starting with NAME. ARGUMENTS is destructured if a list. A placeholder macro is defined with NAME, using DOCSTRING and ARGUMENTS. The value form is bound to VALUE-VAR (wrapped in ONCE-ONLY when ONCE-ONLY?), while the body is bound to BODY-VAR. USES-VALUE? determines if the form uses a value, and generates the appropriate checks."
(let ((arguments-var (gensym "ARGUMENTS"))
(arguments (if (listp arguments)
arguments
`(&rest ,arguments)))
(whole (gensym "WHOLE")))
(multiple-value-bind (remaining-forms declarations docstring)
(parse-body body :documentation t)
(sunless docstring (setf it (format nil "LET+ form ~A." name)))
`(progn
(defmacro ,name (&whole ,whole ,@arguments)
,docstring
(declare (ignore
,@(remove-if (lambda (symbol)
(or (not symbol)
(not (symbolp symbol))
(keywordp symbol)
(find symbol lambda-list-keywords)
(&-symbol? symbol)))
(flatten arguments))))
,@declarations
,whole)
(defmethod let+-expansion-for-list ((first (eql ',name))
,arguments-var ,value-var
,body-var)
,(if uses-value?
`(assert ,value-var () "Missing value form in ~A." ',name)
`(assert (not ,value-var) ()
"~A forms don't take a value." ',name))
,(let ((core `(destructuring-bind ,arguments ,arguments-var
,@declarations
,@remaining-forms)))
(if once-only? ; basically once-only, with ignorable value
(with-unique-names (value-once-var)
`(let ((,value-once-var (gensym "VALUE")))
`(let ((,,value-once-var ,,value-var))
(declare (ignorable ,,value-once-var))
,(let ((,value-var ,value-once-var))
,core))))
core)))))))
;;; Definitions for particular LET+ forms.
;;;
;;; When both read only and read/write forms make sense, the former should
;;; have the suffix -r/o and the latter should be without the suffix in order
;;; to maintain a consistent naming scheme.
;;; helper functions
(defun expand-slot-forms (slots accessor-generator)
"Return a list of expanded bindings, calling (ACCESSOR-GENERATOR KEY)"
(let (bindings)
(loop for entry :in slots do
(destructuring-bind (variable &optional (key variable))
(ensure-list entry)
(when variable
(push `(,variable ,(funcall accessor-generator key)) bindings))))
(nreverse bindings)))
(defun expand-entry-forms (entries accessor-generator)
"Return a list of expanded bindings from ENTRIES, calling (ACESSOR-GENERATOR KEY DEFAULT). Each entry is (VARIABLE &OPTIONAL KEY DEFAULT). When KEY is NIL, VARIABLE is used."
(mapcar (lambda (entry)
(destructuring-bind (variable &optional key default)
(ensure-list entry)
`(,variable ,(funcall accessor-generator
(typecase key
(null `',variable)
(symbol `',key)
(t key))
default))))
entries))
(defun expand-array-elements (value array-elements &optional (accessor 'aref))
"Expand a list of (BINDING &REST SUBSCRIPTS) forms to a list of bindings of the form (ACCESSOR VALUE SUBSCRIPTS)."
(mapcar (lambda (array-element)
`(,(first array-element)
(,accessor ,value ,@(rest array-element))))
array-elements))
(define-let+-expansion (&accessors accessors)
"LET+ form, similar to WITH-ACCESSORS."
`(symbol-macrolet ,(expand-slot-forms accessors (lambda (accessor)
`(,accessor ,value)))
,@body))
(define-let+-expansion (&accessors-r/o accessors)
"LET+ form, similar to WITH-ACCESSORS, but read-only."
`(let+ ,(expand-slot-forms accessors (lambda (accessor)
`(,accessor ,value)))
,@body))
(define-let+-expansion (&slots slots :once-only? nil)
"LET+ form, similar to WITH-SLOTS."
`(with-slots ,slots ,value
,@body))
(define-let+-expansion (&slots-r/o slots)
"LET+ form, similar to WITH-SLOTS but read-only."
`(let+ ,(expand-slot-forms slots
(lambda (slot) `(slot-value ,value ',slot)))
,@body))
(define-let+-expansion (&structure (conc-name &rest slots))
"LET+ form for slots of a structure, with accessors generated using CONC-NAME."
(check-type conc-name symbol)
`(symbol-macrolet
,(expand-slot-forms slots
(lambda (slot) `(,(symbolicate conc-name slot)
,value)))
,@body))
(define-let+-expansion (&structure-r/o (conc-name &rest slots))
"LET+ form for slots of a structure, with accessors generated using CONC-NAME. Read-only version."
(check-type conc-name symbol)
`(let+ ,(expand-slot-forms slots
(lambda (slot)
`(,(symbolicate conc-name slot) ,value)))
,@body))
(define-let+-expansion (&values values :once-only? nil)
"LET+ form for multiple values."
(let ((values-and-temps (mapcar (lambda (v) (list v (gensym))) values)))
`(multiple-value-bind ,(mapcar #'second values-and-temps) ,value
(declare (ignore ,@(loop for (v g) in values-and-temps
when (ignored? v)
collect g)))
(let+ ,(remove-if (compose #'ignored? #'car) values-and-temps)
,@body))))
(defmethod let+-expansion ((array array) value body)
"LET+ expansion for mapping array elements to variables."
(let (bindings
(value-var (gensym "VALUE")))
(dotimes (row-major-index (array-total-size array))
(let ((variable (row-major-aref array row-major-index)))
(unless (ignored? variable)
(push `(,variable
(row-major-aref ,value-var ,row-major-index))
bindings))))
`(let ((,value-var ,value))
(assert (equal (array-dimensions ,value-var)
',(array-dimensions array)))
(let+ ,(nreverse bindings)
,@body))))
(define-let+-expansion (&array-elements array-elements)
"LET+ form, mapping (variable &rest subscripts) specifications to array-elements. VARIABLE is an accessor, which can be used for reading and writing array elements."
`(symbol-macrolet ,(expand-array-elements value array-elements)
,@body))
(define-let+-expansion (&array-elements-r/o array-elements)
"LET+ form, mapping (variable &rest subscripts) specifications to array-elements. Read-only accessor, values assigned to VARIABLEs."
(once-only (value)
`(let+ ,(expand-array-elements value array-elements)
,@body)))
(define-let+-expansion (&flet (function-name lambda-list
&body function-body)
:uses-value? nil)
"LET+ form for function definitions. Expands into an FLET."
`(flet ((,function-name ,lambda-list ,@function-body))
,@body))
(defmacro mergable-labels (bindings &body body)
`(labels ,bindings ,@body))
(define-let+-expansion (&labels (function-name lambda-list
&body function-body)
:uses-value? nil)
"LET+ form for function definitions. Expands into an LABELS, thus allowing recursive functions."
(if (typep (first body) '(cons (eql mergable-labels)))
(destructuring-bind (bindings &rest first-body) (rest (first body))
(assert (null (rest body)))
`(mergable-labels ((,function-name ,lambda-list ,@function-body)
,@bindings)
,@first-body
,@(rest body)))
`(mergable-labels ((,function-name ,lambda-list ,@function-body))
,@body)))
(define-let+-expansion (&macrolet (macro-name lambda-list &body macro-body)
:uses-value? nil)
"LET+ form for local macro definitions. Expands into an MACROLET."
`(macrolet ((,macro-name ,lambda-list ,@macro-body))
,@body))
(define-let+-expansion (&symbol-macrolet (symbol expansion) :uses-value? nil)
"LET+ form for local symbol macros. Expands into a SYMBOL-MACROLET."
`(symbol-macrolet ((,symbol ,expansion))
,@body))
(define-let+-expansion (&plist entries)
"LET+ form for property lists. Each entry is (variable &optional key default)."
`(symbol-macrolet
,(expand-entry-forms entries
(lambda (key default)
`(getf ,value ,key ,default)))
,@body))
(define-let+-expansion (&plist-r/o entries)
"LET+ form for property lists, read only version. Each entry is (variable &optional key default)."
`(let* ,(expand-entry-forms entries
(lambda (key default)
`(getf ,value ,key ,default)))
,@body))
(define-let+-expansion (&hash-table entries)
"LET+ form for hash tables. Each entry is (variable &optional key default)."
`(symbol-macrolet
,(expand-entry-forms entries
(lambda (key default)
`(gethash ,key ,value ,default)))
,@body))
(define-let+-expansion (&hash-table-r/o entries)
"LET+ form for hash tables. Each entry is (variable &optional key default). Read only version."
`(let+ ,(expand-entry-forms entries
(lambda (key default) `(gethash ,key ,value ,default)))
,@body))

37
sbcl/.quicklisp/dists/quicklisp/software/let-plus-20191130-git/package.lisp Normal file
View file

@ -0,0 +1,37 @@
;;;; package.lisp
(defpackage #:let-plus
(:use #:cl #:alexandria #:anaphora)
(:export ; basic user interface
#:let+
#:&ign
#:&accessors
#:&accessors-r/o
#:&slots
#:&slots-r/o
#:&structure
#:&structure-r/o
#:&values
#:&array-elements
#:&array-elements-r/o
#:&flet #:&labels
#:&macrolet
#:&symbol-macrolet
#:&plist
#:&plist-r/o
#:&hash-table
#:&hash-table-r/o)
(:export ; defining new forms
#:let+-expansion
#:let+-expansion-for-list
#:define-let+-expansion)
(:export ; extensions
#:&flet+
#:&labels+
#:lambda+
#:defun+
#:define-structure-let+
#:&fwrap
#:&once-only
#:&with-gensyms
#:&complex))

290
sbcl/.quicklisp/dists/quicklisp/software/let-plus-20191130-git/tests.lisp Normal file
View file

@ -0,0 +1,290 @@
;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*-
(defpackage #:let-plus-tests
(:use #:cl #:alexandria #:lift #:let-plus)
(:export #:run))
(in-package #:let-plus-tests)
(deftestsuite let-plus-tests () ())
(defun run ()
"Run all the tests for LET-PLUS."
(run-tests :suite 'let-plus-tests))
(defmacro test-r/o-and-r/w (init-form bindings r/o-form r/w-form
&key (add 7)
(modified-variable (caar bindings)))
"Macro for autogenerating tests for testing read-only and read-write access.
INIT-FORM is evaluated and bound to a value, which is then bound using LET+
with r/o-form (for read only access) and r/w-form for (read and write access).
Values are compared to bindings (which are of the form (VARIABLE VALUE), where
value should be numeric. MODIFIED-VARIABLE is modified, by adding ADD and
checked for consistency (r/o form should not modify value, while r/w form
should)."
(with-unique-names (object)
(once-only (add)
`(let ((,object ,init-form))
(let+ ((,r/o-form ,object))
,@(loop for (var value) in bindings
collect `(ensure-same ,var ,value))
(incf ,modified-variable ,add))
(let+ ((,r/w-form ,object))
,@(loop for (var value) in bindings
collect `(ensure-same ,var ,value))
(incf ,modified-variable ,add))
(let+ ((,r/o-form ,object))
(ensure-same ,(caar bindings) (+ ,add ,(cadar bindings))))))))
(addtest (let-plus-tests)
test-let*-compatibility
(let+ (a
(b 1)
(c (+ b 3)))
(ensure-same a nil)
(ensure-same b 1)
(ensure-same c 4)))
(addtest (let-plus-tests)
test-unrecognized-form
(ensure-warning (macroexpand '(let+ (((&does-not-exist a b) '(1 2 3)))))))
(defclass foo ()
((bar :accessor bar :initarg :bar)
(baz :accessor baz-acc :initarg :baz))
(:documentation "Class for testing purposes."))
(addtest (let-plus-tests)
test-slots
(test-r/o-and-r/w (make-instance 'foo :bar 1 :baz 2)
((bar 1) (baz2 2))
(&slots-r/o bar (baz2 baz))
(&slots bar (baz2 baz))))
(addtest (let-plus-tests)
test-accessors
(test-r/o-and-r/w (make-instance 'foo :bar 1 :baz 2)
((bar 1) (baz 2))
(&accessors-r/o bar (baz baz-acc))
(&accessors bar (baz baz-acc))))
(defstruct foo2
"Structure for testing purposes."
bar baz)
(addtest (let-plus-tests)
test-structure
(test-r/o-and-r/w (make-foo2 :bar 1 :baz 2)
((bar 1) (baz 2))
(&structure-r/o foo2- bar (baz baz))
(&structure foo2- bar (baz baz))))
(addtest (let-plus-tests)
test-values
(let+ (((&values a &ign c) (values 1 2 3)))
(ensure-same a 1)
(ensure-same c 3)))
(addtest (let-plus-tests)
test-values-recursive
(let+ (((&values (a b) &ign c) (values '(1 4) 2 3)))
(ensure-same a 1)
(ensure-same b 4)
(ensure-same c 3)))
(declaim (notinline two-element-vector))
(defun two-element-vector ()
#(1 2))
(addtest (let-plus-tests)
test-array
(let+ ((#2A((a &ign) (b c)) #2A((1 2) (3 4))))
(ensure-same a 1)
(ensure-same b 3)
(ensure-same c 4))
(ensure-error (let+ ((#(a b c) (two-element-vector))))))
(addtest (let-plus-tests)
test-array-elements
(test-r/o-and-r/w (make-array '(2 2) :initial-contents '((1 2) (3 4)))
((a 1) (b 3) (c 4))
(&array-elements-r/o (a 0 0)
(b 1 0)
(c 1 1))
(&array-elements (a 0 0)
(b 1 0)
(c 1 1))))
(addtest (let-plus-tests)
test-flet
(let+ (((&flet add1 (x)
(1+ x)) ))
(ensure-same (add1 2) 3)))
(addtest (let-plus-tests)
test-labels
(let+ (((&labels my-factorial (x)
(if (<= 2 x)
(* x (my-factorial (1- x)))
1))))
(ensure-same (my-factorial 4) 24)))
(addtest (let-plus-tests)
test-labels/mutual-recursion
(let+ (((&labels my-even? (x)
(cond
((zerop x)
t)
((plusp x)
(my-odd? (1- x)))
(t
nil))))
((&labels my-odd? (x)
(my-even? (1- x)))))
(ensure-same (my-odd? 4) nil)
(ensure-same (my-even? 4) t)
(ensure-same (my-odd? 5) t)
(ensure-same (my-even? 5) nil)))
(defun labels-test-function ()
10)
(addtest (let-plus-tests)
test-labels/dont-splice
(ensure-same (let+ (((&labels foo () (labels-test-function))))
(labels ((labels-test-function () 5))
(labels-test-function))
(foo))
10)
(ensure-same (let+ (((&labels foo () (labels-test-function))))
(labels ((labels-test-function () 5))
(values (foo) (labels-test-function))))
(values 10 5))
(ensure-same (let+ (((&labels foo () (labels-test-function))))
(let+ (((&labels labels-test-function () 5)))
(values (foo) (labels-test-function))))
(values 10 5)))
(addtest (let-plus-tests)
test-plist
(test-r/o-and-r/w (list 'a 1 :b 2 'c '3)
((a 1) (b 2) (c 3) (d 4))
(&plist-r/o a (b :b) (c nil) (d nil 4))
(&plist a (b :b) (c nil) (d nil 4))))
(addtest (let-plus-tests)
test-hash-table
(test-r/o-and-r/w (let ((table (make-hash-table)))
(setf (gethash 'a table) 1
(gethash :b table) 2
(gethash 'c table) 3)
table)
((a 1) (b 2) (c 3) (d 4))
(&hash-table-r/o a (b :b) (c nil) (d nil 4))
(&hash-table a (b :b) (c nil) (d nil 4))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defstruct ab
"A structure for testing defstruct+."
a b)
(define-structure-let+ (ab) a b))
(addtest (let-plus-tests)
test-defstruct+
(test-r/o-and-r/w (make-ab :a 3 :b 7)
((aa 3) (bb 7))
(&ab-r/o aa bb)
(&ab aa bb)))
(addtest (let-plus-tests)
test-fwrap
(let+ (((&fwrap add) (lambda (a b &key (c 0)) (+ a b c))))
(ensure-same (add 1 2) 3)
(ensure-same (add 1 2 :c 3) 6)))
(addtest (let-plus-tests)
test-flet+
(ensure-same (let+ (((&flet+ add3 (#(a b c))
(+ a b c))))
(add3 #(1 2 3)))
6))
(addtest (let-plus-tests)
test-labels+
(let+ (((&labels+ foo ((a . b))
(if a
(foo (cons (cdr a) (cons (car a) b)))
b))))
(ensure-same (foo '((1 2 3) . nil)) '(3 2 1)))
(ensure-no-warning
(compile nil '(lambda (x)
(let+ (((&labels+ foo (&ign)))) (foo x))))))
(addtest (let-plus-tests)
test-defun+
(defun+ foo ((a . b))
"bar"
(+ a b))
(ensure-same (foo '(1 . 2)) 3)
(ensure-same (documentation 'foo 'function) "bar" :test #'string=)
(let ((expansion (macroexpand-1
'(defun+ foo ((a . b))
"foo docstring"
(declare (type integer a b))
(+ a b)))))
(ensure-same 'defun (first expansion))
(ensure-same 'foo (second expansion))
(ensure-same "foo docstring" (fourth expansion))
(let ((let+-expansion (fifth expansion)))
(ensure-same 'let+ (first let+-expansion))
(ensure-same '(declare (type integer a b)) (third let+-expansion))
(ensure-same '(+ a b) (fourth let+-expansion)))))
(addtest (let-plus-tests)
test-&warning
(ensure-warning
(macroexpand '(let+ ((&foo 1)) &foo)))
(ensure-warning
(macroexpand '(let+ ((&foo)) &foo)))
(ensure-warning
(macroexpand '(let+ (&foo) &foo))))
(addtest (let-plus-tests)
test-empty-let+
(ensure-same (let+ nil 1) 1 :test #'eql))
(addtest (let-plus-tests)
test-recursive-let+
(ensure-same (let+ ((#((a . b)) (vector (cons 1 2))))
(values a b))
(values 1 2))
;; (ensure-same (let+ (((#(a) #(b c)) (cons #(1) #(2 3))))
;; (values a b c))
;; (values 1 2 3))
)
(addtest (let-plus-tests)
test-complex
(let ((c #C(3 5)))
(let+ (((&complex x y) c))
(ensure-same x 3)
(ensure-same y 5))))
(addtest (let-plus-tests)
test-nil
(ensure (let+ ((() '())) t))
(ensure-error (let+ ((() '(1)))))
;; (ensure-error (let+ ((() 1))))
)
(addtest (let-plus-tests)
test-empty-let+-with-declaration
(ensure-same (let+ ()
(declare (optimize speed))
t)
t)
(ensure-same (let+ ((&ign 1))
(declare (optimize speed))
t)
t))