Vim window logic, slimv

sbcl/.quicklisp/dists/quicklisp/software/anaphora-20191007-git/symbolic.lisp

@@ -0,0 +1,54 @@
+;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*-
+
+;;;; Copyright (c) 2003 Brian Mastenbrook
+
+;;;; Permission is hereby granted, free of charge, to any person obtaining
+;;;; a copy of this software and associated documentation files (the
+;;;; "Software"), to deal in the Software without restriction, including
+;;;; without limitation the rights to use, copy, modify, merge, publish,
+;;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;;; permit persons to whom the Software is furnished to do so, subject to
+;;;; the following conditions:
+
+;;;; The above copyright notice and this permission notice shall be
+;;;; included in all copies or substantial portions of the Software.
+
+;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(in-package :anaphora)
+
+(defmacro internal-symbol-macrolet (&rest whatever)
+  `(symbol-macrolet ,@whatever))
+
+(define-setf-expander internal-symbol-macrolet (binding-forms place &environment env)
+  (multiple-value-bind (dummies vals newvals setter getter)
+      (get-setf-expansion place env)
+    (values dummies
+	    (substitute `(symbol-macrolet ,binding-forms it) 'it vals)
+	    newvals
+	    `(symbol-macrolet ,binding-forms ,setter)
+	    `(symbol-macrolet ,binding-forms ,getter))))
+
+(with-unique-names (s-indicator current-s-indicator)
+  (defmacro symbolic (operation test &rest other-args)
+    (with-unique-names (this-s)
+      (let ((current-s (get s-indicator current-s-indicator)))
+        (setf (get s-indicator current-s-indicator) this-s)
+        `(symbol-macrolet
+             ((,this-s (internal-symbol-macrolet ((it ,current-s)) ,test))
+              (it ,this-s))
+           (,operation it ,@other-args)))))
+
+  (defmacro anaphoric (op test &body body)  
+    (with-unique-names (this-s)
+      (setf (get s-indicator current-s-indicator) this-s)
+      `(let* ((it ,test)
+              (,this-s it))
+         (declare (ignorable ,this-s))
+         (,op it ,@body)))))