├── .travis.yml ├── LICENSE ├── README.md ├── VERSION ├── circle.yml ├── docs ├── README.md └── _config.yml ├── let-over-lambda-test.asd ├── let-over-lambda.asd ├── let-over-lambda.lisp ├── package.lisp └── t └── let-over-lambda.lisp /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | 3 | sudo: required 4 | 5 | env: 6 | matrix: 7 | - LISP=sbcl COVERALLS=true 8 | - LISP=ccl 9 | # - LISP=clisp 10 | # - LISP=ecl 11 | # - LISP=abcl 12 | 13 | install: 14 | - if [ -x ./install.sh ] && head -2 ./install.sh | grep '^# cl-travis' > /dev/null; 15 | then 16 | ./install.sh; 17 | else 18 | curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | sh; 19 | fi 20 | # Coveralls support 21 | - git clone https://github.com/fukamachi/cl-coveralls ~/lisp/cl-coveralls 22 | 23 | script: 24 | - cl -l prove -l cl-coveralls 25 | -e '(in-package :cl-user)' 26 | -e '(ql:quickload :let-over-lambda)' 27 | -e '(setf prove:*debug-on-error* t)' 28 | -e '(setf *debugger-hook* 29 | (lambda (c h) 30 | (declare (ignore c h)) 31 | (uiop:quit -1)))' 32 | -e '(coveralls:with-coveralls (:exclude (list "t")) 33 | (or (prove:run :let-over-lambda-test) 34 | (uiop:quit -1)))' 35 | 36 | notifications: 37 | webhooks: 38 | urls: 39 | - https://webhooks.gitter.im/e/fba7308ceb6194ceb9ff 40 | on_success: change # options: [always|never|change] default: always 41 | on_failure: always # options: [always|never|change] default: always 42 | on_start: false # default: false 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The BSD License (BSD Simplified) 2 | 3 | Copyright (c) 2002--2008, Doug Hoyte, HCSW 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 7 | 8 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 9 | 10 | 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. 11 | 12 | Neither the name of HCSW nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 13 | 14 | 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 HOLDER 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. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # LET-OVER-LAMBDA 2 | 3 | [![Build Status](https://circleci.com/gh/thephoeron/let-over-lambda.svg?style=shield)](https://circleci.com/gh/thephoeron/let-over-lambda) 4 | [![Build Status](https://travis-ci.org/thephoeron/let-over-lambda.svg?branch=master)](https://travis-ci.org/thephoeron/let-over-lambda) 5 | [![Coverage Status](https://coveralls.io/repos/thephoeron/let-over-lambda/badge.svg?branch=master)](https://coveralls.io/r/thephoeron/let-over-lambda) 6 | [![Quicklisp](https://quickdocs.org/badge/let-over-lambda.svg)](https://quickdocs.org/let-over-lambda/) 7 | [![BSD Simplified License](https://img.shields.io/badge/license-BSD%20Simplified-blue.svg)](./LICENSE) 8 | [![Join the chat at https://gitter.im/thephoeron/let-over-lambda](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/thephoeron/let-over-lambda?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) 9 | 10 | Doug Hoyte's "Production" version of macros from Let Over Lambda, including community updates; available from Quicklisp. 11 | 12 | Read more about the book and code at: http://letoverlambda.com 13 | 14 | ## News & Updates 15 | 16 | ##### 8/02/2023 17 | 18 | Extend LOL-SYNTAX named-readtable to include FARE-QUASIQUOTE. 19 | 20 | ##### 3/19/2015 21 | 22 | Add symbols for anaphoric macro internals, `IT`, `THIS`, and `SELF` to package exports for better end-user experience. Will be available in April 2015 release of Quicklisp. 23 | 24 | ##### 8/14/2014 25 | 26 | Issue with incompatible change to backquote syntax in SBCL 1.2.2 resolved; tested against and builds on SBCL 1.2.0-1 and 1.2.2. Will be available in the August release of Quicklisp. 27 | 28 | ##### 12/18/2013 29 | 30 | Now available in the December 2013 distribution of Quicklisp 31 | 32 | ## Usage 33 | 34 | Make sure you have the latest Quicklisp distribution, then include it as a dependency in your system definition, or from the REPL evaluate `(ql:quickload "let-over-lambda")`. 35 | 36 | ```lisp 37 | (ql:quickload "let-over-lambda") 38 | (lol:flatten '((A . B) (C . D) (E . (F G H (I . J) . K)))) 39 | => (A B C D E F G H I J K) 40 | ``` 41 | 42 | LET-OVER-LAMBDA now uses the `named-readtables` library instead of modifying the global readtable. To use LOL reader macros in your Lisp source files, you will have to add both `let-over-lambda` and `named-readtables` to your project dependencies, and the following line after your call to `in-package`, in every source file you wish to use LOL syntax: 43 | 44 | ```lisp 45 | (named-readtables:in-readtable lol:lol-syntax) 46 | ``` 47 | 48 | ## Authors and Contributors 49 | 50 | - [Doug Hoyte](https://github.com/hoytech) 51 | - ["the Phoeron" Colin J.E. Lupton](https://github.com/thephoeron) 52 | - [Jorge Gajon](https://github.com/gajon) 53 | - [André Miranda](https://github.com/EuAndreh/) 54 | 55 | ## License 56 | 57 | Copyright © 2008–2023, the Authors. Released under the BSD License 58 | (BSD Simplified). Please see [`LICENSE`](./LICENSE) for details. 59 | -------------------------------------------------------------------------------- /VERSION: -------------------------------------------------------------------------------- 1 | "1.1.0" 2 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | machine: 2 | environment: 3 | PATH: ~/.roswell/bin:$PATH 4 | 5 | dependencies: 6 | pre: 7 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/release/scripts/install-for-ci.sh | sh 8 | - case $CIRCLE_NODE_INDEX in 9 | 0) ros config set default.lisp sbcl-bin ;; 10 | 1) ros install ccl-bin; 11 | ros config set default.lisp ccl-bin ;; 12 | esac 13 | - ros run -- --version 14 | override: 15 | - git clone https://github.com/fukamachi/cl-coveralls ~/lisp/cl-coveralls 16 | - git clone https://github.com/fukamachi/prove ~/lisp/prove 17 | - ros -l ~/lisp/prove/prove.asd install prove 18 | 19 | test: 20 | override: 21 | - if [ "$CIRCLE_NODE_INDEX" = 0 ]; then COVERALLS=true run-prove let-over-lambda-test.asd; else run-prove let-over-lambda-test.asd; fi: {parallel: true} 22 | -------------------------------------------------------------------------------- /docs/README.md: -------------------------------------------------------------------------------- 1 | # Documentation 2 | 3 | Reference implementation of source-code from Doug Hoyte's book, Let Over Lambda. 4 | 5 | --- 6 | 7 | Copyright © 2022, "the Phoeron" Colin J.E. Lupton. 8 | 9 | Back to [//thephoeron.github.io](https://thephoeron.github.io) 10 | 11 | -------------------------------------------------------------------------------- /docs/_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-hacker -------------------------------------------------------------------------------- /let-over-lambda-test.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LET-OVER-LAMBDA-TEST-ASD; Base: 10 -*- 2 | ;;;; file: let-over-lambda-test.asd 3 | 4 | (in-package :cl-user) 5 | 6 | (defpackage let-over-lambda-test-asd 7 | (:use :cl :asdf)) 8 | 9 | (in-package :let-over-lambda-test-asd) 10 | 11 | (defsystem #:let-over-lambda-test 12 | :serial t 13 | :version "1.0.1" 14 | :description "The test code for Let Over Lambda." 15 | :author "André Miranda " 16 | :maintainer "\"the Phoeron\" Colin J.E. Lupton " 17 | :license "BSD Simplified" 18 | :depends-on (#:let-over-lambda 19 | #:prove 20 | #:named-readtables) 21 | :components ((:module "t" 22 | :components 23 | ((:test-file "let-over-lambda")))) 24 | 25 | :defsystem-depends-on (prove-asdf) 26 | :perform (test-op :after (op c) 27 | (funcall (intern #.(string :run-test-system) :prove-asdf) c) 28 | (asdf:clear-system c))) 29 | 30 | ;; EOF 31 | -------------------------------------------------------------------------------- /let-over-lambda.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LET-OVER-LAMBDA; Base: 10 -*- file: let-over-lambda.asd 2 | 3 | (in-package :cl-user) 4 | 5 | (defpackage let-over-lambda/asdf 6 | (:nicknames let-over-lambda/sys lol/sys) 7 | (:use cl asdf uiop) 8 | (:export #:*lol-version*)) 9 | 10 | (in-package :let-over-lambda/asdf) 11 | 12 | (defsystem let-over-lambda 13 | :description "The Production version code from letoverlambda.com, conveniently wrapped in an ASDF System for Quicklisp." 14 | :author "Doug Hoyte " 15 | :maintainer "\"the Phoeron\" Colin J.E. Lupton " 16 | :homepage "https://thephoeron.github.io/let-over-lambda/" 17 | :source-control (:git "https://github.com/thephoeron/let-over-lambda.git") 18 | :bug-tracker "https://github.com/thephoeron/let-over-lambda/issues" 19 | :version (:read-file-form "VERSION") 20 | :license "BSD Simplified" 21 | :depends-on (alexandria 22 | cl-ppcre 23 | named-readtables 24 | fare-quasiquote-extras) 25 | :serial t 26 | :components ((:file "package") 27 | (:file "let-over-lambda")) 28 | :in-order-to ((test-op (test-op let-over-lambda-test)))) 29 | 30 | (defparameter *lol-version* (asdf:component-version (asdf:find-system :let-over-lambda)) 31 | "A string denoting the current version of LET-OVER-LAMBDA. Used for diagnostic output.") 32 | 33 | ;; EOF 34 | -------------------------------------------------------------------------------- /let-over-lambda.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LET-OVER-LAMBDA; Base: 10 -*- file: let-over-lambda.lisp 2 | 3 | (in-package :let-over-lambda) 4 | 5 | (named-readtables:in-readtable :fare-quasiquote) 6 | 7 | ;; Antiweb (C) Doug Hoyte 8 | 9 | ;; This is a "production" version of LOL with bug-fixes 10 | ;; and new features in the spirit of the book. 11 | 12 | ;; See http://letoverlambda.com 13 | 14 | ;; This is the source code for the book 15 | ;; _Let_Over_Lambda_ by Doug Hoyte. 16 | ;; This code is (C) 2002-2008, Doug Hoyte. 17 | ;; 18 | ;; You are free to use, modify, and re-distribute 19 | ;; this code however you want, except that any 20 | ;; modifications must be clearly indicated before 21 | ;; re-distribution. There is no warranty, 22 | ;; expressed nor implied. 23 | ;; 24 | ;; Attribution of this code to me, Doug Hoyte, is 25 | ;; appreciated but not necessary. If you find the 26 | ;; code useful, or would like documentation, 27 | ;; please consider buying the book! 28 | 29 | ;; Modifications by "the Phoeron" Colin J.E. Lupton, 2012--2023 30 | ;; - Support for ASDF/Quicklisp 31 | ;; - Cheap hacks to support new Backquote implementation in SBCL v1.2.2 32 | 33 | ;; Safety feature for SBCL>=v1.2.2 34 | #+sbcl 35 | (eval-when (:compile-toplevel :execute) 36 | (handler-case 37 | (progn 38 | (sb-ext:assert-version->= 1 2 2) 39 | (setq *features* (remove 'old-sbcl *features*))) 40 | (error () 41 | (pushnew 'old-sbcl *features*)))) 42 | 43 | (defun group (source n) 44 | (if (zerop n) (error "zero length")) 45 | (labels ((rec (source acc) 46 | (let ((rest (nthcdr n source))) 47 | (if (consp rest) 48 | (rec rest (cons 49 | (subseq source 0 n) 50 | acc)) 51 | (nreverse 52 | (cons source acc)))))) 53 | (if source (rec source nil) nil))) 54 | 55 | (eval-when (:compile-toplevel :execute :load-toplevel) 56 | (defun mkstr (&rest args) 57 | (with-output-to-string (s) 58 | (dolist (a args) (princ a s)))) 59 | 60 | (defun symb (&rest args) 61 | (values (intern (apply #'mkstr args)))) 62 | 63 | (defun flatten (x) 64 | (labels ((rec (x acc) 65 | (cond ((null x) acc) 66 | #+(and sbcl (not lol::old-sbcl)) 67 | ((typep x 'sb-impl::comma) (rec (sb-impl::comma-expr x) acc)) 68 | ((atom x) (cons x acc)) 69 | (t (rec 70 | (car x) 71 | (rec (cdr x) acc)))))) 72 | (rec x nil))) 73 | 74 | (defun g!-symbol-p (s) 75 | (and (symbolp s) 76 | (> (length (symbol-name s)) 2) 77 | (string= (symbol-name s) 78 | "G!" 79 | :start1 0 80 | :end1 2))) 81 | 82 | (defun o!-symbol-p (s) 83 | (and (symbolp s) 84 | (> (length (symbol-name s)) 2) 85 | (string= (symbol-name s) 86 | "O!" 87 | :start1 0 88 | :end1 2))) 89 | 90 | (defun o!-symbol-to-g!-symbol (s) 91 | (symb "G!" 92 | (subseq (symbol-name s) 2)))) 93 | 94 | (defmacro defmacro/g! (name args &rest body) 95 | (let ((syms (remove-duplicates 96 | (remove-if-not #'g!-symbol-p 97 | (flatten body))))) 98 | (multiple-value-bind (body declarations docstring) 99 | (parse-body body :documentation t) 100 | `(defmacro ,name ,args 101 | ,@(when docstring 102 | (list docstring)) 103 | ,@declarations 104 | (let ,(mapcar 105 | (lambda (s) 106 | `(,s (gensym ,(subseq 107 | (symbol-name s) 108 | 2)))) 109 | syms) 110 | ,@body))))) 111 | 112 | (defmacro defmacro! (name args &rest body) 113 | (let* ((os (remove-if-not #'o!-symbol-p (flatten args))) 114 | (gs (mapcar #'o!-symbol-to-g!-symbol os))) 115 | (multiple-value-bind (body declarations docstring) 116 | (parse-body body :documentation t) 117 | `(defmacro/g! ,name ,args 118 | ,@(when docstring 119 | (list docstring)) 120 | ,@declarations 121 | `(let ,(mapcar #'list (list ,@gs) (list ,@os)) 122 | ,(progn ,@body)))))) 123 | 124 | (defmacro defun! (name args &body body) 125 | (let ((syms (remove-duplicates 126 | (remove-if-not #'g!-symbol-p 127 | (flatten body))))) 128 | (multiple-value-bind (body declarations docstring) 129 | (parse-body body :documentation t) 130 | `(defun ,name ,args 131 | ,@(when docstring 132 | (list docstring)) 133 | ,@declarations 134 | (let ,(mapcar (lambda (s) 135 | `(,s (gensym ,(subseq (symbol-name s) 136 | 2)))) 137 | syms) 138 | ,@body))))) 139 | 140 | ;; Nestable suggestion from Daniel Herring 141 | (eval-when (:compile-toplevel :load-toplevel :execute) 142 | (defun |#"-reader| (stream sub-char numarg) 143 | (declare (ignore sub-char numarg)) 144 | (let (chars (state 'normal) (depth 1)) 145 | (loop do 146 | (let ((curr (read-char stream))) 147 | (cond ((eq state 'normal) 148 | (cond ((char= curr #\#) 149 | (push #\# chars) 150 | (setq state 'read-sharp)) 151 | ((char= curr #\") 152 | (setq state 'read-quote)) 153 | (t 154 | (push curr chars)))) 155 | ((eq state 'read-sharp) 156 | (cond ((char= curr #\") 157 | (push #\" chars) 158 | (incf depth) 159 | (setq state 'normal)) 160 | (t 161 | (push curr chars) 162 | (setq state 'normal)))) 163 | ((eq state 'read-quote) 164 | (cond ((char= curr #\#) 165 | (decf depth) 166 | (if (zerop depth) (return)) 167 | (push #\" chars) 168 | (push #\# chars) 169 | (setq state 'normal)) 170 | (t 171 | (push #\" chars) 172 | (if (char= curr #\") 173 | (setq state 'read-quote) 174 | (progn 175 | (push curr chars) 176 | (setq state 'normal))))))))) 177 | (coerce (nreverse chars) 'string)))) 178 | 179 | ; (set-dispatch-macro-character #\# #\" #'|#"-reader|) 180 | 181 | ; This version is from Martin Dirichs 182 | (eval-when (:compile-toplevel :load-toplevel :execute) 183 | (defun |#>-reader| (stream sub-char numarg) 184 | (declare (ignore sub-char numarg)) 185 | (let (chars) 186 | (do ((curr (read-char stream) 187 | (read-char stream))) 188 | ((char= #\newline curr)) 189 | (push curr chars)) 190 | (let ((pattern (nreverse chars)) 191 | output) 192 | (labels ((match (pos chars) 193 | (if (null chars) 194 | pos 195 | (if (char= (nth pos pattern) (car chars)) 196 | (match (1+ pos) (cdr chars)) 197 | (match 0 (cdr (append (subseq pattern 0 pos) chars))))))) 198 | (do (curr 199 | (pos 0)) 200 | ((= pos (length pattern))) 201 | (setf curr (read-char stream) 202 | pos (match pos (list curr))) 203 | (push curr output)) 204 | (coerce 205 | (nreverse 206 | (nthcdr (length pattern) output)) 207 | 'string)))))) 208 | 209 | ; (set-dispatch-macro-character #\# #\> #'|#>-reader|) 210 | 211 | (defun segment-reader (stream ch n) 212 | (if (> n 0) 213 | (let ((chars)) 214 | (do ((curr (read-char stream) 215 | (read-char stream))) 216 | ((char= ch curr)) 217 | (push curr chars)) 218 | (cons (coerce (nreverse chars) 'string) 219 | (segment-reader stream ch (- n 1)))))) 220 | 221 | #+cl-ppcre 222 | (defmacro! match-mode-ppcre-lambda-form (o!args o!mods) 223 | ``(lambda (,',g!str) 224 | (ppcre:scan-to-strings 225 | ,(if (zerop (length ,g!mods)) 226 | (car ,g!args) 227 | (format nil "(?~a)~a" ,g!mods (car ,g!args))) 228 | ,',g!str))) 229 | 230 | #+cl-ppcre 231 | (defmacro! subst-mode-ppcre-lambda-form (o!args) 232 | ``(lambda (,',g!str) 233 | (cl-ppcre:regex-replace-all 234 | ,(car ,g!args) 235 | ,',g!str 236 | ,(cadr ,g!args)))) 237 | 238 | #+cl-ppcre 239 | (eval-when (:compile-toplevel :load-toplevel :execute) 240 | (defun |#~-reader| (stream sub-char numarg) 241 | (declare (ignore sub-char numarg)) 242 | (let ((mode-char (read-char stream))) 243 | (cond 244 | ((char= mode-char #\m) 245 | (match-mode-ppcre-lambda-form 246 | (segment-reader stream 247 | (read-char stream) 248 | 1) 249 | (coerce (loop for c = (read-char stream) 250 | while (alpha-char-p c) 251 | collect c 252 | finally (unread-char c stream)) 253 | 'string))) 254 | ((char= mode-char #\s) 255 | (subst-mode-ppcre-lambda-form 256 | (segment-reader stream 257 | (read-char stream) 258 | 2))) 259 | (t (error "Unknown #~~ mode character")))))) 260 | 261 | ; #+cl-ppcre (set-dispatch-macro-character #\# #\~ #'|#~-reader|) 262 | 263 | (defmacro! dlambda (&rest ds) 264 | `(lambda (&rest ,g!args) 265 | (case (car ,g!args) 266 | ,@(mapcar 267 | (lambda (d) 268 | `(,(if (eq t (car d)) 269 | t 270 | (list (car d))) 271 | (apply (lambda ,@(cdr d)) 272 | ,(if (eq t (car d)) 273 | g!args 274 | `(cdr ,g!args))))) 275 | ds)))) 276 | 277 | ;; Graham's alambda 278 | (defmacro alambda (parms &body body) 279 | `(labels ((self ,parms ,@body)) 280 | #'self)) 281 | 282 | ;; Graham's aif 283 | (defmacro aif (test then &optional else) 284 | `(let ((it ,test)) 285 | (if it ,then ,else))) 286 | 287 | (eval-when (:compile-toplevel :execute :load-toplevel) 288 | 289 | (defun |#`-reader| (stream sub-char numarg) 290 | (declare (ignore sub-char)) 291 | (unless numarg (setq numarg 1)) 292 | `(lambda ,(loop for i from 1 to numarg 293 | collect (symb 'a i)) 294 | ,(funcall 295 | (get-macro-character #\`) stream nil))) 296 | 297 | (defun |#f-reader| (stream sub-char numarg) 298 | (declare (ignore stream sub-char)) 299 | (setq numarg (or numarg 3)) 300 | (unless (<= numarg 3) 301 | (error "Bad value for #f: ~a" numarg)) 302 | `(declare (optimize (speed ,numarg) 303 | (safety ,(- 3 numarg))))) 304 | 305 | (named-readtables:defreadtable :lol-syntax 306 | (:fuse :standard :fare-quasiquote) 307 | (:dispatch-macro-char #\# #\" #'|#"-reader|) 308 | (:dispatch-macro-char #\# #\> #'|#>-reader|) 309 | #+cl-ppcre 310 | (:dispatch-macro-char #\# #\~ #'|#~-reader|) 311 | (:dispatch-macro-char #\# #\` #'|#`-reader|) 312 | (:dispatch-macro-char #\# #\f #'|#f-reader|))) 313 | 314 | (named-readtables:in-readtable :lol-syntax) 315 | 316 | (defmacro! nlet-tail (n letargs &body body) 317 | (let ((gs (loop for i in letargs 318 | collect (gensym)))) 319 | `(macrolet 320 | ((,n ,gs 321 | `(progn 322 | (psetq 323 | ,@(apply #'nconc 324 | (mapcar 325 | #'list 326 | ',(mapcar #'car letargs) 327 | (list ,@gs)))) 328 | (go ,',g!n)))) 329 | (block ,g!b 330 | (let ,letargs 331 | (tagbody 332 | ,g!n (return-from 333 | ,g!b (progn ,@body)))))))) 334 | 335 | (defmacro alet% (letargs &rest body) 336 | `(let ((this) ,@letargs) 337 | (setq this ,@(last body)) 338 | ,@(butlast body) 339 | this)) 340 | 341 | (defmacro alet (letargs &rest body) 342 | `(let ((this) ,@letargs) 343 | (setq this ,@(last body)) 344 | ,@(butlast body) 345 | (lambda (&rest params) 346 | (apply this params)))) 347 | 348 | (defun let-binding-transform (bs) 349 | (if bs 350 | (cons 351 | (cond ((symbolp (car bs)) 352 | (list (car bs))) 353 | ((consp (car bs)) 354 | (car bs)) 355 | (t 356 | (error "Bad let bindings"))) 357 | (let-binding-transform (cdr bs))))) 358 | 359 | (defmacro pandoriclet (letargs &rest body) 360 | (let ((letargs (cons 361 | '(this) 362 | (let-binding-transform 363 | letargs)))) 364 | `(let (,@letargs) 365 | (setq this ,@(last body)) 366 | ,@(butlast body) 367 | (dlambda 368 | (:pandoric-get (sym) 369 | ,(pandoriclet-get letargs)) 370 | (:pandoric-set (sym val) 371 | ,(pandoriclet-set letargs)) 372 | (t (&rest args) 373 | (apply this args)))))) 374 | 375 | (defun pandoriclet-get (letargs) 376 | `(case sym 377 | ,@(mapcar #`((,(car a1)) ,(car a1)) 378 | letargs) 379 | (t (error 380 | "Unknown pandoric get: ~a" 381 | sym)))) 382 | 383 | (defun pandoriclet-set (letargs) 384 | `(case sym 385 | ,@(mapcar #`((,(car a1)) 386 | (setq ,(car a1) val)) 387 | letargs) 388 | (t (error 389 | "Unknown pandoric set: ~a" 390 | sym)))) 391 | 392 | (declaim (inline get-pandoric)) 393 | 394 | (defun get-pandoric (box sym) 395 | (funcall box :pandoric-get sym)) 396 | 397 | (defsetf get-pandoric (box sym) (val) 398 | `(progn 399 | (funcall ,box :pandoric-set ,sym ,val) 400 | ,val)) 401 | 402 | (defmacro with-pandoric (syms box &rest body) 403 | (let ((g!box (gensym "box"))) 404 | `(let ((,g!box ,box)) 405 | (declare (ignorable ,g!box)) 406 | (symbol-macrolet 407 | (,@(mapcar #`(,a1 (get-pandoric ,g!box ',a1)) 408 | syms)) 409 | ,@body)))) 410 | 411 | (defun pandoric-hotpatch (box new) 412 | (with-pandoric (this) box 413 | (setq this new))) 414 | 415 | (defmacro pandoric-recode (vars box new) 416 | `(with-pandoric (this ,@vars) ,box 417 | (setq this ,new))) 418 | 419 | (defmacro plambda (largs pargs &rest body) 420 | (let ((pargs (mapcar #'list pargs))) 421 | `(let (this self) 422 | (setq 423 | this (lambda ,largs ,@body) 424 | self (dlambda 425 | (:pandoric-get (sym) 426 | ,(pandoriclet-get pargs)) 427 | (:pandoric-set (sym val) 428 | ,(pandoriclet-set pargs)) 429 | (t (&rest args) 430 | (apply this args))))))) 431 | 432 | (defvar pandoric-eval-tunnel) 433 | 434 | (defmacro pandoric-eval (vars expr) 435 | `(let ((pandoric-eval-tunnel 436 | (plambda () ,vars t))) 437 | (eval `(with-pandoric 438 | ,',vars pandoric-eval-tunnel 439 | ,,expr)))) 440 | 441 | ;; Chapter 7 442 | 443 | 444 | (defmacro fast-progn (&rest body) 445 | `(locally #f ,@body)) 446 | 447 | (defmacro safe-progn (&rest body) 448 | `(locally #0f ,@body)) 449 | 450 | (defun fformat (&rest all) 451 | (apply #'format all)) 452 | 453 | (define-compiler-macro fformat 454 | (&whole form 455 | stream fmt &rest args) 456 | (if (constantp fmt) 457 | (if stream 458 | `(funcall (formatter ,fmt) 459 | ,stream ,@args) 460 | (let ((g!stream (gensym "stream"))) 461 | `(with-output-to-string (,g!stream) 462 | (funcall (formatter ,fmt) 463 | ,g!stream ,@args)))) 464 | form)) 465 | 466 | (declaim (inline make-tlist tlist-left 467 | tlist-right tlist-empty-p)) 468 | 469 | (defun make-tlist () (cons nil nil)) 470 | (defun tlist-left (tl) (caar tl)) 471 | (defun tlist-right (tl) (cadr tl)) 472 | (defun tlist-empty-p (tl) (null (car tl))) 473 | 474 | (declaim (inline tlist-add-left 475 | tlist-add-right)) 476 | 477 | (defun tlist-add-left (tl it) 478 | (let ((x (cons it (car tl)))) 479 | (if (tlist-empty-p tl) 480 | (setf (cdr tl) x)) 481 | (setf (car tl) x))) 482 | 483 | (defun tlist-add-right (tl it) 484 | (let ((x (cons it nil))) 485 | (if (tlist-empty-p tl) 486 | (setf (car tl) x) 487 | (setf (cddr tl) x)) 488 | (setf (cdr tl) x))) 489 | 490 | (declaim (inline tlist-rem-left)) 491 | 492 | (defun tlist-rem-left (tl) 493 | (if (tlist-empty-p tl) 494 | (error "Remove from empty tlist") 495 | (let ((x (car tl))) 496 | (setf (car tl) (cdar tl)) 497 | (if (tlist-empty-p tl) 498 | (setf (cdr tl) nil)) ;; For gc 499 | (car x)))) 500 | 501 | (declaim (inline tlist-update)) 502 | 503 | (defun tlist-update (tl) 504 | (setf (cdr tl) (last (car tl)))) 505 | 506 | (defun build-batcher-sn (n) 507 | (let* (network 508 | (tee (ceiling (log n 2))) 509 | (p (ash 1 (- tee 1)))) 510 | (loop while (> p 0) do 511 | (let ((q (ash 1 (- tee 1))) 512 | (r 0) 513 | (d p)) 514 | (loop while (> d 0) do 515 | (loop for i from 0 to (- n d 1) do 516 | (if (= (logand i p) r) 517 | (push (list i (+ i d)) 518 | network))) 519 | (setf d (- q p) 520 | q (ash q -1) 521 | r p))) 522 | (setf p (ash p -1))) 523 | (nreverse network))) 524 | 525 | (defmacro! sortf (comparator &rest places) 526 | (if places 527 | `(tagbody 528 | ,@(mapcar 529 | #`(let ((,g!a #1=,(nth (car a1) places)) 530 | (,g!b #2=,(nth (cadr a1) places))) 531 | (if (,comparator ,g!b ,g!a) 532 | (setf #1# ,g!b 533 | #2# ,g!a))) 534 | (build-batcher-sn (length places)))))) 535 | 536 | ;;;;;; NEW CODE FOR ANTIWEB 537 | #+cl-ppcre 538 | (defun dollar-symbol-p (s) 539 | (and (symbolp s) 540 | (> (length (symbol-name s)) 1) 541 | (string= (symbol-name s) 542 | "$" 543 | :start1 0 544 | :end1 1) 545 | (ignore-errors (parse-integer (subseq (symbol-name s) 1))))) 546 | 547 | (defmacro! if-match ((match-regex str) then &optional else) 548 | (let* ((dollars (remove-duplicates 549 | (remove-if-not #'dollar-symbol-p 550 | (flatten then)))) 551 | (top (or (car (sort (mapcar #'dollar-symbol-p dollars) #'>)) 552 | 0))) 553 | `(multiple-value-bind (,g!matches ,g!captures) (,match-regex ,str) 554 | (declare (ignorable ,g!matches ,g!captures)) 555 | (let ((,g!captures-len (length ,g!captures))) 556 | (declare (ignorable ,g!captures-len)) 557 | (symbol-macrolet ,(mapcar #`(,(symb "$" a1) 558 | (if (< ,g!captures-len ,a1) 559 | (error "Too few matchs: ~a unbound." ,(mkstr "$" a1)) 560 | (aref ,g!captures ,(1- a1)))) 561 | (loop for i from 1 to top collect i)) 562 | (if ,g!matches 563 | ,then 564 | ,else)))))) 565 | 566 | 567 | (defmacro when-match ((match-regex str) &body forms) 568 | `(if-match (,match-regex ,str) 569 | (progn ,@forms))) 570 | 571 | ;; EOF 572 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LET-OVER-LAMBDA; Base: 10 -*- file: package.lisp 2 | 3 | (defpackage let-over-lambda 4 | (:nicknames lol) 5 | (:use cl cl-user cl-ppcre) 6 | (:import-from #:alexandria 7 | #:parse-body) 8 | (:import-from #:named-readtables 9 | #:defreadtable 10 | #:in-readtable) 11 | (:export #:lol-syntax 12 | #:mkstr 13 | #:symb 14 | #:group 15 | #:flatten 16 | #:fact 17 | #:choose 18 | #:g!-symbol-p 19 | #:defmacro/g! 20 | #:o!-symbol-p 21 | #:o!-symbol-to-g!-symbol 22 | #:defmacro! 23 | #:defun! 24 | #:|#"-reader| 25 | #:segment-reader 26 | #:match-mode-ppcre-lambda-form 27 | #:subst-mode-ppcre-lambda-form 28 | #:|#~-reader| 29 | #:dlambda 30 | #:alambda 31 | #:aif 32 | #:|#`-reader| 33 | #:|#f-reader| 34 | #:nlet-tail 35 | #:alet% 36 | #:alet 37 | #:it 38 | #:this 39 | #:self 40 | #:let-binding-transform 41 | #:pandoriclet 42 | #:pandoriclet-get 43 | #:pandoriclet-set 44 | #:get-pandoric 45 | #:with-pandoric 46 | #:pandoric-hotpatch 47 | #:pandoric-recode 48 | #:plambda 49 | #:pandoric-eval 50 | #:fast-progn 51 | #:safe-progn 52 | #:fformat 53 | #:make-tlist 54 | #:tlist-left 55 | #:tlist-right 56 | #:tlist-empty-p 57 | #:tlist-add-left 58 | #:tlist-add-right 59 | #:tlist-rem-left 60 | #:tlist-update 61 | #:build-batcher-sn 62 | #:sortf 63 | #:dollar-symbol-p 64 | #:prune-if-match-bodies-from-sub-lexical-scope 65 | #:if-match 66 | #:when-match)) 67 | 68 | ;; EOF 69 | -------------------------------------------------------------------------------- /t/let-over-lambda.lisp: -------------------------------------------------------------------------------- 1 | (in-package cl-user) 2 | 3 | (defpackage let-over-lambda-test 4 | (:use cl let-over-lambda prove) 5 | (:import-from named-readtables 6 | in-readtable)) 7 | 8 | (in-package let-over-lambda-test) 9 | 10 | (in-readtable lol-syntax) 11 | 12 | ;; NOTE: To run this test file, execute `(asdf:test-system :let-over-lambda)' in your Lisp. 13 | 14 | (plan 8) 15 | 16 | (defun! fn! () 17 | `(let ((,g!test 123)) 18 | ,g!test)) 19 | 20 | (defmacro fn-macro () 21 | (fn!)) 22 | 23 | (deftest defun!-test 24 | (is-expand (fn-macro) 25 | (LET (($TEST 123)) 26 | $TEST))) 27 | 28 | (defparameter flatten-list `(D (E (F ,'(G))))) 29 | 30 | (deftest flatten-test 31 | (is (flatten '((A . B) (C D (E) (F (G))))) 32 | '(A B C D E F G) 33 | "FLATTEN function works as expected.") 34 | (is (flatten `(A B C ,flatten-list)) 35 | '(A B C D E F G) 36 | "FLATTEN on quasiquotes works as expected.")) 37 | 38 | (defparameter heredoc-string #>END 39 | I can put anything here: ", , "# and ># are 40 | no problem. The only thing that will terminate 41 | the reading of this string is...END) 42 | 43 | (deftest heredoc-read-macro-test 44 | (is heredoc-string 45 | "I can put anything here: \", , \"# and ># are 46 | no problem. The only thing that will terminate 47 | the reading of this string is..." 48 | "SHARP-GREATER-THEN read macro works as expected.")) 49 | 50 | (deftest pilfered-perl-regex-syntax-test 51 | (is-expand '#~m|\w+tp://| 52 | '(lambda ($str) (cl-ppcre:scan-to-strings "\\w+tp://" $str)) 53 | "#~m expands correctly.") 54 | (is-expand '#~s/abc/def/ 55 | '(lambda ($str) (cl-ppcre:regex-replace-all "abc" $str "def")) 56 | "#~s expands correctly.") 57 | (is-values (#~m/abc/ "123abc") 58 | '("abc" #()) 59 | "#~m runs correctly." 60 | :test #'equalp) 61 | (is (#~s/abc/def/ "Testing abc testing abc") 62 | "Testing def testing def" 63 | "#~s runs correctly.")) 64 | 65 | (deftest read-anaphor-sharp-backquote-test 66 | (is '#`((,a1)) 67 | '(lambda (a1) `((,a1))) 68 | "SHARP-BACKQUOTE expands correctly." 69 | :test #'equalp) 70 | (is-expand #.(#3`(((,@a2)) ,a3 (,a1 ,a1)) 71 | (gensym) 72 | '(a b c) 73 | 'hello) 74 | (((a b c)) hello ($g $g)) 75 | "SHARP-BACKQUOTE runs correctly, respecting order, gensyms, nesting, numarg, etc.")) 76 | 77 | (deftest sharp-f-test 78 | (is '#f 79 | '(declare (optimize (speed 3) (safety 0))) 80 | "Default numarg SHARP-F expands correctly.") 81 | (is '#0f 82 | '(declare (optimize (speed 0) (safety 3))) 83 | "Numarg = 3 SHARP-F expands correctly.") 84 | (is '(#1f #2f) 85 | '((declare (optimize (speed 1) (safety 2))) 86 | (declare (optimize (speed 2) (safety 1)))) 87 | "SHARP-F correctly expands into rarely used compiler options.")) 88 | 89 | (deftest |test-#""#-read-macro| 90 | (is #"Contains " and \."# 91 | "Contains \" and \\." 92 | "SHARP-QUOTE read macro works as expected.")) 93 | 94 | (deftest if-match-test 95 | (is (if-match (#~m_a(b)c_ "abc") 96 | $1) 97 | "b" 98 | "IF-MATCH correctly returns the single capture.") 99 | (is-error (if-match (#~m_a(b)c_ "abc") 100 | $2) 101 | 'simple-error 102 | "IF-MATCH throws an error when $2 is unbound.") 103 | (is (if-match (#~m_a(b)c_ "def") 104 | $1 105 | :else) 106 | :else 107 | "When IF-MATCH test is false it goes to the else body.") 108 | (is (if-match (#~m_a(b)c_ "abc") 109 | (if-match (#~m_(d)(e)f_ "def") 110 | (list $1 $2) 111 | :no-second-match) 112 | $1) 113 | '("d" "e") 114 | "IF-MATCH works with nested IF-MATCHs.") 115 | (is (if-match (#~m_a(b)c_ "abc") 116 | (if-match (#~m_(d)(e)f_ "d ef") 117 | (list $1 $2) 118 | :no-second-match) 119 | $1) 120 | :no-second-match 121 | "IF-MATCH works with nested IF-MATCHs.") 122 | (is-error (if-match (#~m_a(b)c_ "ab c") 123 | (if-match (#~m_(d)(e)f_ "d ef") 124 | (list $1 $2) 125 | :no-second-match) 126 | $1) 127 | 'simple-error 128 | "IF-MATCH throws an error, even when nested.") 129 | (is-error (if-match (#~m_a(b)c_ "ab c") 130 | (if-match (#~m_(d)(e)f_ "d ef") 131 | (list $1 $2) 132 | :no-second-match) 133 | $2) 134 | 'simple-error 135 | "IF-MATCH throws an error, even when nested.")) 136 | 137 | (run-test-all) 138 | --------------------------------------------------------------------------------