Find file Copy path
f321d95 Aug 2, 2015
2 contributors

Users who have contributed to this file

@thephoeron @EuAndreh
569 lines (497 sloc) 17 KB
;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LET-OVER-LAMBDA; Base: 10 -*- file: let-over-lambda.lisp
(in-package #:let-over-lambda)
;; Antiweb (C) Doug Hoyte
;; This is a "production" version of LOL with bug-fixes
;; and new features in the spirit of the book.
;; See
;; This is the source code for the book
;; _Let_Over_Lambda_ by Doug Hoyte.
;; This code is (C) 2002-2008, Doug Hoyte.
;; You are free to use, modify, and re-distribute
;; this code however you want, except that any
;; modifications must be clearly indicated before
;; re-distribution. There is no warranty,
;; expressed nor implied.
;; Attribution of this code to me, Doug Hoyte, is
;; appreciated but not necessary. If you find the
;; code useful, or would like documentation,
;; please consider buying the book!
;; Modifications by "the Phoeron" Colin J.E. Lupton, 2012--2014
;; - Support for ASDF/Quicklisp
;; - Cheap hacks to support new Backquote implementation in SBCL v1.2.2
;; Safety feature for SBCL>=v1.2.2
(eval-when (:compile-toplevel :execute)
(sb-ext:assert-version->= 1 2 2)
(setq *features* (remove 'old-sbcl *features*)))
(error ()
(pushnew 'old-sbcl *features*))))
(defun group (source n)
(if (zerop n) (error "zero length"))
(labels ((rec (source acc)
(let ((rest (nthcdr n source)))
(if (consp rest)
(rec rest (cons
(subseq source 0 n)
(cons source acc))))))
(if source (rec source nil) nil)))
(eval-when (:compile-toplevel :execute :load-toplevel)
(defun mkstr (&rest args)
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun symb (&rest args)
(values (intern (apply #'mkstr args))))
(defun flatten (x)
(labels ((rec (x acc)
(cond ((null x) acc)
#+(and sbcl (not lol::old-sbcl))
((typep x 'sb-impl::comma) (rec (sb-impl::comma-expr x) acc))
((atom x) (cons x acc))
(t (rec
(car x)
(rec (cdr x) acc))))))
(rec x nil)))
(defun g!-symbol-p (s)
(and (symbolp s)
(> (length (symbol-name s)) 2)
(string= (symbol-name s)
:start1 0
:end1 2)))
(defun o!-symbol-p (s)
(and (symbolp s)
(> (length (symbol-name s)) 2)
(string= (symbol-name s)
:start1 0
:end1 2)))
(defun o!-symbol-to-g!-symbol (s)
(symb "G!"
(subseq (symbol-name s) 2))))
(defmacro defmacro/g! (name args &rest body)
(let ((syms (remove-duplicates
(remove-if-not #'g!-symbol-p
(flatten body)))))
(multiple-value-bind (body declarations docstring)
(parse-body body :documentation t)
`(defmacro ,name ,args
,@(when docstring
(list docstring))
(let ,(mapcar
(lambda (s)
`(,s (gensym ,(subseq
(symbol-name s)
(defmacro defmacro! (name args &rest body)
(let* ((os (remove-if-not #'o!-symbol-p (flatten args)))
(gs (mapcar #'o!-symbol-to-g!-symbol os)))
(multiple-value-bind (body declarations docstring)
(parse-body body :documentation t)
`(defmacro/g! ,name ,args
,@(when docstring
(list docstring))
`(let ,(mapcar #'list (list ,@gs) (list ,@os))
,(progn ,@body))))))
(defmacro defun! (name args &body body)
(let ((syms (remove-duplicates
(remove-if-not #'g!-symbol-p
(flatten body)))))
(multiple-value-bind (body declarations docstring)
(parse-body body :documentation t)
`(defun ,name ,args
,@(when docstring
(list docstring))
(let ,(mapcar (lambda (s)
`(,s (gensym ,(subseq (symbol-name s)
;; Nestable suggestion from Daniel Herring
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun |#"-reader| (stream sub-char numarg)
(declare (ignore sub-char numarg))
(let (chars (state 'normal) (depth 1))
(loop do
(let ((curr (read-char stream)))
(cond ((eq state 'normal)
(cond ((char= curr #\#)
(push #\# chars)
(setq state 'read-sharp))
((char= curr #\")
(setq state 'read-quote))
(push curr chars))))
((eq state 'read-sharp)
(cond ((char= curr #\")
(push #\" chars)
(incf depth)
(setq state 'normal))
(push curr chars)
(setq state 'normal))))
((eq state 'read-quote)
(cond ((char= curr #\#)
(decf depth)
(if (zerop depth) (return))
(push #\" chars)
(push #\# chars)
(setq state 'normal))
(push #\" chars)
(if (char= curr #\")
(setq state 'read-quote)
(push curr chars)
(setq state 'normal)))))))))
(coerce (nreverse chars) 'string))))
; (set-dispatch-macro-character #\# #\" #'|#"-reader|)
; This version is from Martin Dirichs
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun |#>-reader| (stream sub-char numarg)
(declare (ignore sub-char numarg))
(let (chars)
(do ((curr (read-char stream)
(read-char stream)))
((char= #\newline curr))
(push curr chars))
(let ((pattern (nreverse chars))
(labels ((match (pos chars)
(if (null chars)
(if (char= (nth pos pattern) (car chars))
(match (1+ pos) (cdr chars))
(match 0 (cdr (append (subseq pattern 0 pos) chars)))))))
(do (curr
(pos 0))
((= pos (length pattern)))
(setf curr (read-char stream)
pos (match pos (list curr)))
(push curr output))
(nthcdr (length pattern) output))
; (set-dispatch-macro-character #\# #\> #'|#>-reader|)
(defun segment-reader (stream ch n)
(if (> n 0)
(let ((chars))
(do ((curr (read-char stream)
(read-char stream)))
((char= ch curr))
(push curr chars))
(cons (coerce (nreverse chars) 'string)
(segment-reader stream ch (- n 1))))))
(defmacro! match-mode-ppcre-lambda-form (o!args o!mods)
``(lambda (,',g!str)
,(if (zerop (length ,g!mods))
(car ,g!args)
(format nil "(?~a)~a" ,g!mods (car ,g!args)))
(defmacro! subst-mode-ppcre-lambda-form (o!args)
``(lambda (,',g!str)
,(car ,g!args)
,(cadr ,g!args))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun |#~-reader| (stream sub-char numarg)
(declare (ignore sub-char numarg))
(let ((mode-char (read-char stream)))
((char= mode-char #\m)
(segment-reader stream
(read-char stream)
(coerce (loop for c = (read-char stream)
while (alpha-char-p c)
collect c
finally (unread-char c stream))
((char= mode-char #\s)
(segment-reader stream
(read-char stream)
(t (error "Unknown #~~ mode character"))))))
; #+cl-ppcre (set-dispatch-macro-character #\# #\~ #'|#~-reader|)
(defmacro! dlambda (&rest ds)
`(lambda (&rest ,g!args)
(case (car ,g!args)
(lambda (d)
`(,(if (eq t (car d))
(list (car d)))
(apply (lambda ,@(cdr d))
,(if (eq t (car d))
`(cdr ,g!args)))))
;; Graham's alambda
(defmacro alambda (parms &body body)
`(labels ((self ,parms ,@body))
;; Graham's aif
(defmacro aif (test then &optional else)
`(let ((it ,test))
(if it ,then ,else)))
(eval-when (:compile-toplevel :execute :load-toplevel)
(defun |#`-reader| (stream sub-char numarg)
(declare (ignore sub-char))
(unless numarg (setq numarg 1))
`(lambda ,(loop for i from 1 to numarg
collect (symb 'a i))
(get-macro-character #\`) stream nil)))
(defun |#f-reader| (stream sub-char numarg)
(declare (ignore stream sub-char))
(setq numarg (or numarg 3))
(unless (<= numarg 3)
(error "Bad value for #f: ~a" numarg))
`(declare (optimize (speed ,numarg)
(safety ,(- 3 numarg)))))
(defreadtable lol-syntax
(:merge :standard)
(:dispatch-macro-char #\# #\" #'|#"-reader|)
(:dispatch-macro-char #\# #\> #'|#>-reader|)
(:dispatch-macro-char #\# #\~ #'|#~-reader|)
(:dispatch-macro-char #\# #\` #'|#`-reader|)
(:dispatch-macro-char #\# #\f #'|#f-reader|)))
(in-readtable lol-syntax)
(defmacro! nlet-tail (n letargs &body body)
(let ((gs (loop for i in letargs
collect (gensym))))
((,n ,gs
,@(apply #'nconc
',(mapcar #'car letargs)
(list ,@gs))))
(go ,',g!n))))
(block ,g!b
(let ,letargs
,g!n (return-from
,g!b (progn ,@body))))))))
(defmacro alet% (letargs &rest body)
`(let ((this) ,@letargs)
(setq this ,@(last body))
,@(butlast body)
(defmacro alet (letargs &rest body)
`(let ((this) ,@letargs)
(setq this ,@(last body))
,@(butlast body)
(lambda (&rest params)
(apply this params))))
(defun let-binding-transform (bs)
(if bs
(cond ((symbolp (car bs))
(list (car bs)))
((consp (car bs))
(car bs))
(error "Bad let bindings")))
(let-binding-transform (cdr bs)))))
(defmacro pandoriclet (letargs &rest body)
(let ((letargs (cons
`(let (,@letargs)
(setq this ,@(last body))
,@(butlast body)
(:pandoric-get (sym)
,(pandoriclet-get letargs))
(:pandoric-set (sym val)
,(pandoriclet-set letargs))
(t (&rest args)
(apply this args))))))
(defun pandoriclet-get (letargs)
`(case sym
,@(mapcar #`((,(car a1)) ,(car a1))
(t (error
"Unknown pandoric get: ~a"
(defun pandoriclet-set (letargs)
`(case sym
,@(mapcar #`((,(car a1))
(setq ,(car a1) val))
(t (error
"Unknown pandoric set: ~a"
(declaim (inline get-pandoric))
(defun get-pandoric (box sym)
(funcall box :pandoric-get sym))
(defsetf get-pandoric (box sym) (val)
(funcall ,box :pandoric-set ,sym ,val)
(defmacro with-pandoric (syms box &rest body)
(let ((g!box (gensym "box")))
`(let ((,g!box ,box))
(declare (ignorable ,g!box))
(,@(mapcar #`(,a1 (get-pandoric ,g!box ',a1))
(defun pandoric-hotpatch (box new)
(with-pandoric (this) box
(setq this new)))
(defmacro pandoric-recode (vars box new)
`(with-pandoric (this ,@vars) ,box
(setq this ,new)))
(defmacro plambda (largs pargs &rest body)
(let ((pargs (mapcar #'list pargs)))
`(let (this self)
this (lambda ,largs ,@body)
self (dlambda
(:pandoric-get (sym)
,(pandoriclet-get pargs))
(:pandoric-set (sym val)
,(pandoriclet-set pargs))
(t (&rest args)
(apply this args)))))))
(defvar pandoric-eval-tunnel)
(defmacro pandoric-eval (vars expr)
`(let ((pandoric-eval-tunnel
(plambda () ,vars t)))
(eval `(with-pandoric
,',vars pandoric-eval-tunnel
;; Chapter 7
(defmacro fast-progn (&rest body)
`(locally #f ,@body))
(defmacro safe-progn (&rest body)
`(locally #0f ,@body))
(defun fformat (&rest all)
(apply #'format all))
(define-compiler-macro fformat
(&whole form
stream fmt &rest args)
(if (constantp fmt)
(if stream
`(funcall (formatter ,fmt)
,stream ,@args)
(let ((g!stream (gensym "stream")))
`(with-output-to-string (,g!stream)
(funcall (formatter ,fmt)
,g!stream ,@args))))
(declaim (inline make-tlist tlist-left
tlist-right tlist-empty-p))
(defun make-tlist () (cons nil nil))
(defun tlist-left (tl) (caar tl))
(defun tlist-right (tl) (cadr tl))
(defun tlist-empty-p (tl) (null (car tl)))
(declaim (inline tlist-add-left
(defun tlist-add-left (tl it)
(let ((x (cons it (car tl))))
(if (tlist-empty-p tl)
(setf (cdr tl) x))
(setf (car tl) x)))
(defun tlist-add-right (tl it)
(let ((x (cons it nil)))
(if (tlist-empty-p tl)
(setf (car tl) x)
(setf (cddr tl) x))
(setf (cdr tl) x)))
(declaim (inline tlist-rem-left))
(defun tlist-rem-left (tl)
(if (tlist-empty-p tl)
(error "Remove from empty tlist")
(let ((x (car tl)))
(setf (car tl) (cdar tl))
(if (tlist-empty-p tl)
(setf (cdr tl) nil)) ;; For gc
(car x))))
(declaim (inline tlist-update))
(defun tlist-update (tl)
(setf (cdr tl) (last (car tl))))
(defun build-batcher-sn (n)
(let* (network
(tee (ceiling (log n 2)))
(p (ash 1 (- tee 1))))
(loop while (> p 0) do
(let ((q (ash 1 (- tee 1)))
(r 0)
(d p))
(loop while (> d 0) do
(loop for i from 0 to (- n d 1) do
(if (= (logand i p) r)
(push (list i (+ i d))
(setf d (- q p)
q (ash q -1)
r p)))
(setf p (ash p -1)))
(nreverse network)))
(defmacro! sortf (comparator &rest places)
(if places
#`(let ((,g!a #1=,(nth (car a1) places))
(,g!b #2=,(nth (cadr a1) places)))
(if (,comparator ,g!b ,g!a)
(setf #1# ,g!b
#2# ,g!a)))
(build-batcher-sn (length places))))))
(defun dollar-symbol-p (s)
(and (symbolp s)
(> (length (symbol-name s)) 1)
(string= (symbol-name s)
:start1 0
:end1 1)
(ignore-errors (parse-integer (subseq (symbol-name s) 1)))))
(defmacro! if-match ((match-regex str) then &optional else)
(let* ((dollars (remove-duplicates
(remove-if-not #'dollar-symbol-p
(flatten then))))
(top (or (car (sort (mapcar #'dollar-symbol-p dollars) #'>))
`(multiple-value-bind (,g!matches ,g!captures) (,match-regex ,str)
(declare (ignorable ,g!matches ,g!captures))
(let ((,g!captures-len (length ,g!captures)))
(declare (ignorable ,g!captures-len))
(symbol-macrolet ,(mapcar #`(,(symb "$" a1)
(if (< ,g!captures-len ,a1)
(error "Too few matchs: ~a unbound." ,(mkstr "$" a1))
(aref ,g!captures ,(1- a1))))
(loop for i from 1 to top collect i))
(if ,g!matches
(defmacro when-match ((match-regex str) &body forms)
`(if-match (,match-regex ,str)
(progn ,@forms)))
;; EOF