TFC/tfcconnection
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

add portable quicklisp

Browse source
This commit is contained in:
Chris Cochrun 2023-06-14 05:45:10 -05:00
parent 3620ead09b
commit 207f1d0234
4737 changed files with 526283 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

2
quicklisp/dists/quicklisp/software/3bz-20201220-git/.gitignore vendored Normal file
View file

@ -0,0 +1,2 @@
*~
*.fasl

29
quicklisp/dists/quicklisp/software/3bz-20201220-git/3bz.asd Normal file
View file

@ -0,0 +1,29 @@
(defsystem :3bz
:description "deflate decompressor"
:depends-on (alexandria
(:feature (:and (:not :mezzano) (:not :abcl)) cffi)
(:feature (:and (:not :mezzano) (:not :abcl)) mmap)
trivial-features
nibbles
babel)
:serial t
:license "MIT"
:author "Bart Botta <00003b at gmail.com>"
:components
((:file "package")
(:file "tuning")
(:file "util")
(:file "constants")
(:file "types")
(:file "huffman-tree")
(:file "ht-constants")
(:file "io-common")
(:file "io-nommap" :if-feature (:or :mezzano :abcl))
(:file "io-mmap" :if-feature (:and (:not :mezzano) (:not :abcl)))
(:file "io")
(:file "deflate")
(:file "checksums")
(:file "zlib")
(:file "gzip")
(:file "api")))

94
quicklisp/dists/quicklisp/software/3bz-20201220-git/README.md Normal file
View file

@ -0,0 +1,94 @@
Yet another CL impementation of [rfc1951
deflate](https://tools.ietf.org/html/rfc1951) decompression
(optionally with [rfc1950 zlib](https://tools.ietf.org/html/rfc1950)
or [rfc1952
gzip](https://tools.ietf.org/html/rfc1952https://tools.ietf.org/html/rfc1952)
wrappers), with support for reading from foreign pointers (for use with
mmap and similar, etc), and from CL octet vectors and streams.
### Still somewhat WIP, but approaching usability.
Performance for vectors/pointers is somewhere between FFI to libz and chipz,
still needs some low-level optimization of copy routines and checksums.
Stream API is very slow, and may be replaced at some point.
API isn't completely stable yet, needs some actual use to figure out
the details.
#### API/usage
##### easy API:
`decompress-vector (compressed &key (format :zlib) output`
```lisp
;; pass a (simple-array (unsigned-byte 8) (*))
(3bz:decompress-vector (alexandria:read-file-into-byte-vector "foo.gz")
:format :gzip) ;; accepts :deflate, :zlib, :gzip
;; ->
#(....)
1234
;; get back decompressed data and size as 2 values
```
If decompressed size is known, you can save some copies by passing in
a pre-allocated `(simple-array (unsigned-byte 8) (*))` vector with
`:OUTPUT`.
##### full API:
Allows input and output in multiple pieces, as well as input from
vectors, FFI pointers, or streams (streams are currently very slow
though).
* step 1: make a decompression state:
`make-deflate-state`, `make-zlib-state`, or `make-gzip-state`.
Optionally with `:output-buffer octet-vector` to provide initial
output buffer.
* step 2: make an input context
`make-octet-vector-context`, `make-octet-stream-context`, or `with-octet-pointer`+`make-octet-pointer-context`.
pass source of coresponding type, + optional `:start`,`:end`,`:offset`
to specify valid region within source. For FFI pointers, use
`(with-octet-pointer (octet-pointer ffi-pointer size) ...)` to wrap a
raw pointer + size into `octet-pointer` to pass to
`make-octet-pointer-context`. (If you need indefinite scope pointers,
file an issue so support that can be added to API.)
* step 3: decompress
`(decompress context state)` returns current offset into output buffer.
* step 4: check decompression state
* if `(finished state)`, you are done.
* if `(input-underrun state)`, you need to supply more input by creating a new input context, and call `decompress` again with new context.
* if `(output-overflow state)`, you need to provide a new output buffer with `(replace-output-buffer state new-buffer)` and call `decompress` again.
##### performance notes:
* Streams API is currently *very* slow, and will probably be rewritten at some point.
* Output in small pieces is slow:
`deflate` needs to maintain a 32kb history window, so every time
output buffer overflows, it copies 32kb of history. If output buffer
is smaller than 32kb, that means more history is copied than total
output, so avoid small output buffers.
Ideally, if output size is known in advance and output buffer never
overflows, there is no extra copies for history window.
If output size isn't known, if you start with something like `(min
input-size 32768)` and double (or at least scale by 1.x) on each
overflow, there will only be O(N) bytes copied to combine output
buffers, and O(lgN) byytes copied for history.

71
quicklisp/dists/quicklisp/software/3bz-20201220-git/api.lisp Normal file
View file

@ -0,0 +1,71 @@
(in-package 3bz)
(defun decompress (context state)
(etypecase state
(gzip-state
(decompress-gzip context state))
(zlib-state
(decompress-zlib context state))
(deflate-state
(decompress-deflate context state))))
(defun replace-output-buffer (state buffer)
(unless (or (zerop (ds-output-offset state))
(ds-output-overflow state))
;; we don't create/fill window until output buffer overflows, so
;; would need to do that here. error for now until someone needs
;; that ability...
(error "can't switch buffers without filling old one yet."))
(setf (ds-output-buffer state) buffer)
(setf (ds-output-offset state) 0)
(setf (ds-output-overflow state) nil))
(defun decompress-vector (compressed &key (format :zlib) (start 0) (end (length compressed)) output)
"decompress octet-vector COMPRESSED using
FORMAT (:deflate,:zlib,:gzip). If output is supplied, it should be an
octet-vector large enough to hold entire uncompressed output.
Returns buffer containing decompressed data (OUTPUT if supplied) and #
of octets decompressed."
(let ((parts nil)
(state (ecase format
(:gzip (make-gzip-state))
(:zlib (make-zlib-state))
(:deflate (make-deflate-state))))
(rc (make-octet-vector-context compressed :start start :end end)))
(if output
(progn
(setf (ds-output-buffer state) output)
(setf (ds-output-offset state) 0)
(let ((c (decompress rc state)))
(unless (ds-finished state)
(cond
((ds-input-underrun state)
(error "incomplete ~a stream" format))
((ds-output-overflow state)
(error "not enough space to decompress ~a stream" format))
(t (error "?"))))
(values output c)))
(progn
(loop for out = (make-array (min (- end start) 32768)
:element-type 'octet)
then (make-array (* 2 (length out)) :element-type 'octet)
do (replace-output-buffer state out)
(let ((c (decompress rc state)))
(push (cons out c) parts))
(assert (not (ds-input-underrun state)))
until (ds-finished state))
(let* ((s (reduce '+ parts :key 'cdr))
(b (make-array s :element-type 'octet)))
(loop for start = 0 then (+ start c)
for (p . c) in (nreverse parts)
do (replace b p :start1 start :end2 c))
(values b (length b)))))))
(defun finished (state)
(ds-finished state))
(defun input-underrun (state)
(ds-input-underrun state))
(defun output-overflow (state)
(ds-output-overflow state))

122
quicklisp/dists/quicklisp/software/3bz-20201220-git/bench.lisp Normal file
View file

@ -0,0 +1,122 @@
(in-package 3bz)
#++(ql:quickload '(3bz salza2 flexi-streams chipz deoxybyte-gzip))
(defvar *foo* nil)
(defvar *chipz* nil)
(defvar *3bz* nil)
#++
(prog1 nil
(push *foo* *chipz*))
#++
(prog1 nil
(push *foo* *3bz*))
(defvar *zzz* nil)
(let* ((d (time
(alexandria:read-file-into-byte-vector "e:/tmp/t/linux-2.2.26.tar"))
#++(setf *foo*
(time
(map-into (make-array (expt 2 24) :element-type 'octet)
(lambda () (random 225))))))
(tmp (make-array (length d) :element-type 'octet
:initial-element 0))
(v #++(time
(salza2:compress-data d 'salza2:deflate-compressor))
(or *zzz*
(setf *zzz*
(time
(multiple-value-bind (x r w)
(gz:deflate-vector d tmp :compression 9
:suppress-header t)
(declare (ignore r))
(subseq x 0 w))))))
(c (make-instance 'octet-vector-context
:octet-vector v
:boxes (make-context-boxes :end (length v))))
(state (make-deflate-state :output-buffer tmp)))
#++(time (dump-deflate v "-sirqq"))
#++(time (dump-deflate v "-sir"))
(format t "chipz:~%")
(fill tmp 0)
(with-simple-restart (continue "continue")
(let ((x (time (chipz:decompress tmp 'chipz:deflate v))))
(declare (ignore x))
(assert (equalp d tmp))))
(fill tmp 0)
(format t "3bz:~%") ;; 0.36
(let ((x (time (decompress c state))))
(assert (not (ds-output-overflow state)))
(assert (ds-finished state))
(assert (equalp (typecase x
(cons
(time (apply 'concatenate 'octet-vector x)))
(vector x)
(number
(subseq tmp 0 x)))
d)))
(fill tmp 0)
(format t "3bz/pointer:~%") ;; 0.36
(cffi:with-pointer-to-vector-data (p v)
(with-octet-pointer (op p (length v))
(let ((x (time (decompress (make-instance 'octet-pointer-context
:pointer p :op op
:boxes (make-context-boxes :end (length v)))
(make-deflate-state :output-buffer tmp)))))
(assert (equalp (if (consp x)
(time (apply 'concatenate 'octet-vector x))
(subseq tmp 0 x))
d)))))
(fill tmp 0)
(format t "3bz/stream:~%")
(flex:with-input-from-sequence (s v)
(let ((x (time (decompress (make-instance 'octet-stream-context
:octet-stream s
:boxes (make-context-boxes :end (length v)))
(make-deflate-state :output-buffer tmp)))))
(assert (equalp (if (consp x)
(time (apply 'concatenate 'octet-vector x))
(subseq tmp 0 x))
d))))
(fill tmp 0)
(format t "gz:~%")
(let ((x (time (gz:inflate-vector v tmp :suppress-header t))))
(assert (equalp x d)))
(print (length v))
nil)
(let* ((d (time
(alexandria:read-file-into-byte-vector "e:/tmp/t/linux-2.2.26.tar")))
(tmp (make-array (length d) :element-type 'octet
:initial-element 0))
(v (or *zzz*
(setf *zzz*
(time
(multiple-value-bind (x r w)
(gz:deflate-vector d tmp :compression 9
:suppress-header t)
(declare (ignore r))
(subseq x 0 w)))))))
(fill tmp 0)
(format t "3bz:~%") ;; 0.33
(let ((x (time (decompress (make-instance 'octet-vector-context
:octet-vector v
:boxes (make-context-boxes
:end (length v)))
(make-deflate-state :output-buffer tmp)))))
(assert (equalp (if (consp x)
(time (apply 'concatenate 'octet-vector x))
(subseq tmp 0 x))
d)))
(format t " x10:~%")
(time
(loop repeat 10
do (decompress (make-instance 'octet-vector-context
:octet-vector v
:boxes (make-context-boxes
:end (length v)))
(make-deflate-state :output-buffer tmp))))
nil)

209
quicklisp/dists/quicklisp/software/3bz-20201220-git/checksums.lisp Normal file
View file

@ -0,0 +1,209 @@
(in-package 3bz)
#++
(let ((max (1- (expt 2 29))))
(flet ((s (n)
(+ (* (1+ n) 65520)
(* (/ (* n (1+ n)) 2) 255))))
(loop with n1 = 0
with n = (/ max 2)
with n2 = max
when (>= (s n) max)
do (psetf n (floor (+ n n1) 2)
n2 n)
else do (psetf n (floor (+ n n2) 2)
n1 n)
until (< (- n2 n1) 2)
finally (return n1))))
(defun adler32/ub64 (buf end s1 s2)
(declare (type octet-vector buf)
(type (unsigned-byte 16) s1 s2)
(type fixnum end)
(optimize speed))
;; with 64bit accumulators, we need to do the MOD every 380368439
;; adds. formula = (+ (* (1+ n) 65520) (* (/ (* n (1+ n)) 2) 255))
(let* ((unroll #1=#.+adler32-unroll+)
(chunk-size ;(* unroll (floor 5552 unroll))
(* unroll (floor 380368439 unroll)))
(s1 s1)
(s2 s2))
(declare (type (unsigned-byte 64) s1 s2)
(fixnum chunk-size))
(assert (<= end (length buf)))
(macrolet ((a (i)
`(progn
(setf s1 (ub64+ s1
(locally
(declare (optimize (safety 0)))
(aref buf (the fixnum ,i)))))
(setf s2 (ub64+ s2 s1))))
(unroll (n)
`(progn
,@(loop for x below n
collect `(a (fixnum+ i ,x))))))
(loop with i of-type fixnum = 0
for rem fixnum = (the fixnum (- end i))
for c fixnum = (fixnum+ i (min (* #1# (floor rem #1#))
chunk-size))
while (> rem #1#)
do (loop while (< i c)
do (unroll #1#)
(locally (declare (optimize (safety 0)))
(setf i (fixnum+ i #1#))))
(setf s1 (mod s1 +adler32-prime+)
s2 (mod s2 +adler32-prime+))
finally (progn
(assert (<= i end))
(loop for i fixnum from i below end
do (a i))))
(setf s1 (mod s1 +adler32-prime+)
s2 (mod s2 +adler32-prime+)))
(locally (declare (type (unsigned-byte 16) s1 s2))
(values s1 s2))))
(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +accumulate-count+
(let ((max most-positive-fixnum))
(flet ((s (n)
(+ (* (1+ n) 65520)
(* (/ (* n (1+ n)) 2) 255))))
(loop with n1 = 0
with n = (/ max 2)
with n2 = max
when (>= (s n) max)
do (psetf n (floor (+ n n1) 2)
n2 n)
else do (psetf n (floor (+ n n2) 2)
n1 n)
until (< (- n2 n1) 2)
finally (return n1))))))
;; need at least 20 or so bits of accumulator, and add a few more so
;; we can unroll
(assert (> +accumulate-count+ 100))
(defun adler32/fixnum (buf end s1 s2)
(declare (type octet-vector buf)
(type (unsigned-byte 16) s1 s2)
(type non-negative-fixnum end)
(optimize speed))
(let* ((unroll #1=#.+adler32-unroll+)
(chunk-size
(* unroll (floor +accumulate-count+ unroll)))
(s1 s1)
(s2 s2))
(declare (type non-negative-fixnum s1 s2 chunk-size))
(assert (<= end (length buf)))
(macrolet ((a (i)
`(progn
(setf s1 (the fixnum (+ s1
(the octet (aref buf (the fixnum ,i))))))
(setf s2 (the fixnum (+ s2 s1)))))
(unroll (n)
`(progn
,@(loop for x below n
collect `(a (+ i ,x))))))
(loop with i of-type non-negative-fixnum = 0
for rem fixnum = (the fixnum (- end i))
for c fixnum = (the fixnum (+ i
(the fixnum
(min (* #1# (floor rem #1#))
chunk-size))))
while (> rem #1#)
do (loop while (< i c)
do (unroll #1#)
(locally (declare (optimize (safety 0)))
(setf i (the fixnum (+ i #1#)))))
(setf s1 (mod s1 +adler32-prime+)
s2 (mod s2 +adler32-prime+))
finally (progn
(assert (<= i end))
(loop for i fixnum from i below end
do (a i))))
(setf s1 (mod s1 +adler32-prime+)
s2 (mod s2 +adler32-prime+)))
(locally (declare (type (unsigned-byte 16) s1 s2))
(values s1 s2)))))
(defun adler32/ub32 (buf end s1 s2)
(declare (type octet-vector buf)
(type (unsigned-byte 16) s1 s2)
(type fixnum end)
(optimize speed ))
;; with 32bit accumulators, we need to do the MOD every 5552 adds.
(let* ((unroll #1=#.+adler32-unroll+)
(chunk-size (* unroll (floor 5552 unroll)))
(s1 s1)
(s2 s2))
(declare (type (unsigned-byte 32) s1 s2))
(assert (<= end (length buf)))
(macrolet ((a (i)
`(progn
(setf s1 (the (unsigned-byte 32) (+ s1 (aref buf ,i))))
(setf s2 (the (unsigned-byte 32) (+ s2 s1)))))
(unroll (n)
`(progn
,@(loop for x below n
collect `(a (+ i ,x))))))
(loop with i fixnum = 0
while (> (- end i) #1#)
for c fixnum = (+ i (min (* #1# (floor (- end i) #1#))
chunk-size))
do (loop while (< i c)
do (unroll #1#)
(locally (declare (optimize (safety 0)))
(incf i #1#)))
(setf s1 (mod s1 +adler32-prime+)
s2 (mod s2 +adler32-prime+))
finally (progn
(assert (<= i end))
(loop for i from i below end
do (a i))))
(setf s1 (mod s1 +adler32-prime+)
s2 (mod s2 +adler32-prime+)))
(locally (declare (type (unsigned-byte 16) s1 s2))
(values s1 s2))))
(declaim (inline adler32))
(defun adler32 (buf end s1 s2)
#+#.(3bz::use-adler32 :ub64)
(adler32/ub64 buf end s1 s2)
#+#.(3bz::use-adler32 :fixnum)
(adler32/fixnum buf end s1 s2)
#+#.(3bz::use-adler32 :ub32)
(adler32/ub32 buf end s1 s2))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun generate-crc32-table ()
(let ((table (make-array 256 :element-type '(unsigned-byte 32))))
(loop for n below (length table)
do (setf (aref table n)
(let ((c n))
(loop for k below 8
if (oddp c)
do (setf c (logxor #xedb88320 (ash c -1)))
else
do (setf c (ash c -1)))
c)))
table)))
(declaim (type (simple-array (unsigned-byte 32) (256)) +crc32/table+))
(alexandria:define-constant +crc32/table+
(generate-crc32-table) :test 'equalp)
(defun crc32/table (buf end crc)
(declare (type octet-vector buf)
(type fixnum end)
(type (unsigned-byte 32) crc)
(optimize speed))
(let ((crc (logxor crc #xffffffff)))
(declare (type (unsigned-byte 32) crc))
(loop for b across buf
repeat end
do (setf crc
(logxor (ldb (byte 24 8) crc)
(aref +crc32/table+
(ldb (byte 8 0)
(logxor crc b))))))
(logxor crc #xffffffff)))

73
quicklisp/dists/quicklisp/software/3bz-20201220-git/constants.lisp Normal file
View file

@ -0,0 +1,73 @@
(in-package 3bz)
;; libz says these are enough entries for zlib as specified
(defconstant +max-tree-entries/len+ 852)
(defconstant +max-tree-entries/dist+ 592)
(defconstant +max-tree-size+ (+ +max-tree-entries/len+
+max-tree-entries/dist+))
;; max # of bits for an encoded huffman tree entry + and optional extra bits
;; (= 15 bits + 13 extra bits)
(defconstant +ht-max-bits+ 28)
;; low-bit tags for nodes in tree
(defconstant +ht-literal+ #b00)
(defconstant +ht-link/end+ #b01)
(defconstant +ht-len/dist+ #b10)
(defconstant +ht-invalid+ #b11)
;; 'end' code in lit/len alphabet
(defconstant +end-code+ 256)
;; first length code in lit/len alphabet
(defconstant +lengths-start+ 257)
;; last valid length (there are some extra unused values to fill tree)
(defconstant +lengths-end+ 285)
;; offset of length codes in extra-bits tables
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +lengths-extra-bits-offset+ 32))
(defconstant +adler32-prime+ 65521)
;; extra-bits and len/dist-bases store
(declaim (type (simple-array (unsigned-byte 4)
(#. (+ 29 +lengths-extra-bits-offset+)))
+extra-bits+)
(type (simple-array (unsigned-byte 16)
(#. (+ 29 +lengths-extra-bits-offset+)))
+len/dist-bases+))
(alexandria:define-constant +extra-bits+
(concatenate
'(simple-array (unsigned-byte 4) (61))
(replace (make-array +lengths-extra-bits-offset+ :initial-element 0)
#(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13))
#(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0))
:test 'equalp)
;; base length value for each length/distance code, add to extra bits
;; to get length
(alexandria:define-constant +len/dist-bases+
(concatenate '(simple-array (unsigned-byte 16) (61))
(replace (make-array +lengths-extra-bits-offset+ :initial-element 0)
#(1 2 3 4 5 7 9 13 17 25 33 49 65 97
129 193 257 385 513 769
1025 1537 2049 3073 4097 6145 8193
12289 16385 24577))
#(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99
115 131 163 195 227 258))
:test 'equalp)
(declaim (type (simple-array (unsigned-byte 8) (19)) +len-code-order+))
(alexandria:define-constant +len-code-order+
(coerce #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15)
'(simple-array (unsigned-byte 8) (19)))
:test 'equalp)
(declaim (type (simple-array (unsigned-byte 4) (19)) +len-code-extra+))
(alexandria:define-constant +len-code-extra+
(coerce #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 7)
'(simple-array (unsigned-byte 4) (19)))
:test 'equalp)

303
quicklisp/dists/quicklisp/software/3bz-20201220-git/deflate-test.lisp Normal file
View file

@ -0,0 +1,303 @@
(in-package 3bz)
#++
(ql:quickload '(salza2 flexi-streams chipz))
#++
(defun dump-deflate (octets &rest options)
(let ((uiop:*default-stream-element-type* '(unsigned-byte 8)))
(flex:with-input-from-sequence (s octets)
(sb-ext:run-program
;; -r = raw deflate data, -d = print dynamic header, -s = print stats
#p"~/src/infgen/infgen.exe" (or options '("-rds"))
:input s
:output *standard-output*))))
#++
(let* ((v (salza2:compress-data (coerce #(1 2 3 4 1 2 3 4 1 2) 'octet-vector) 'salza2:deflate-compressor))
(c (make-instance 'octet-vector-context
:octet-vector v
:boxes (make-context-boxes :end (length v))))
(state (make-deflate-state)))
(dump-deflate v)
(print (length (time (chipz:decompress nil 'chipz:deflate v))))
(time
(decompress c state)))
;; test streams from https://github.com/nayuki/Simple-DEFLATE-decompressor/blob/master/java/test/DecompressorTest.java
(defun deflate-test (in out &optional err)
(declare (ignorable err))
(let* ((in (remove #\space in))
(out (remove #\space out))
(octets (make-array (* (ceiling (length in) 8))
:element-type 'octet :initial-element 0)))
(declare (ignorable out))
(loop for c across in
for x from 0
for bit = (mod x 8)
for byte = (floor x 8)
do (setf (ldb (byte 1 bit) (aref octets byte))
(digit-char-p c)))
(format t "~&test ~s~% -> ~x~%" in octets)
(dump-deflate octets)
(let* ((c (make-instance 'octet-vector-context
:octet-vector octets
:boxes (make-context-boxes :end (length octets))))
(state (make-deflate-state))
(d #++(with-output-to-string (*standard-output*)
(decompress c state)
#++(loop for b = (read-struct 'deflate-block c)
when (data b)
do (loop for a across (data b)
do (format s "~2,'0x" a))
until (plusp (bfinal b))))
(let* ((tmp (make-array 1024 :element-type 'octet))
(d1 (decompress c state :into tmp)))
(setf d1 (list (subseq tmp 0 d1)))
(with-output-to-string (s)
(loop for v in d1
do (loop for x across v
do (format s "~2,'0x" x)))))))
(format t "got <~a>~%" d)
(format t "expected <~a>~%" out)
(unless err (assert (string= d out))))))
;; No blocks
(deflate-test "" "" 'eof)
;; Reserved block type
(deflate-test "1 11 00000" "" 'format)
;; Partial block type
(deflate-test "1 0" "" 'eof) ;;
;; Uncompressed block len=0: (empty)
(deflate-test "1 00 00000 0000000000000000 1111111111111111" "")
;; Uncompressed block len=3: 05 14 23
(deflate-test "1 00 00000 1100000000000000 0011111111111111 10100000 00101000 11000100" "05 14 23") ;
;; Uncompressed block len=1: 05
;; Uncompressed block len=2: 14 23
(deflate-test "0 00 00000 0100000000000000 1011111111111111 10100000 00101000 1 00 00000 1000000000000000 0111111111111111 11000100" "05 14 23") ;
;; Uncompressed block (partial padding) (no length)
(deflate-test "1 00 000" "" 'eof) ;
;; Uncompressed block (partial length)
(deflate-test "1 00 00000 0000000000" "" 'eof)
;; Uncompressed block (mismatched len and nlen)
(deflate-test "1 00 00000 0010000000010000 1111100100110101" "" 'format)
;; Uncompressed block len=6: 55 EE (End)
(deflate-test "1 00 11111 0110000000000000 1001111111111111 10101010 01110111" "" 'eof) ;
;; Uncompressed block len=0: (empty)
;; No final block
(deflate-test "0 00 00000 0000000000000000 1111111111111111" "" 'eof)
;; Fixed Huffman block: 90 A1 FF End
;; Uncompressed block len=2: AB CD
(deflate-test "0 10 110010000 110100001 111111111 0000000 1 00 0100000000000000 1011111111111111 11010101 10110011" "90 A1 FF AB CD") ;
;; Fixed Huffman block: End
(deflate-test "1 10 0000000" "") ;
;; Fixed Huffman block: 00 80 8F 90 C0 FF End
(deflate-test "1 10 00110000 10110000 10111111 110010000 111000000 111111111 0000000" "00 80 8F 90 C0 FF") ;
;; Fixed Huffman block: 00 01 02 (33) End
(deflate-test "1 10 00110000 00110001 00110010 0000001 00010 0000000" "00 01 02 00 01 02") ;
;; Fixed Huffman block: 01 (14) End
(deflate-test "1 10 00110001 0000010 00000 0000000" "01 01 01 01 01") ;
;; Fixed Huffman block: 8E 8F (25) End
(deflate-test "1 10 10111110 10111111 0000011 00001 0000000" "8E 8F 8E 8F 8E 8F 8E") ;
;; Fixed Huffman block: #286
(deflate-test "1 10 11000110" "" 'format) ;
;; Fixed Huffman block: #287
(deflate-test "1 10 11000111" "" 'format) ;
;; Fixed Huffman block: 00 #257 #30
(deflate-test "1 10 00110000 0000001 11110" "" 'format) ;
;; Fixed Huffman block: 00 #257 #31
(deflate-test "1 10 00110000 0000001 11111" "" 'format) ;
;; Fixed Huffman block: (partial symbol)
(deflate-test "1 10 00000" "" 'eof) ;
;; Fixed Huffman block: 00 #269+1(partial)
(deflate-test "1 10 00110000 0001101 1" "" 'eof) ;
;; Fixed Huffman block: 00 #285 #0 #257 #8+00(partial)
(deflate-test "1 10 00110000 11000101 00000 0000001 01000 00" "" 'eof) ;
;; Dynamic Huffman block:
;; numCodeLen=19
;; codeLenCodeLen = 0:0 1:1 2:0 ... 15:0 16:0 17:0 18:1
;; numLitLen=257 numDist=2
;; litLenCodeLen = 0:1 1:0 ... 255:0 256:1
;; distCodeLen = 0:1 1:1
;; Data: End
(let ((blockHeader "1 01")
(codeCounts "00000 10000 1111")
(codeLenCodeLens "000 000 100 000 000 000 000 000 000 000 000 000 000 000 000 000 000 100 000")
(codeLens "0 11111111 10101011 0 0 0")
(data "1"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens codeLens data) ""))
;; Dynamic Huffman block:
;; numCodeLen=18
;; codeLenCodeLen = 0:2 1:2 2:0 ... 15:0 16:0 17:0 18:1
;; numLitLen=257 numDist=1
;; litLenCodeLen = 0:0 ... 254:0 255:1 256:1
;; distCodeLen = 0:0
;; Data: End
(let ((blockHeader "1 01")
(codeCounts "00000 00000 0111")
(codeLenCodeLens "000 000 100 010 000 000 000 000 000 000 000 000 000 000 000 000 000 010")
(codeLens "01111111 00101011 11 11 10")
(data "1"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens codeLens data) ""))
;; Dynamic Huffman block:
;; numLitLen=257 numDist=1 numCodeLen=18
;; codeLenCodeLen = 0:0 1:1 2:0 ... 15:0 16:1 17:0 18:0
;; Literal/length/distance code lengths: #16+00
(let ((blockHeader "1 01")
(codeCounts "00000 00000 0111")
(codeLenCodeLens "100 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 100")
(codeLens "1"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens codeLens) "" 'format))
;; Dynamic Huffman block:
;; numLitLen=257 numDist=1 numCodeLen=18
;; codeLenCodeLen = 0:0 1:1 2:0 ... 15:0 16:0 17:0 18:1
;; Literal/length/distance code lengths: 1 1 #18+1111111 #18+1101100
(let ((blockHeader "1 01") ;
(codeCounts "00000 00000 0111") ;
(codeLenCodeLens "000 000 100 000 000 000 000 000 000 000 000 000 000 000 000 000 000 100") ;
(codeLens "0 0 11111111 10011011")) ;
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens codeLens) "" 'format))
;; Dynamic Huffman block:
;; numLitLen=257 numDist=1 numCodeLen=4
;; codeLenCodeLen = 0:1 1:1 2:1 3:0
(let ((blockHeader "1 01")
(codeCounts "00000 00000 0000")
(codeLenCodeLens "100 100 100 000")
(padding "0000000000000000000"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens padding) "" 'format)) ;
;; Dynamic Huffman block:
;; numLitLen=257 numDist=1 numCodeLen=4
;; codeLenCodeLen = 0:1 1:1 2:1 3:1
(let ((blockHeader "1 01")
(codeCounts "00000 00000 0000")
(codeLenCodeLens "100 100 100 100")
(padding "0000000000000000000"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens padding) "" 'format)) ;
;; Dynamic Huffman block:
;; numLitLen=257 numDist=1 numCodeLen=4
;; codeLenCodeLen = 0:1 1:2 2:3 3:0
(let ((blockHeader "1 01")
(codeCounts "00000 00000 0000")
(codeLenCodeLens "100 010 110 000")
(padding "0000000000000000000"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens padding) "" 'format)) ;
;; Dynamic Huffman block:
;; numLitLen=257 numDist=1 numCodeLen=4
;; codeLenCodeLen = 0:0 1:0 2:0 3:0
(let ((blockHeader "1 01")
(codeCounts "00000 00000 0000")
(codeLenCodeLens "000 000 000 000")
(padding "0000000000000000000"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens padding) "" 'format)) ;
;; Dynamic Huffman block:
;; numLitLen=257 numDist=1 numCodeLen=4
;; codeLenCodeLen = 0:0 1:0 2:1 3:0
(let ((blockHeader "1 01")
(codeCounts "00000 00000 0000")
(codeLenCodeLens "000 000 100 000")
(padding "0000000000000000000"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens padding) "" 'format)) ;
;; Dynamic Huffman block:
;; numLitLen=257 numDist=1 numCodeLen=4
;; codeLenCodeLen = 0:2 1:1 2:0 3:0
(let ((blockHeader "1 01")
(codeCounts "00000 00000 0000")
(codeLenCodeLens "010 100 000 000")
(padding "0000000000000000000"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens padding) "" 'format)) ;
;; Dynamic Huffman block:
;; numLitLen=258 numDist=1 numCodeLen=18
;; codeLenCodeLen = 0:2 1:2 2:2 ... 15:0 16:0 17:0 18:2
;; Literal/length/distance code lengths: 0 2 #18+1111111 #18+1101001 1 2 1
;; Data: 01 #257 #0 #256
(let ((blockHeader "1 01")
(codeCounts "10000 00000 0111")
(codeLenCodeLens "000 000 010 010 000 000 000 000 000 000 000 000 000 000 000 010 000 010")
(codeLens "00 10 111111111 111001011 01 10 01")
(data "10 11 0 0"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens codeLens data) "01 01 01 01")) ;
;; Dynamic Huffman block:
;; numLitLen=258 numDist=1 numCodeLen=18
;; codeLenCodeLen = 0:2 1:2 2:2 ... 15:0 16:0 17:0 18:2
;; Literal/length/distance code lengths: 0 2 #18+1111111 #18+1101001 1 2 1
;; Data: 01 #257 #31 #256
(let ((blockHeader "1 01")
(codeCounts "10000 00000 0111")
(codeLenCodeLens "000 000 010 010 000 000 000 000 000 000 000 000 000 000 000 010 000 010")
(codeLens "00 10 111111111 111001011 01 10 01")
(data "10 11 1 0"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens codeLens data) "01 01 01 01" 'format)) ;
;; Dynamic Huffman block:
;; numLitLen=258 numDist=1 numCodeLen=18
;; codeLenCodeLen = 0:2 1:2 2:2 ... 15:0 16:0 17:0 18:2
;; Literal/length/distance code lengths: 2 #18+1111111 #18+1101010 1 2 0
;; Data: 00 #257
(let ((blockHeader "1 01")
(codeCounts "10000 00000 0111")
(codeLenCodeLens "000 000 010 010 000 000 000 000 000 000 000 000 000 000 000 010 000 010")
(codeLens "10 111111111 110101011 01 10 00")
(data "10 11")
(padding "0000000000000000"))
(deflate-test (concatenate 'string blockHeader codeCounts codeLenCodeLens codeLens data padding) "" 'format)) ;

727
quicklisp/dists/quicklisp/software/3bz-20201220-git/deflate.lisp Normal file
View file

@ -0,0 +1,727 @@
(in-package 3bz)
#++(ql:quickload '3bz)
(defstruct-cached (deflate-state (:conc-name ds-))
;; current state machine state
(current-state :start-of-block)
;; set when reading last block in stream
(last-block-flag nil :type (or nil t))
;; storage for dynamic huffman tree, modified for each dynamic block
(dynamic-huffman-tree (cons (make-huffman-tree) (make-huffman-tree))
:type (cons huffman-tree huffman-tree))
;; reference to either dynamic-huffman-tree or *static-huffman-tree*
;; depending on curret block
(current-huffman-tree +static-huffman-trees+
:type (cons huffman-tree huffman-tree))
;; dynamic huffman tree parameters being read
(dht-hlit 0 :type (unsigned-byte 10))
(dht-hlit+hdist 0 :type (unsigned-byte 10))
(dht-hclen 0 :type (unsigned-byte 4))
(dht-len-codes (make-array 19 :element-type '(unsigned-byte 4)
:initial-element 0)
:type (simple-array (unsigned-byte 4) (19)))
(dht-len-tree (make-huffman-tree)) ;; fixme: reduce size
(dht-lit/len/dist (make-array (+ 288 32) :element-type '(unsigned-byte 4)
:initial-element 0)
:type code-table-type)
(dht-lit/len/dist-index 0 :type (mod 320))
(dht-last-len #xff :type octet)
;; number of bytes left to copy (for uncompressed block, or from
;; history in compressed block)
(bytes-to-copy 0 :type (unsigned-byte 16))
(copy-offset 0 :type (unsigned-byte 16))
;; bitstream state: we read up to 64bits at a time to try to
;; minimize time spent interacting with input source relative to
;; decoding time.
(partial-bits 0 :type (unsigned-byte 64))
;; # of valid bits remaining in partial-bits (0 = none)
(bits-remaining 0 :type (unsigned-byte 7))
;; output state
(output-offset 0 :type fixnum) ;; next octet to write
(output-buffer (make-array 0 :element-type 'octet)
:type octet-vector)
;; window (only used if output buffer is filled mid-decode,
;; otherwise output buffer is used directly)
(window nil :type (or null octet-vector))
;;; status for caller:
;; true if reached end of final block, and 'output' contains all
;; decompressed data
(finished nil :type (or nil t))
;; true if there isn't enough space in 'output' to finish
(output-overflow nil :type (or nil t))
;; true if input is empty (or incomplete) without reaching end of
;; final block
(input-underrun nil :type (or nil t)))
(defmacro state-machine ((state) &body tagbody)
(let ((tags (loop for form in tagbody when (atom form) collect form)))
`(symbol-macrolet ((.current-state ,(list nil)))
(macrolet ((next-state (next-state)
`(progn
(setf current-state ',next-state)
(go ,next-state)))
(%enter-state (s &environment env)
(setf (car (macroexpand '.current-state env)) s)
`(progn #++(format t "~s~%" ',s)))
(restart-state (&environment env)
`(go ,(car (macroexpand '.current-state env)))))
(tagbody
;; possibly could do better than a linear search here, but
;; if state machine is being interrupted often enough to
;; matter, it probably won't matter anyway :/ at most,
;; maybe define more commonly interrupted states earlier
(ecase (ds-current-state ,state)
,@(loop for i in tags
collect `(,i (go ,i))))
,@(loop for f in tagbody
collect f
when (atom f)
collect `(%enter-state ,f)))))))
(defparameter *stats* (make-hash-table))
(defun-with-reader-contexts decompress-deflate (read-context state)
(read-context)
(declare (optimize speed))
(with-cached-state (state deflate-state save-state
partial-bits bits-remaining
current-huffman-tree
output-offset
current-state
bytes-to-copy
output-buffer)
(setf output-overflow nil
input-underrun nil)
(macrolet ((bits* (&rest sizes)
;; only valid for fixed sizes, but possibly should
;; allow passing +constants+ and try to eval them
;; at macroexpansion instead of requiring numbers?
(let ((n (reduce '+ sizes)))
`(let ((b (bits ,n)))
(declare (type (unsigned-byte ,n) b))
(values ,@(loop for o = 0 then (+ o s)
for s in sizes
collect `(ldb (byte ,s ,o) b))))))
(eoi () ;; end of input
#++ (error "eoi")
#++ (go :eoi)
`(progn
(setf input-underrun t)
(save-state)
(throw :exit-loop :eoi)))
(eoo () ;; end of output
`(let ((window-size (expt 2 15)))
(declare (optimize (speed 1)))
(unless (ds-window state)
(setf (ds-window state)
;; extra few bytes so we can use word-size
;; copies
(make-array (+ window-size 8)
:element-type 'octet)))
(when (< output-offset window-size)
(replace (ds-window state) (ds-window state)
:start2 output-offset))
(replace (ds-window state) output-buffer
:start1 (max 0 (- window-size output-offset))
:start2 (max 0 (- output-offset window-size)))
(save-state)
(throw :exit-loop :eoo))))
(let ((ht-scratch (make-huffman-tree)))
(labels ((bits-avail (n)
(<= n bits-remaining))
(byte-align ()
(let ((r (mod bits-remaining 8)))
(unless (zerop r)
(setf partial-bits (ash partial-bits (- r)))
(decf bits-remaining r))))
;; called when temp is empty, read bits and update
;; remaining
(%fill-bits ()
#+#.(3bz::use-ub64)
(multiple-value-bind (input octets)
(word64)
(declare (type (mod 9) octets)
(type (unsigned-byte 64) input))
(setf bits-remaining (* 8 octets)
partial-bits input))
#-#.(3bz::use-ub64)
(multiple-value-bind (input octets)
(word32)
(declare (type (mod 5) octets)
(type (unsigned-byte 32) input))
(setf bits-remaining (* 4 octets)
partial-bits input)))
(%fill-bits32 (n)
(multiple-value-bind (input octets)
(word32)
(declare (type (mod 5) octets)
(type (unsigned-byte 32) input))
(setf partial-bits
(logior
(ash (ldb (byte 32 0) input)
(min 32 bits-remaining))
partial-bits))
(incf bits-remaining (* 8 octets))
(>= bits-remaining n)))
;; internals of bit reader, only call after
;; ensuring there are enough bits available
(%bits (n)
(prog1 (ldb (byte n 0) partial-bits)
(setf partial-bits (ash partial-bits (- n)))
(decf bits-remaining n)))
;; fast path for bit reader, inlined
(bits (n)
(if (<= n bits-remaining)
(%bits n)
(bits-full n)))
;; slow path for bit reader, not inlined (should
;; only be called if we know there aren't enough
;; bits in temp. usually called from BITS)
(bits-full (n)
;; we could handle 64 bits, but we limit it to
;; make it more likely to fit in a fixnum
(declare (type (mod 56) n))
;; try to read (up to) 64 bits from input
;; (returns 0 in OCTETS if no more input)
(multiple-value-bind (input octets)
;; some callers need more than 32 bits at once,
;; so no use-ub64 here for now
(word64)
(declare (type (mod 9) octets)
(type (unsigned-byte 6) bits-remaining)
(type (unsigned-byte 64) input))
(let* ((bits (* octets 8))
(total (+ bits-remaining bits)))
;; didn't read enough bits, save any bits we
;; did get for later, then fail
(when (> n total)
(assert (<= total 64))
(setf partial-bits
(ldb (byte 64 0)
(logior (ash input bits-remaining)
partial-bits)))
(setf bits-remaining total)
(eoi))
;; if we get here, we have enough bits now,
;; so combine them and store any leftovers
;; for later
(let* ((n2 (- n bits-remaining))
(r (ldb (byte n 0)
(logior (ash (ldb (byte n2 0) input)
bits-remaining)
(ldb (byte bits-remaining 0)
partial-bits))))
(bits2 (- bits n2)))
(declare (type (unsigned-byte 6) n2)
(type (unsigned-byte 64) r))
(setf partial-bits (ash input (- n2))
bits-remaining bits2)
r))))
(out-byte (b)
(setf (aref output-buffer output-offset) b)
(setf output-offset (wrap-fixnum (1+ output-offset)))
nil)
(copy-byte-or-fail ()
(out-byte (bits 8)))
(%copy-history (from to s d e count total-count offset)
(declare (type non-negative-fixnum d e)
(type fixnum s)
(type non-negative-fixnum count offset total-count))
(cond
;; if copy won't fit (or oversized copy below
;; might overrun buffer), use slow path for
;; now
((> (+ d count 8)
e)
(loop while (< d e)
while (plusp count)
do (setf (aref to d)
(aref from s))
(setf d (1+ d))
(setf s (1+ s))
(decf count)
(decf total-count))
;; todo: store state so it can continue
(when (plusp count)
(setf bytes-to-copy total-count)
(setf copy-offset offset)
(setf current-state :continue-copy-history)
(setf output-offset d)
(setf output-overflow t)
(eoo)))
;; to speed things up, we allow writing past
;; current output index (but not past end of
;; buffer), and read/write as many bytes at a
;; time as possible.
#+#.(3bz::use-ub64)
((> offset 8)
(loop repeat (ceiling count 8)
do (setf (ub64ref/le to d)
(ub64ref/le from s))
(setf d (wrap-fixnum (+ d 8)))
(setf s (wrap-fixnum (+ s 8)))))
((= offset 1)
;; if offset is 1, we are just repeating a
;; single byte...
(loop with x of-type octet = (aref from s)
repeat count
do (setf (aref to d) x)
(setf d (wrap-fixnum (1+ d)))))
#+#.(3bz::use-ub64)
((= offset 8)
(loop with x of-type ub64 = (ub64ref/le from s)
repeat (ceiling count 8)
do (setf (ub64ref/le to d)
x)
(setf d (wrap-fixnum (+ d 8)))))
((> offset 4)
(loop repeat (ceiling count 4)
do (setf (ub32ref/le to d)
(ub32ref/le from s))
(setf d (wrap-fixnum (+ d 4)))
(setf s (wrap-fixnum (+ s 4)))))
#+#.(3bz::use-ub64)
((= offset 4)
(loop with x of-type ub32 = (ub32ref/le from s)
with xx of-type ub64 = (dpb x (byte 32 32) x)
repeat (ceiling count 8)
do (setf (ub64ref/le to d) xx)
(setf d (wrap-fixnum (+ d 8)))))
#-#.(3bz::use-ub64)
((= offset 4)
(loop with x of-type ub32 = (ub32ref/le from s)
repeat (ceiling count 4)
do (setf (ub32ref/le to d) x)
(setf d (wrap-fixnum (+ d 4)))))
((= offset 3)
(loop repeat (ceiling count 2)
do (setf (ub16ref/le to d)
(ub16ref/le from s))
(setf d (wrap-fixnum (+ d 2)))
(setf s (wrap-fixnum (+ s 2)))))
#+#.(3bz::use-ub64)
((= offset 2)
(loop with x of-type ub16 = (ub16ref/le from s)
with xx of-type ub32 = (dpb x (byte 16 16) x)
with xxxx of-type ub64 = (dpb xx (byte 32 32) xx)
repeat (ceiling count 8)
do (setf (ub64ref/le to d) xxxx)
(setf d (wrap-fixnum (+ d 8)))))
#-#.(3bz::use-ub64)
((= offset 2)
(loop with x of-type ub16 = (ub16ref/le from s)
with xx of-type ub32 = (dpb x (byte 16 16) x)
repeat (ceiling count 4)
do (setf (ub32ref/le to d) xx)
(setf d (wrap-fixnum (+ d 4)))))
(t (error "?"))))
(copy-history (count offset)
(declare (type non-negative-fixnum count offset))
(let* ((d output-offset)
(s (- d offset))
(e (length output-buffer))
(n count))
(when (< s 0)
(unless window
(error "no window?"))
(let ((c (min count (abs s))))
(%copy-history window output-buffer
(+ 32768 s) d e
c count offset)
(decf n c)
(setf d (wrap-fixnum (+ d c))))
(setf s 0))
(when (plusp n)
(%copy-history output-buffer output-buffer
s d e n n offset))
;; D may be a bit past actual value, so calculate
;; correct offset
(setf output-offset
(wrap-fixnum (+ output-offset count)))))
(decode-huffman-full (ht old-bits old-count)
(declare (type huffman-tree ht)
(type (unsigned-byte 32) old-bits)
(type (or null (unsigned-byte 6)) old-count))
(let ((ht-bits (ht-start-bits ht))
(bits partial-bits)
;; # of valid bits left in BITS
(avail bits-remaining)
;; offset of next unused bit in BITS
(offset 0)
;; if we had to refill bits, # we had before refill
(old 0)
(extra-bits nil)
(node 0)
(nodes (ht-nodes ht)))
(declare (type (unsigned-byte 64) bits)
(type (unsigned-byte 7) avail)
(type (unsigned-byte 7) old)
(type ht-bit-count-type ht-bits))
(loop
;; if we don't have enough bits, add some
when (> ht-bits avail)
do (incf old bits-remaining)
(%fill-bits)
;; dist + extra is max 28 bits, so just
;; grab enough for that from new input
;; if available
(assert (< old 32))
(setf bits
(logior bits
(ash
(ldb (byte (min 30 bits-remaining)
0)
partial-bits)
old)))
(setf avail
(min 64
(+ avail (min 30 bits-remaining))))
(when (> ht-bits avail)
;; still not enough bits, push bits back
;; onto tmp if we read more, and EOI
(assert (< old 64))
(assert (< (+ bits-remaining old) 64))
(setf partial-bits
(ldb (byte 64 0)
(ash partial-bits old)))
(setf (ldb (byte old 0) partial-bits)
(ldb (byte old 0) bits))
(incf bits-remaining old)
;; if we are reading a dist, put bits
;; from len back too so we don't need
;; separate states for lit/len and dist
(locally
(declare #+sbcl (sb-ext:muffle-conditions
sb-ext:code-deletion-note))
(when old-count
;; (lit/len + dist + extras is max 48
;; bits, so just
(assert (< (+ old-count bits-remaining) 64))
(setf partial-bits
(ldb (byte 64 0)
(ash partial-bits old-count)))
(setf (ldb (byte old-count 0) partial-bits)
(ldb (byte old-count 0) old-bits))
(incf bits-remaining old-count)))
(eoi))
if extra-bits
do (setf extra-bits (ldb (byte ht-bits offset) bits))
(incf offset ht-bits)
(decf avail ht-bits)
(loop-finish)
else
do (let* ((b (ldb (byte ht-bits offset) bits)))
(setf node (aref nodes (+ node b)))
(incf offset ht-bits)
(decf avail ht-bits)
(ecase (ht-node-type node)
(#.+ht-link/end+
(when (ht-endp node)
(loop-finish))
(setf ht-bits (ht-link-bits node))
(setf node (ht-link-offset node)))
(#.+ht-literal+
(loop-finish))
(#.+ht-len/dist+
(let ((x (ht-extra-bits node)))
(when (zerop x)
(loop-finish))
(setf ht-bits x
extra-bits x))))))
(let ((s (- offset old)))
(assert (< 0 s 64))
(setf partial-bits (ash partial-bits (- s)))
(decf bits-remaining s))
(assert (< offset 32))
(values (ht-value node)
(or extra-bits 0)
(ht-node-type node)
(ldb (byte offset 0) bits)
offset)))
;; specialized version when we know we have enough bits
;; (up to 28 depending on tree)
(%decode-huffman-fast (ht)
(declare (type huffman-tree ht))
(let ((ht-bits (ht-start-bits ht))
(bits partial-bits)
;; offset of next unused bit in BITS
(offset 0)
(extra-bits nil)
(node 0)
(nodes (ht-nodes ht)))
(declare (type (unsigned-byte 64) bits)
(type ht-bit-count-type ht-bits)
(type (unsigned-byte 5) offset))
(loop
for b = (ldb (byte ht-bits offset) bits)
do (setf node (aref nodes (+ node b)))
(incf offset ht-bits)
(ecase (ht-node-type node)
(#.+ht-link/end+
(when (ht-endp node)
(loop-finish))
(setf ht-bits (ht-link-bits node)
node (ht-link-offset node)))
(#.+ht-len/dist+
(let ((x (ht-extra-bits node)))
(when (plusp x)
(setf extra-bits (ldb (byte x offset) bits))
(incf offset x))
(loop-finish)))
(#.+ht-literal+
(loop-finish))))
(setf partial-bits (ash partial-bits (- offset)))
(decf bits-remaining offset)
(values (ht-value node) ;; code
(or extra-bits 0) ;; extra
(ht-node-type node) ;; type
(ldb (byte offset 0) bits) ;; old-bits
offset))) ;; old-count
(decode-huffman (ht old-bits old-count)
;; seems to be faster to just use constant than
;; try to optimize for specific table?
(if (or (bits-avail +ht-max-bits+)
(%fill-bits32 +ht-max-bits+))
(%decode-huffman-fast ht)
(decode-huffman-full ht old-bits old-count))))
(declare (inline bits-avail byte-align %fill-bits %bits bits
out-byte copy-byte-or-fail
decode-huffman %decode-huffman-fast
%fill-bits32 copy-history
%copy-history)
(ignorable #'bits-avail))
(catch :exit-loop
(state-machine (state)
:start-of-block
(multiple-value-bind (final type) (bits* 1 2)
(setf last-block-flag (plusp final))
(ecase type
(0 (next-state :uncompressed-block))
(1 ;; static huffman tree
(setf current-huffman-tree +static-huffman-trees+)
(next-state :decode-compressed-data))
(2
(setf current-huffman-tree dynamic-huffman-tree)
(next-state :dynamic-huffman-block))))
;;; uncompressed block
:uncompressed-block
(byte-align)
(multiple-value-bind (s n) (bits* 16 16)
(assert (= n (ldb (byte 16 0) (lognot s))))
(setf bytes-to-copy s)
(next-state :copy-block))
:copy-block
(loop while (and (plusp bits-remaining)
(plusp bytes-to-copy))
do (out-byte (bits 8))
(decf bytes-to-copy))
(loop with e = (- (length output-buffer) 8)
while (and (> bytes-to-copy 8)
(< output-offset e))
do (multiple-value-bind (w c) #+#.(3bz::use-ub64) (word64) #-#.(3bz::use-ub64) (word32)
(declare (type #+#.(3bz::use-ub64) ub64
#-#.(3bz::use-ub64) ub32))
(cond
#+#.(3bz::use-ub64)
((= 8 c)
(setf (ub64ref/le output-buffer output-offset)
w)
(setf output-offset
(wrap-fixnum (+ output-offset 8)))
(decf bytes-to-copy 8))
#-#.(3bz::use-ub64)
((= 4 c)
(setf (ub32ref/le output-buffer
output-offset)
w)
(setf output-offset
(wrap-fixnum (+ output-offset 4)))
(decf bytes-to-copy 4))
((plusp c)
(loop for i below c
do (out-byte (ldb (byte 8 (* i 8)) w))
(decf bytes-to-copy)))
(t (eoo)))))
(loop while (plusp bytes-to-copy)
do (copy-byte-or-fail)
(decf bytes-to-copy))
(next-state :block-end)
;;; dynamic huffman table block, huffman table
:dynamic-huffman-block
;; we have at least 26 bits of fixed data, 3 length
;; fields, and first 4 code lengths, so try to read
;; those at once
(multiple-value-bind (hlit hdist hclen l16 l17 l18 l0)
(bits* 5 5 4 3 3 3 3)
(let ((dlc dht-len-codes))
(fill dlc 0)
(setf (aref dlc 16) l16)
(setf (aref dlc 17) l17)
(setf (aref dlc 18) l18)
(setf (aref dlc 0) l0))
;; possibly could optimize this a bit more, but
;; should be fairly small part of any normal file
(setf dht-hlit (+ hlit 257)
dht-hlit+hdist (+ dht-hlit hdist 1)
dht-hclen hclen
dht-lit/len/dist-index 0)
(next-state :dht-len-table))
:dht-len-table
;; we read 4 entries with header, so max 15 left = 45
;; bits. wait until we have at least that much
;; available and extract all at once
(let* ((bitcount (* dht-hclen 3))
(bits (bits bitcount))
(permute +len-code-order+)
(lc dht-len-codes))
(declare (type (unsigned-byte 48) bits))
;; extract length codes into proper elements of
;; len-codes
(loop for i from 4
for o from 0 by 3 ;downfrom (- bitcount 3) by 3
repeat dht-hclen
do (setf (aref lc (aref permute i))
(ldb (byte 3 o) bits)))
;; and build a huffman tree out of them
(multiple-value-bind (count bits max)
(build-tree-part dht-len-tree 0
dht-len-codes
:dht-len 0 19
ht-scratch
+len-code-extra+)
(declare (ignore count))
(setf (ht-start-bits dht-len-tree) bits)
(setf (ht-max-bits dht-len-tree) max))
(setf dht-last-len #xff)
(next-state :dht-len-table-data))
:dht-len-table-data
(let ((ht dht-len-tree)
(end dht-hlit+hdist)
(lld dht-lit/len/dist))
;; decode-huffman will EOI if not enough bits
;; available, so we need to track state in loop to
;; be able to continue
(loop while (< dht-lit/len/dist-index end)
do (multiple-value-bind (code extra)
(decode-huffman ht 0 nil)
(cond
((< code 16)
(setf (aref lld dht-lit/len/dist-index)
(setf dht-last-len code))
(incf dht-lit/len/dist-index))
((= code 16)
(unless (< dht-last-len 16)
(error "tried to repeat length without previous length"))
(let ((e (+ dht-lit/len/dist-index extra 3)))
(assert (<= e dht-hlit+hdist))
(loop for i from dht-lit/len/dist-index
repeat (+ extra 3)
do (setf (aref lld i) dht-last-len))
#++(fill lld dht-last-len
:start dht-lit/len/dist-index
:end e)
(setf dht-lit/len/dist-index e)))
(t
(let* ((c (if (= code 17) 3 11))
(e (+ dht-lit/len/dist-index extra c)))
(assert (<= e dht-hlit+hdist))
(fill lld 0
:start dht-lit/len/dist-index
:end e)
(setf dht-lit/len/dist-index e)
(setf dht-last-len 0)))))))
;; if we get here, we have read whole table, build tree
(build-trees* (car dynamic-huffman-tree)
(cdr dynamic-huffman-tree)
dht-lit/len/dist
dht-hlit
dht-lit/len/dist-index
ht-scratch)
(next-state :decode-compressed-data)
;;; dynamic or static huffman block, compressed data
:decode-compressed-data
(symbol-macrolet ((bases +len/dist-bases+)
(ht current-huffman-tree))
(loop
(multiple-value-bind (code extra type old-bits old-count)
(decode-huffman (car ht) 0 nil)
(ecase type
(#.+ht-len/dist+
;; got a length code, read dist and copy
(let ((octets (+ extra (aref bases code))))
;; try to read dist. decode-huffman* will
;; push BITS back onto temp before calling
;; EOI if it fails, so we can restart state
;; at len code
(multiple-value-bind (dist extra)
(decode-huffman (cdr ht)
old-bits old-count)
;; got dist code
(copy-history octets (+ (aref bases dist) extra)))))
(#.+ht-literal+
(when (>= output-offset (length output-buffer))
(setf current-state :out-byte)
(setf bytes-to-copy code)
(setf output-overflow t)
(eoo))
(out-byte code))
(#.+ht-link/end+
(assert (= code 0))
(assert (= extra 0))
(next-state :block-end))))))
;; continue copy if output filled up in the middle
:continue-copy-history
(copy-history bytes-to-copy copy-offset)
(next-state :decode-compressed-data)
:out-byte
(when (> output-offset (length output-buffer))
(when (> output-offset (length output-buffer))
(error "tried to continue from overflow without providing more space in output"))
(setf output-overflow t)
(eoo))
(out-byte bytes-to-copy)
(next-state :decode-compressed-data)
;;; end of a block, see if we are done with deflate stream
:block-end
(if last-block-flag
(next-state :done)
(next-state :start-of-block))
;;; normal exit from state machine
:done
(setf finished t)
;;; any exit from state machine (should set flags first)
:exit-loop)))))
(save-state)
output-offset))

41
quicklisp/dists/quicklisp/software/3bz-20201220-git/gzip-test.lisp Normal file
View file

@ -0,0 +1,41 @@
(in-package 3bz)
#++ (ql:quickload '(ironclad 3bz deoxybyte-gzip chipz))
(defvar *gzip* nil)
(let* ((d (time
(alexandria:read-file-into-byte-vector "e:/tmp/t/linux-2.2.26.tar")))
(tmp (make-array (length d) :element-type 'octet
:initial-element 0))
(v (or *gzip*
(setf *gzip*
(time
(multiple-value-bind (x r w)
(gz:deflate-vector d (make-array (* 2 (length d))
:element-type 'octet)
:compression 9
:gzip-format t)
(declare (ignore r))
(subseq x 0 w)))))))
(format t "chipz:~%")
(fill tmp 0)
(with-simple-restart (continue "continue")
(let ((x (time (chipz:decompress tmp 'chipz:gzip v))))
(declare (ignore x))
(assert (equalp d tmp))))
(fill tmp 0)
(format t "3bz:~%") ;; 0.33
(let ((x (time (decompress-gzip (make-instance 'octet-vector-context
:octet-vector v
:boxes (make-context-boxes
:end (length v)))
(make-gzip-state :output-buffer tmp)))))
(assert (equalp (if (consp x)
(time (apply 'concatenate 'octet-vector x))
(subseq tmp 0 x))
d)))
(fill tmp 0)
(format t "gz:~%")
(let ((x (time (gz:inflate-vector v tmp :gzip-format t))))
(assert (equalp x d)))
nil)

285
quicklisp/dists/quicklisp/software/3bz-20201220-git/gzip.lisp Normal file
View file

@ -0,0 +1,285 @@
(in-package 3bz)
(defstruct (gzip-state (:conc-name gs-)
(:include deflate-state))
;; A compliant decompressor must check ID1, ID2, and CM, and provide
;; an error indication if any of these have incorrect values. It
;; must examine FEXTRA/XLEN, FNAME, FCOMMENT and FHCRC at least so
;; it can skip over the optional fields if they are present. It
;; need not examine any other part of the header or trailer; in
;; particular, a decompressor may ignore FTEXT and OS and always
;; produce binary output, and still be compliant. A compliant
;; decompressor must give an error indication if any reserved bit is
;; non-zero, since such a bit could indicate the presence of a new
;; field that would cause subsequent data to be interpreted
;; incorrectly.
(gzip-state :header)
(compression-method nil)
(flags nil)
(extra nil)
(name nil)
(comment nil)
(operating-system nil)
(mtime/unix nil)
(mtime/universal nil)
(compression-level :default)
(header-bytes (make-array 16 :adjustable t :fill-pointer 0))
(crc32 0 :type (unsigned-byte 32)))
(defun decompress-gzip (read-context state)
(check-type state gzip-state)
;; fixme: avoid duplication with these from deflate/zlib
(with-reader-contexts (read-context)
(with-accessors ((input-underrun gs-input-underrun)
(gzip-state gs-gzip-state)
(partial-bits gs-partial-bits)
(bits-remaining gs-bits-remaining)
(finished gs-finished)
(flags gs-flags)
(compression-level gs-compression-level)
(compression-method gs-compression-method)
(output-buffer gs-output-buffer)
(output-offset gs-output-offset)
(output-overflow gs-output-overflow)
(header-bytes gs-header-bytes)
(mtime/unix gs-mtime/unix)
(mtime/universal gs-mtime/universal)
(extra gs-extra)
(name gs-name)
(comment gs-comment)
(operating-system gs-operating-system)
(crc32 gs-crc32))
state
(labels ((%fill-bits32 (n)
(multiple-value-bind (input octets)
(word32)
(declare (type (mod 5) octets))
(setf partial-bits
(logior
(ash (ldb (byte 32 0) input)
(min 32 bits-remaining))
partial-bits))
(incf bits-remaining (* 8 octets))
(>= bits-remaining n)))
(%bits (n)
(prog1 (ldb (byte n 0) partial-bits)
(setf partial-bits (ash partial-bits (- n)))
(decf bits-remaining n)))
(header-byte ()
(let ((b (%bits 8)))
;; might need to crc header, so store a copy
(when header-bytes
(vector-push-extend b header-bytes))
b))
(byte-align ()
(let ((r (mod bits-remaining 8)))
(unless (zerop r)
(setf partial-bits (ash partial-bits (- r)))
(decf bits-remaining r))))
(update-checksum ()
(setf crc32 (crc32/table output-buffer output-offset crc32)))
(crc ()
(when (and (< bits-remaining 32)
(not (%fill-bits32 32)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(let ((crc (logior (ash (header-byte) 0)
(ash (header-byte) 8)
(ash (header-byte) 16)
(ash (header-byte) 24))))
#++(format t "crc = ~8,'0x ?= ~8,'0x~%"
crc crc32)
(assert (= crc crc32))
(setf gzip-state :final-len)))
(len ()
(when (and (< bits-remaining 32)
(not (%fill-bits32 32)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(let ((len (logior (ash (header-byte) 0)
(ash (header-byte) 8)
(ash (header-byte) 16)
(ash (header-byte) 24))))
len
#++(format t "len = ~8,'0x ?= ~8,'0x~%"
len output-offset)
(setf gzip-state nil))))
(declare (inline %fill-bits32 %bits byte-align)
(optimize (speed 1)))
(setf input-underrun nil)
(loop
while gzip-state
do (case gzip-state
(:header ;; magic #
(when (and (< bits-remaining 16)
(not (%fill-bits32 16)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(let ((id1 (header-byte))
(id2 (header-byte)))
(assert (= id1 #x1f))
(assert (= id2 #x8b))
(setf gzip-state :header2)))
(:header2 ;; compression method, flags
(when (and (< bits-remaining 16)
(not (%fill-bits32 16)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(let ((cm (header-byte))
(flg (header-byte)))
(if (= cm 8)
(setf compression-method :deflate)
(error "unknown compression method ~s~%" cm))
(when (plusp (ldb (byte 3 5) flg))
(error "reserved flag bits set in ~8,'0b" flg))
(when (logbitp 0 flg) (push :text flags))
(if (logbitp 1 flg)
(push :header-crc flags)
;; no crc, stop remembering header contents
(setf header-bytes nil))
(when (logbitp 2 flg) (push :extra flags))
(when (logbitp 3 flg) (push :name flags))
(when (logbitp 4 flg) (push :comment flags))
(setf gzip-state :header-mtime)))
(:header-mtime
(when (and (< bits-remaining 32)
(not (%fill-bits32 32)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(let ((mtime (logior (ash (header-byte) 0)
(ash (header-byte) 8)
(ash (header-byte) 16)
(ash (header-byte) 24))))
(unless (zerop mtime)
(setf mtime/unix mtime)
(setf mtime/universal
(+ mtime (encode-universal-time 0 0 0 1 1 1970 0))))
(setf gzip-state :header3)))
(:header3 ;; extra flags, os
(when (and (< bits-remaining 16)
(not (%fill-bits32 16)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(let ((xfl (header-byte))
(os (header-byte)))
(setf compression-level
(or (case xfl (2 :maximum) (4 :fastest))
xfl))
(setf operating-system
(if (<= 0 os 13)
(aref #(:fat :amiga :vms :unix :vm/cms
:atari-tos :hpfs :macintosh
:z-system :cp/m :tops-20
:ntfs :qdos :acorn-riscos)
os)
(list :unknown os)))
(setf gzip-state :header-extra)))
(:header-extra
(when (member :extra flags)
(unless extra
(when (and (< bits-remaining 16)
(not (%fill-bits32 16)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(let ((xlen (logior (ash (header-byte) 0)
(ash (header-byte) 8))))
(setf extra (make-array xlen :element-type 'octet
:fill-pointer 0))))
(loop while (< (fill-pointer extra)
(length extra))
do (when (and (< bits-remaining 8)
(not (%fill-bits32 8)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(vector-push (header-byte) extra))
(setf extra (coerce extra '(simple-array octet 1))))
(setf gzip-state :header-name))
(:header-name
(when (member :name flags)
(unless name
(setf name (make-array 16 :adjustable t :fill-pointer 0
:element-type 'octet)))
(loop do (when (and (< bits-remaining 8)
(not (%fill-bits32 8)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(let ((b (header-byte)))
(cond
((not (zerop b))
(vector-push-extend b name))
(t
(setf name
;; rfc says 8859-1, but try utf8 anyway
(or (babel:octets-to-string
name :encoding :utf-8 :errorp nil)
(babel:octets-to-string
name :encoding :iso8859-1)))
(loop-finish))))))
(setf gzip-state :header-comment))
(:header-comment
(when (member :comment flags)
(unless comment
(setf comment (make-array 16 :adjustable t :fill-pointer 0
:element-type 'octet)))
(loop do (when (and (< bits-remaining 8)
(not (%fill-bits32 8)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(let ((b (header-byte)))
(cond
((not (zerop b))
(vector-push-extend b comment))
(t
(setf comment
;; rfc says 8859-1, but try utf8 anyway
(or (babel:octets-to-string
comment :encoding :utf-8 :errorp nil)
(babel:octets-to-string
comment :encoding :iso8859-1)))
(loop-finish))))))
(setf gzip-state :header-crc))
(:header-crc
;; check hcrc if present
(when (member :header-crc flags)
(when (and (< bits-remaining 16)
(not (%fill-bits32 16)))
(setf input-underrun t)
(return-from decompress-gzip 0))
(let* ((hb (coerce header-bytes 'octet-vector))
(crc (logior (ash (%bits 8) 0)
(ash (%bits 8) 8)))
(crc32 (crc32/table hb (length hb) 0)))
(format t "got header crc ~4,'0x, expected ~8,'0x~%"
crc crc32)
(assert (= crc (ldb (byte 16 0) crc32)))))
#++(format t "gzip header: method ~s, level ~s, os ~s, flags ~s~%"
compression-method compression-level
operating-system flags)
#++(when mtime/universal
(format t " mtime: ~s~%"
(reverse (multiple-value-list
(decode-universal-time mtime/universal)))))
#++(format t " name: ~s~%" name)
#++(format t " comment: ~s~%" comment)
#++(format t " extra: ~s~%" extra)
(setf gzip-state nil))
(:final-crc
(crc))
(:final-len
(len)
(return-from decompress-gzip output-offset)))
(unless gzip-state
(decompress-deflate read-context state)
(when (or finished output-overflow)
(update-checksum))
(when finished
(byte-align)
(setf gzip-state :final-crc)
(setf finished nil))))
(when (eql :final-crc gzip-state)
(crc))
(when (eql :final-len gzip-state)
(len))
output-offset))))

33
quicklisp/dists/quicklisp/software/3bz-20201220-git/ht-constants.lisp Normal file
View file

@ -0,0 +1,33 @@
(in-package 3bz)
#++
(defconstant +static-huffman-tree+ (if (boundp '+static-huffman-tree+)
+static-huffman-tree+
(make-huffman-tree)))
#++
(build-tree +static-huffman-tree+ *fixed-lit/length-table* *fixed-dist-table*)
#++(dump-tree +static-huffman-tree+)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar %static-huffman-tree/len% (make-huffman-tree))
(defvar %static-huffman-tree/dist% (make-huffman-tree) )
(build-trees %static-huffman-tree/len%
%static-huffman-tree/dist%
*fixed-lit/length-table* *fixed-dist-table*)
(defconstant +static-huffman-tree/len+ (eval
'(if (boundp '+static-huffman-tree/len+)
+static-huffman-tree/len+
%static-huffman-tree/len%)))
(defconstant +static-huffman-tree/dist+ (eval
'(if (boundp '+static-huffman-tree/dist+)
+static-huffman-tree/dist+
%static-huffman-tree/dist%))))
#-ccl
(eval-when (:compile-toplevel :load-toplevel :execute)
(alexandria:define-constant +static-huffman-trees+
(cons +static-huffman-tree/len+ +static-huffman-tree/dist+)
:test 'equalp))
#+ccl
(defparameter +static-huffman-trees+
(cons +static-huffman-tree/len+ +static-huffman-tree/dist+))

333
quicklisp/dists/quicklisp/software/3bz-20201220-git/huffman-tree.lisp Normal file
View file

@ -0,0 +1,333 @@
(in-package 3bz)
;; accessors/predicates/constructors for node in tree
;; low bits 00 = literal
;; low bits 01 = link flag, #x0001 = end, #xffff = invalid
;; low bits 10 = len/dist
;; (low bits 11 = invalid)
(declaim (inline ht-linkp ht-invalidp ht-endp ht-node-type
ht-link-bits ht-link-offset
ht-literalp ht-extra-bits ht-value
ht-link-node ht-literal-node ht-len-node ht-dist-node
ht-invalid-node ht-end-node))
(defun ht-linkp (node)
(oddp node))
(defun ht-invalidp (node)
(= node #xffff))
;; (usually will just check for link bits or link-offset = 0 for endp)
(defun ht-endp (node)
(= node #x0001))
(defun ht-node-type (node)
(ldb (byte 2 0) node))
;; for valid link, store 4 bits of bit-count, 10 bits of table base
(defun ht-link-node (bits index)
(logior +ht-link/end+
(ash bits 2)
(ash index 6)))
(defun ht-link-bits (node)
(ldb (byte 4 2) node))
(defun ht-link-offset (node)
(ldb (byte 10 6) node))
(defun ht-literalp (node)
(zerop (ldb (byte 2 0) node)))
(defun ht-len/dist-p (node)
(= 1 (ldb (byte 2 0) node)))
;; literals just store an 8-bit code value. len/dist codes store an
;; 8-bit index into base array, and 4bits extra bits count
;; fixme: merge these with link, so decoded can treat them the same?
(defun ht-extra-bits (node)
(ldb (byte 4 2) node))
(defun ht-value (node)
(ldb (byte 10 6) node))
(defun ht-literal-node (value)
(logior +ht-literal+
(ash value 6)))
(defun ht-len-node (value extra-bits)
(assert (>= value +lengths-start+))
;; value stored in tree is offset so we can use single table
;; for extra-bits and base-values for lengths and distances
(let ((v (+ +lengths-extra-bits-offset+
(if (>= value +lengths-start+)
(- value +lengths-start+)
value))))
(ldb (byte 16 0)
(logior +ht-len/dist+
(ash v 6)
(ash (aref extra-bits v) 2)))))
(defun ht-dist-node (value extra-bits)
(ldb (byte 16 0)
(logior +ht-len/dist+
(ash value 6)
(ash (aref extra-bits value) 2))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ht-invalid-node () #xffff)
(defun ht-end-node () #x0001)
#-cmucl(declaim (inline ht-max-bits ht-start-bits))
(defstruct (huffman-tree (:conc-name ht-))
(start-bits 0 :type ht-bit-count-type)
(max-bits 0 :type (mod 29))
(nodes (make-array +max-tree-size+
:element-type 'ht-node-type
:initial-element (ht-invalid-node))
:type ht-node-array-type)))
(defmethod make-load-form ((object huffman-tree) &optional environment)
(make-load-form-saving-slots object :environment environment))
(defparameter *fixed-lit/length-table*
(concatenate 'code-table-type
(make-array (1+ (- 143 0)) :initial-element 8)
(make-array (1+ (- 255 144)) :initial-element 9)
(make-array (1+ (- 279 256)) :initial-element 7)
(make-array (1+ (- 287 280)) :initial-element 8)))
(defparameter *fixed-dist-table*
(coerce (make-array 32 :initial-element 5) 'code-table-type))
(defun build-tree-part (tree tree-offset table type start end
scratch
extra-bits)
(declare (type (and fixnum unsigned-byte) tree-offset start end)
(type code-table-type table extra-bits)
(optimize speed))
(assert (typep scratch 'huffman-tree))
;; # of entries of each bit size
(let* ((counts (let ((a (make-array 16 :element-type '(unsigned-byte 11)
:initial-element 0)))
(loop for x from start below end
for i = (aref table x)
do (incf (aref a i)))
(loop for s fixnum = 1 then (ash s 1)
for c across a
for i from 0 below 16
unless (zerop i)
do (if (> c s)
(error "too many entries in huffman table with bit length ~s: ~s/~s." i c s)
(decf s c))
finally (when (and (plusp s)
(< 1 (- (- end start)
(aref a 0))))
(error "incomplete huffman table ~s~%" s)))
(setf (aref a 0) 0)
a))
;; first position of each used bit size
(offsets (let ((c 0))
(declare (type (unsigned-byte 11) c))
(map '(simple-array (unsigned-byte 11) (16))
(lambda (a)
(prog1
(if (zerop a) 0 c)
(incf c a)))
counts)))
;; first code of each used bit size
(code-offsets (let ((c 0))
(declare (type (unsigned-byte 17) c))
(map '(simple-array (unsigned-byte 16) (16))
(lambda (a)
(prog1
(if (zerop a) 0 c)
(setf c (ash (+ c a) 1))))
counts)))
;; range of bit sizes used
(min (position-if-not 'zerop counts))
;; max # of bits needed to read entry + extra bits for this tree
(max-bits (+ (or (position-if-not 'zerop counts :from-end t) 0)
(ecase type
(:dist 13)
(:lit/len 5)
(:dht-len 7))))
;; temp space for sorting table
(terminals scratch))
(declare (type (or null (unsigned-byte 4)) min)
(type (simple-array (unsigned-byte 11) (16)) counts)
(dynamic-extent counts offsets code-offsets))
(unless min
(return-from build-tree-part (values 0 0 0)))
;; sort table/allocate codes
(loop with offset-tmp = (copy-seq offsets)
for i fixnum from 0
for to fixnum from start below end
for l = (aref table to)
for nodes of-type (simple-array (unsigned-byte 16) 1)
= (ht-nodes terminals)
for o = (aref offset-tmp l)
for co = (aref code-offsets l)
when (plusp l)
do (incf (aref offset-tmp l))
(cond
((member type '(:dist :dht-len))
(setf (aref nodes o)
(if (<= i 29)
(ht-dist-node i extra-bits)
;; codes above 29 aren't used
(ht-invalid-node))))
((> i +lengths-end+)
(setf (aref nodes o) (ht-invalid-node)))
((>= i +lengths-start+)
(setf (aref nodes o) (ht-len-node i extra-bits)))
((= i +end-code+)
(setf (aref nodes o) (ht-end-node)))
(t
(setf (aref nodes o) (ht-literal-node i)))))
;; fill tree:
(let ((next-subtable tree-offset))
(declare (type (unsigned-byte 12) next-subtable))
(labels ((next-len (l)
(position-if #'plusp counts :start l))
(subtable (prefix prefix-bits)
(declare (ignorable prefix))
(or
(loop for entry-bits = (if (zerop (aref counts prefix-bits))
(next-len prefix-bits)
prefix-bits)
while entry-bits
if (= prefix-bits entry-bits)
return (prog1 (aref (ht-nodes terminals)
(aref offsets entry-bits))
(incf (aref offsets entry-bits))
(decf (aref counts entry-bits)))
else
return (let ((start next-subtable)
(b (- entry-bits prefix-bits)))
(declare (type (unsigned-byte 16) b))
(incf next-subtable (expt 2 b))
(loop for i below (expt 2 b)
do (setf (aref (ht-nodes tree)
(+ start (bit-rev i b)))
(subtable i entry-bits)))
(values (ht-link-node b start))))
(ht-invalid-node))))
(incf next-subtable (expt 2 min))
(loop for i below (expt 2 min)
do (setf (aref (ht-nodes tree)
(+ tree-offset (bit-rev i min)))
(subtable i min))))
(values next-subtable min max-bits))))
#++
(defun build-tree (tree lit/len dist)
(declare (optimize speed)
(type code-table-type lit/len dist))
(multiple-value-bind (count bits)
(build-tree-part tree 0 lit/len :lit/len 0 (length lit/len)
(make-huffman-tree)
+extra-bits+)
(setf (ht-len-start-bits tree) bits)
(setf (ht-dist-offset tree) count)
(setf (ht-dist-start-bits tree)
(nth-value 1 (build-tree-part tree count dist :dist
0 (length dist)
(make-huffman-tree)
+extra-bits+)))))
#++
(defun build-tree* (tree lit/len/dist mid end scratch)
(declare (optimize speed)
(type (vector (unsigned-byte 4)) lit/len/dist)
(type (and unsigned-byte fixnum) mid))
(multiple-value-bind (count bits)
(build-tree-part tree 0 lit/len/dist :lit/len 0 mid scratch +extra-bits+)
(setf (ht-len-start-bits tree) bits)
(setf (ht-dist-offset tree) count)
(setf (ht-dist-start-bits tree)
(nth-value 1 (build-tree-part tree count
lit/len/dist :dist
mid end
scratch
+extra-bits+)))
#++(dump-tree tree)))
(defun build-trees (ltree dtree lit/len dist)
(declare (optimize speed)
(type code-table-type lit/len dist))
(multiple-value-bind (count bits max)
(build-tree-part ltree 0 lit/len :lit/len 0 (length lit/len)
(make-huffman-tree) +extra-bits+)
(declare (ignore count))
(setf (ht-start-bits ltree) bits)
(setf (ht-max-bits ltree) max)
(multiple-value-bind (count bits max)
(build-tree-part dtree 0 dist :dist 0 (length dist)
(make-huffman-tree)
+extra-bits+)
(declare (ignore count))
(setf (ht-start-bits dtree) bits)
(setf (ht-max-bits dtree) max))
#++(dump-tree tree)))
(defun build-trees* (ltree dtree lit/len/dist mid end scratch)
(declare (optimize speed)
(type (vector (unsigned-byte 4)) lit/len/dist)
(type (and unsigned-byte fixnum) mid))
(multiple-value-bind (count bits max)
(build-tree-part ltree 0 lit/len/dist :lit/len 0 mid scratch +extra-bits+)
(declare (ignore count))
(setf (ht-start-bits ltree) bits)
(setf (ht-max-bits ltree) max)
(multiple-value-bind (count bits max)
(build-tree-part dtree 0 lit/len/dist :dist mid end
scratch +extra-bits+)
(declare (ignore count))
(setf (ht-start-bits dtree) bits)
(setf (ht-max-bits dtree) max))
#++(dump-tree tree)))
#++
(defun dump-tree (tree &key bits base (depth 0))
(cond
((and bits base)
(loop for i below (expt 2 bits)
for node = (aref (ht-nodes tree) (+ i base))
do (format *debug-io* "~a~4,' d: ~a~%"
(make-string depth :initial-element #\~)
i
(ecase (ht-node-type node)
(#.+ht-literal+ (list :literal (ht-value node)))
(#.+ht-link/end+
(if (ht-endp node) :end
(list :link
:bits (ht-link-bits node)
:offset (ht-link-offset node))))
(#.+ht-len/dist+
(let ((v (ht-value node)))
(list :len/dist v
(when (> v +lengths-extra-bits-offset+)
(+ v
+lengths-start+
(- +lengths-extra-bits-offset+)))
:start (aref +len/dist-bases+ v)
:end (+ (aref +len/dist-bases+ v)
(1- (expt 2 (aref +extra-bits+ v)))))))
(#.+ht-invalid+ :invalid)))
(when (and (ht-linkp node)
(not (or (ht-endp node)
(ht-invalidp node))))
(dump-tree tree :bits (ht-link-bits node)
:base (ht-link-offset node)
:depth (+ depth 2)))))
(t
(format *debug-io* "lit/len table:~%")
(dump-tree tree :bits (ht-len-start-bits tree)
:base 0 :depth 1)
(format *debug-io* "distance table:~%")
(when (plusp (ht-dist-start-bits tree))
(dump-tree tree :bits (ht-dist-start-bits tree)
:base (ht-dist-offset tree)
:depth 1)))))

69
quicklisp/dists/quicklisp/software/3bz-20201220-git/io-common.lisp Normal file
View file

@ -0,0 +1,69 @@
(in-package #:3bz)
(deftype octet () '(unsigned-byte 8))
(deftype octet-vector () '(simple-array octet (*)))
;; typed container for offsets and bounds of current input source, and
;; remaining bits of partially read octets
(defstruct (context-boxes (:conc-name cb-))
;; start of 'active' region of buffer
(start 0 :type size-t)
;; end of 'active' region of buffer
(end 0 :type size-t)
;; offset of next unread byte, (<= start offset end)
(offset 0 :type size-t))
(defmacro context-common ((boxes) &body body)
`(macrolet ((pos ()
`(cb-offset ,',boxes))
(end ()
`(cb-end ,',boxes))
(%octet (read-form
&optional (eob-form
'(error "read past end of buffer")))
`(progn
(when (>= (pos) (end))
,eob-form)
(prog1
,read-form
(incf (pos)))))
(octets-left ()
`(- (cb-end ,',boxes) (pos))))
,@body))
(defclass octet-vector-context ()
((octet-vector :reader octet-vector :initarg :octet-vector)
(boxes :reader boxes :initarg :boxes)))
(defun make-octet-vector-context (vector &key (start 0) (offset start)
(end (length vector)))
(make-instance 'octet-vector-context
:octet-vector vector
:boxes (make-context-boxes
:start start :offset offset :end end)))
(defclass octet-stream-context ()
((octet-stream :reader octet-stream :initarg :octet-stream)
(boxes :reader boxes :initarg :boxes)))
(defun make-octet-stream-context (file-stream &key (start 0) (offset 0)
(end (file-length file-stream)))
(make-instance 'octet-stream-context
:octet-stream file-stream
:boxes (make-context-boxes
:start start :offset offset :end end)))
;; hack to allow storing parts of a file to use as context later. call
;; before using context
(defmethod %resync-file-stream (context))
(defmethod %resync-file-stream ((context octet-stream-context))
(file-position (octet-stream context)
(cb-offset (boxes context))))
(defun valid-octet-stream (os)
(and (typep os 'stream)
(subtypep (stream-element-type os) 'octet)
(open-stream-p os)
(input-stream-p os)))

115
quicklisp/dists/quicklisp/software/3bz-20201220-git/io-mmap.lisp Normal file
View file

@ -0,0 +1,115 @@
(in-package #:3bz)
;; we restrict size of these types a bit more on 64 bit platforms to
;; ensure intermediate results stay in reasonable range for
;; performance. 32bit probably needs tuned, might want to allow larger
;; than fixnum offsets for FFI use with implementations with small
;; fixnums?
(deftype size-t () (if (= 8 (cffi:foreign-type-size :pointer))
`(unsigned-byte
,(min 60 (1- (integer-length most-positive-fixnum))))
`(unsigned-byte
,(min 30 (integer-length most-positive-fixnum)))))
;; slightly larger so incrementing a size-t still fits
(deftype offset-t () (if (= 8 (cffi:foreign-type-size :pointer))
`(unsigned-byte
,(min 61 (integer-length most-positive-fixnum)))
`(unsigned-byte
,(min 31 (integer-length most-positive-fixnum)))))
(defclass octet-pointer ()
((base :reader base :initarg :base)
(size :reader size :initarg :size) ;; end?
(scope :reader scope :initarg :scope)))
(defmacro with-octet-pointer ((var pointer size) &body body)
(with-gensyms (scope)
(once-only (pointer size)
`(let* ((,scope (cons t ',var)))
(unwind-protect
(let ((,var (make-instance 'octet-pointer :base ,pointer
:size ,size
:scope ,scope)))
,@body)
(setf (car ,scope) nil))))))
(defun valid-octet-pointer (op)
(and (car (scope op))
(not (cffi:null-pointer-p (base op)))
(plusp (size op))))
(defclass octet-pointer-context ()
((op :reader op :initarg :op)
(pointer :reader %pointer :initarg :pointer)
(boxes :reader boxes :initarg :boxes)))
(defun make-octet-pointer-context (octet-pointer
&key (start 0) (offset 0)
(end (size octet-pointer)))
(make-instance 'octet-pointer-context
:op octet-pointer
:pointer (base octet-pointer)
:boxes (make-context-boxes
:start start :offset offset :end end)))
(defmacro with-pointer-context ((context) &body body)
(with-gensyms (boxes pointer)
(once-only (context)
`(let* ((,boxes (boxes ,context))
(,pointer (base (op ,context))))
(declare (optimize speed)
(ignorable ,pointer ,boxes)
(type context-boxes ,boxes))
(assert (valid-octet-pointer (op ,context)))
(context-common (,boxes)
(macrolet ((word64 ()
(with-gensyms (available result)
`(let ((,available (octets-left)))
(if (>= ,available 8)
(let ((,result (cffi:mem-ref
,',pointer :uint64 (pos))))
(incf (pos) 8)
(values ,result 8))
(let ((,result 0))
(declare (type (unsigned-byte 64) ,result))
(loop
for i fixnum below (min 8 ,available)
do (setf ,result
(ldb (byte 64 0)
(logior
,result
(ash
(cffi:mem-ref
,',pointer
:uint8
(+ (pos) i))
(* i 8))))))
(incf (pos) ,available)
(values ,result ,available))))))
(word32 ()
(with-gensyms (available result)
`(let ((,available (octets-left)))
(if (>= ,available 4)
(let ((,result (cffi:mem-ref
,',pointer :uint32 (pos))))
(incf (pos) 4)
(values ,result 4))
(let ((,result 0))
(declare (type (unsigned-byte 32) ,result))
(loop
for i of-type (unsigned-byte 2) below (min 4 ,available)
do (setf ,result
(ldb (byte 32 0)
(logior
,result
(ash
(cffi:mem-ref
,',pointer
:uint8
(+ (pos) i))
(* i 8))))))
(incf (pos) ,available)
(values ,result ,available)))))))
,@body))))))

20
quicklisp/dists/quicklisp/software/3bz-20201220-git/io-nommap.lisp Normal file
View file

@ -0,0 +1,20 @@
(in-package #:3bz)
;;; stubs of mmap/pointer routines to allow compilation on mezzano/abcl
#- (or abcl mezzano)
(error "this code assume mezzano/abcl, patches welcome if some other OS needs it")
;; we restrict size of these types a bit more on 64 bit platforms to
;; ensure intermediate results stay in reasonable range for
;; performance.
(deftype size-t () `(unsigned-byte
,(min 60 (1- (integer-length most-positive-fixnum)))))
;; slightly larger so incrementing a size-t still fits
(deftype offset-t () `(unsigned-byte
,(min 61 (integer-length most-positive-fixnum))))
(defclass octet-pointer-context ()
())
(defmacro with-pointer-context ((context) &body body)
(declare (ignore context body))
`(error "pointer contexts not supported on this platform"))

141
quicklisp/dists/quicklisp/software/3bz-20201220-git/io.lisp Normal file
View file

@ -0,0 +1,141 @@
(in-package #:3bz)
(defmacro with-vector-context ((context) &body body)
(with-gensyms (boxes vector)
(once-only (context)
`(let* ((,boxes (boxes ,context))
(,vector (octet-vector ,context)))
(declare (optimize speed)
(ignorable ,vector ,boxes)
(type context-boxes ,boxes))
(check-type ,vector octet-vector)
(locally (declare (type octet-vector ,vector))
(context-common (,boxes)
(macrolet (;; read up to 8 octets in LE order, return
;; result + # of octets read as multiple
;; values
(word64 ()
(with-gensyms (available result)
`(let ((,available (octets-left)))
(if (>= ,available 8)
(let ((,result (ub64ref/le
,',vector (pos))))
(incf (pos) 8)
(values ,result 8))
(let ((,result 0))
(loop
for i fixnum below ,available
do (setf ,result
(ldb (byte 64 0)
(logior
,result
(ash
(aref ,',vector
(+ (pos) i))
(* i 8))))))
(incf (pos) ,available)
(values ,result ,available))))))
(word32 ()
(with-gensyms (available result)
`(let ((,available (octets-left)))
(if (>= ,available 4)
(let ((,result (ub32ref/le
,',vector (pos))))
(incf (pos) 4)
(values ,result 4))
(let ((,result 0))
(loop
for i of-type (unsigned-byte 2) below (min 4 ,available)
do (setf ,result
(ldb (byte 32 0)
(logior
,result
(ash
(aref ,',vector
(+ (pos) i))
(* i 8))))))
(incf (pos) ,available)
(values ,result ,available)))))))
,@body)))))))
(defmacro with-stream-context ((context) &body body)
(with-gensyms (boxes stream)
(once-only (context)
`(let* ((,boxes (boxes ,context))
(,stream (octet-stream ,context)))
(declare (optimize speed)
(ignorable ,stream ,boxes)
(type context-boxes ,boxes))
(assert (valid-octet-stream ,stream))
(context-common (,boxes)
(macrolet (;; override POS/SET-POS for streams
(pos ()
`(file-position ,',stream))
(word64 ()
(with-gensyms (available result)
`(locally (declare (optimize (speed 1)))
(let ((,available (- (end) (pos))))
(if (>= ,available 8)
(values (nibbles:read-ub64/le ,',stream) 8)
(let ((,result 0))
(declare (type (unsigned-byte 64) ,result)
(type (mod 8) ,available))
(loop
for i fixnum below (min 8 ,available)
do (setf (ldb (byte 8 (* i 8))
,result)
(read-byte ,',stream)))
(values ,result ,available)))))))
(word32 ()
(with-gensyms (available result)
`(locally (declare (optimize (speed 1)))
(let ((,available (- (end) (pos))))
(if (>= ,available 4)
(values (nibbles:read-ub32/le ,',stream) 4)
(let ((,result 0))
(declare (type (unsigned-byte 64) ,result)
(type (mod 4) ,available))
(loop
for i fixnum below (min 4 ,available)
do (setf (ldb (byte 8 (* i 8))
,result)
(read-byte ,',stream)))
(values ,result ,available))))))))
,@body))))))
(defmacro defun-with-reader-contexts (base-name lambda-list (in) &body body)
`(progn
,@(with-standard-io-syntax
(loop for cc in '(vector stream pointer)
for w = (find-symbol (format nil "~a-~a-~a" 'with cc 'context)
(find-package :3bz))
for n = (intern (format nil "~a/~a" base-name cc)
(find-package :3bz))
collect `(defun ,n ,lambda-list
(,w (,in)
(let ()
,@body)))))
(defun ,base-name ,lambda-list
(etypecase ,in
,@(with-standard-io-syntax
(loop for cc in '(vector stream pointer)
for ct = (find-symbol (format nil "~a-~a-~a" 'octet cc 'context)
(find-package :3bz))
for n = (find-symbol (format nil "~a/~a" base-name cc)
(find-package :3bz))
collect `(,ct (,n ,@lambda-list))))))))
(defmacro with-reader-contexts ((context) &body body)
`(etypecase ,context
(octet-vector-context
(with-vector-context (,context)
,@body))
(octet-pointer-context
(with-pointer-context (,context)
,@body))
(octet-stream-context
(with-stream-context (,context)
,@body))))

28
quicklisp/dists/quicklisp/software/3bz-20201220-git/package.lisp Normal file
View file

@ -0,0 +1,28 @@
(defpackage 3bz
(:use :cl)
(:import-from :alexandria
#:with-gensyms
#:once-only
#:ensure-list)
(:import-from #+mezzano #:mezzano.internals
#-mezzano #:nibbles
#:ub16ref/le
#:ub32ref/le
#:ub64ref/le)
(:export
#:decompress
#:decompress-vector
#:with-octet-pointer
#:make-octet-vector-context
#:make-octet-stream-context
#:make-octet-pointer-context
#:make-deflate-state
#:make-zlib-state
#:make-gzip-state
#:finished
#:input-underrun
#:output-overflow
#:%resync-file-stream
#:replace-output-buffer))

89
quicklisp/dists/quicklisp/software/3bz-20201220-git/test-chunked-input.lisp Normal file
View file

@ -0,0 +1,89 @@
(in-package 3bz)
#++
(ql:quickload '(deoxybyte-gzip))
#++
(let ((*default-pathname-defaults* (asdf:system-relative-pathname '3bz "")))
(with-open-file (o "test.deflated" :element-type 'octet :direction :output
:if-does-not-exist :create :if-exists :error)
(let* ((i (alexandria:read-file-into-byte-vector "deflate.lisp"))
(tmp (make-array (length i) :element-type 'octet
:initial-element 0)))
(multiple-value-bind (x r w)
(gz:deflate-vector i
tmp :compression 9
:suppress-header t)
(declare (ignore r))
(nibbles:write-ub64/le (length i) o)
(write-sequence (subseq x 0 w) o)))))
(defparameter *test-file*
(let ((f (alexandria:read-file-into-byte-vector (asdf:system-relative-pathname '3bz "test.deflated"))))
(list (nibbles:ub64ref/le f 0)
(subseq f 8))))
(defun test-chunked (decompressed-size vector generator)
(let* ((l (length vector))
(o 0)
(tmp (make-array decompressed-size :element-type 'octet
:initial-element 0))
(state (make-deflate-state :output-buffer tmp)))
(loop for end = (min l (+ o (funcall generator)))
for s = (unless (= o l)
(subseq vector o end))
for c = (make-instance 'octet-vector-context
:octet-vector s
:boxes (make-context-boxes :end (length s)))
while s
do (decompress c state)
(assert (or (ds-finished state)
(ds-input-underrun state)))
(setf o end))
tmp))
(equalp
(gz:inflate-vector (second *test-file*)
(make-array (first *test-file*)
:element-type 'octet)
:suppress-header t)
(test-chunked (first *test-file*) (second *test-file*)
(constantly 3)))
(defparameter *foo* nil)
(defparameter *c* 0)
(let ((ref (gz:inflate-vector (second *test-file*)
(make-array (first *test-file*)
:element-type 'octet)
:suppress-header t)))
(loop
for i from 0
repeat 30000
do (print i)
while
(progn
(setf *foo* nil)
(incf *c*)
(equalp
ref
(test-chunked (first *test-file*) (second *test-file*)
(lambda ()
(let ((r (random 1234)))
(push r *foo*)
r)))))
count t))
(let ((*default-pathname-defaults* (asdf:system-relative-pathname '3bz "")))
(let* ((i (alexandria:read-file-into-byte-vector "deflate.lisp"))
(tmp (make-array (* 2 (length i)) :element-type 'octet
:initial-element 0)))
(multiple-value-bind (x r w)
(gz:deflate-vector i
tmp :compression 0
:suppress-header t)
(declare (ignore r))
(mismatch i
(test-chunked (length i) (subseq x 0 w) (constantly 1323134)
#++(lambda () (random 4)))))))

90
quicklisp/dists/quicklisp/software/3bz-20201220-git/test-chunked-output.lisp Normal file
View file

@ -0,0 +1,90 @@
(in-package 3bz)
#++
(ql:quickload '(deoxybyte-gzip))
#++
(let ((*default-pathname-defaults* (asdf:system-relative-pathname '3bz "")))
(with-open-file (o "test.deflated" :element-type 'octet :direction :output
:if-does-not-exist :create :if-exists :error)
(let* ((i (alexandria:read-file-into-byte-vector "deflate.lisp"))
(tmp (make-array (length i) :element-type 'octet
:initial-element 0)))
(multiple-value-bind (x r w)
(gz:deflate-vector i
tmp :compression 9
:suppress-header t)
(declare (ignore r))
(nibbles:write-ub64/le (length i) o)
(write-sequence (subseq x 0 w) o)))))
(defparameter *test-file*
(let ((f (alexandria:read-file-into-byte-vector (asdf:system-relative-pathname '3bz "test.deflated"))))
(list (nibbles:ub64ref/le f 0)
(subseq f 8))))
(defun test-chunked-output (vector generator)
(let* ((l (length vector))
(state (make-deflate-state))
(c (make-instance 'octet-vector-context
:octet-vector vector
:boxes (make-context-boxes :end l))))
(setf (ds-output-buffer state)
(make-array (funcall generator)
:element-type 'octet :initial-element 0))
(setf (ds-output-offset state) 0)
(coerce
(loop
for x = (decompress c state)
#+do (format t "~s ~s~%" ss (subseq (ds-output-buffer state) 0 x))
sum x into ss
when (or (ds-finished state)
(ds-output-overflow state))
append (coerce (subseq (ds-output-buffer state) 0 x) 'list)
and
do (setf (ds-output-buffer state)
(make-array (funcall generator) :element-type 'octet
:initial-element 0))
(Setf (ds-output-offset state) 0)
until (ds-finished state))
'vector)))
(let* ((a (gz:inflate-vector (second *test-file*)
(make-array (first *test-file*)
:element-type 'octet)
:suppress-header t))
(b (test-chunked-output (second *test-file*)
(constantly 3)))
(c (mismatch a b)))
(when c
(list c
(subseq a c (length a))
(subseq b c (length b))
c)))
(defparameter *foo* nil)
(defparameter *c* 0)
(let ((ref (gz:inflate-vector (second *test-file*)
(make-array (first *test-file*)
:element-type 'octet)
:suppress-header t)))
(loop
for i from 0
repeat 30000
do (princ i) (terpri)
while
(progn
(setf *foo* nil)
(incf *c*)
(equalp
ref
(test-chunked-output (second *test-file*)
(lambda ()
(let ((r (+ 1 (random 12345))))
(push r *foo*)
r)))))
count t))

BIN
quicklisp/dists/quicklisp/software/3bz-20201220-git/test.deflated Normal file
View file

Binary file not shown.

42
quicklisp/dists/quicklisp/software/3bz-20201220-git/tuning.lisp Normal file
View file

@ -0,0 +1,42 @@
(in-package 3bz)
;;; some tuning parameters, and functions used in #+#.(...) to control
;;; features used by code
;;; deflate code tries to read/write/copy 64bits at a time, and uses
;;; ub64 buffer for bits when doing non-octet-unaligned reads, but
;;; that's slow if ub64 is a bignum, so this is used to switch to ub32
;;; where possible
(defun use-ub64 ()
'(:or)
;; on mezzano, ub64 is better on some files, worse on others, so leaving off for now
#+ (or (and 64-bit sbcl))
'(:and))
;;; similarly, adler32 checksum accumulates as many bytes as possible
;;; before doing mod, so we can either use :ub64, :ub32 or :fixnum
;;; versions of adler32 code depending on which is fastest
(defun use-adler32 (version)
(if (eql version
;; ub64 is fastest on 64bit sbcl, and seems better on mezzano too now
#+ (or mezzano (and sbcl x86-64))
:ub64
;; for now, just using fixnum elsewhere until there are
;; proper benchmarks. not sure if ub32 is faster than
;; fixnum anywhere, or if fixnum is good enough
#- (or mezzano abcl (and sbcl x86-64))
:fixnum
#+ abcl
:ub32
)
'(:and)
'(:or)))
;;; adler32 checksum is unrolled a bit to reduce loop overhead, this
;;; specifies how many iterations to unroll
;; todo: set this for more combinations of cpu/implementation once
;; there are benchmarks
(defconstant +adler32-unroll+
#+mezzano 16
#+sbcl 32
#- (or sbcl mezzano) 8)

16
quicklisp/dists/quicklisp/software/3bz-20201220-git/types.lisp Normal file
View file

@ -0,0 +1,16 @@
(in-package 3bz)
(deftype ub8 () '(unsigned-byte 8))
(deftype ub16 () '(unsigned-byte 16))
(deftype ub32 () '(unsigned-byte 32))
(deftype ub64 () '(unsigned-byte 64))
(deftype ht-bit-count-type ()'(unsigned-byte 4))
(deftype ht-offset-type ()'(unsigned-byte 11))
(deftype ht-node-type ()'(unsigned-byte 16))
(deftype ht-node-array-type () `(simple-array ht-node-type (,+max-tree-size+)))
(deftype code-table-type () '(simple-array (unsigned-byte 4) 1))
;; mezzano likes (integer 0 m-p-f) better than (and fixnum unsigned-byte)
(deftype non-negative-fixnum () `(integer 0 ,most-positive-fixnum))

89
quicklisp/dists/quicklisp/software/3bz-20201220-git/util.lisp Normal file
View file

@ -0,0 +1,89 @@
(in-package 3bz)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *cached-struct-defs* (make-hash-table)))
(defmacro defstruct-cached (name-and-options &body slots)
`(progn
(defstruct ,name-and-options
,@slots)
(eval-when (:compile-toplevel :load-toplevel :execute)
,(with-standard-io-syntax
(destructuring-bind (name &rest options)
(alexandria:ensure-list name-and-options)
(let ((conc-name (cadr (assoc :conc-name options))))
(unless conc-name
(setf conc-name (format nil "~a" name)))
(flet ((accessor (slot)
(intern (format nil "~a~a" conc-name slot)
(find-package :3bz))))
`(setf (gethash ',NAME *cached-struct-defs*)
',(loop for (slot init . keys) in slots
for type = (getf keys :type)
collect (list slot (accessor slot) type))))))))))
(defmacro with-cached-state ((struct type save-state-fun &body vars)
&body body)
(let ((slots (gethash type *cached-struct-defs*)))
(assert slots)
`(symbol-macrolet ,(loop for (var accessor) in slots
unless (member var vars)
collect `(,var (,accessor ,struct)))
(let ,(loop for (var accessor) in slots
when (member var vars)
collect `(,var (,accessor ,struct)))
(declare ,@(loop for (var nil type) in slots
when (and (member var vars) type)
collect `(type ,type ,var)
when (member var vars)
collect `(ignorable ,var)))
(flet ((,save-state-fun ()
,@(loop for (var accessor) in slots
when (member var vars)
collect `(setf (,accessor ,struct) ,var))))
(declare (ignorable #',save-state-fun))
,@body)))))
(defmacro wrap-fixnum (x)
;; a few places we already checked something will be a fixnum (for
;; example an array index in a loop), so tell the compiler it doesn't
;; need to check for bignums
#-mezzano
`(ldb (byte #. (integer-length most-positive-fixnum) 0) ,x)
#+mezzano
`(locally (declare (optimize speed (safety 0)))
(the fixnum ,x)))
(declaim (type (simple-array (unsigned-byte 15) (32768)) *bit-rev-table*))
(defparameter *bit-rev-table*
(coerce (loop for i below (expt 2 15)
collect (parse-integer
(reverse (format nil "~15,'0b" i)) :radix 2))
'(simple-array (unsigned-byte 15) (*))))
(declaim (inline bit-rev))
(defun bit-rev (x bits)
(declare (type (unsigned-byte 15) x))
(ldb (byte bits (- 15 bits)) (aref *bit-rev-table* x)))
;; some wrappers for handling fast math when we know types and ranges
(defmacro ub64+ (a b)
#- (or mezzano sbcl)
`(the (unsigned-byte 64) (+ ,a ,b))
#+mezzano
`(locally (declare (optimize speed (safety 0)))
(the (unsigned-byte 64) (+ ,a ,b)))
#+sbcl
`(ldb (byte 64 0) (+ ,a ,b)))
(defmacro fixnum+ (a b)
#- (or mezzano sbcl)
`(the (fixnum) (+ ,a ,b))
#+mezzano
`(locally (declare (optimize speed (safety 0)))
(the (fixnum) (+ ,a ,b)))
#+sbcl
`(+ ,a ,b))

41
quicklisp/dists/quicklisp/software/3bz-20201220-git/zlib-test.lisp Normal file
View file

@ -0,0 +1,41 @@
(in-package 3bz)
#++ (ql:quickload '(3bz deoxybyte-gzip chipz))
(defvar *zlib* nil)
(let* ((d (time
(alexandria:read-file-into-byte-vector "e:/tmp/t/linux-2.2.26.tar")))
(tmp (make-array (length d) :element-type 'octet
:initial-element 0))
(v (or *zlib*
(setf *zlib*
(time
(multiple-value-bind (x r w)
(gz:deflate-vector d (make-array (* 2 (length d))
:element-type 'octet)
:compression 9
)
(declare (ignore r))
(subseq x 0 w)))))))
(format t "chipz:~%")
(fill tmp 0)
(with-simple-restart (continue "continue")
(let ((x (time (chipz:decompress tmp 'chipz:zlib v))))
(declare (ignore x))
(assert (equalp d tmp))))
(fill tmp 0)
(format t "3bz:~%") ;; 0.33
(let ((x (time (decompress-zlib (make-instance 'octet-vector-context
:octet-vector v
:boxes (make-context-boxes
:end (length v)))
(make-zlib-state :output-buffer tmp)))))
(assert (equalp (if (consp x)
(time (apply 'concatenate 'octet-vector x))
(subseq tmp 0 x))
d)))
(fill tmp 0)
(format t "gz:~%")
(let ((x (time (gz:inflate-vector v tmp))))
(assert (equalp x d)))
nil)

144
quicklisp/dists/quicklisp/software/3bz-20201220-git/zlib.lisp Normal file
View file

@ -0,0 +1,144 @@
(in-package 3bz)
(defstruct (zlib-state (:conc-name zs-)
(:include deflate-state))
(zlib-state :header)
(compression-method nil)
(window-size 0)
(dict-id nil)
(compression-level :default)
;; checksum state
(s1 1 :type (unsigned-byte 16))
(s2 0 :type (unsigned-byte 16)))
(defun check-zlib-header (cmf flg &key (errorp t))
(let* ((cm (ldb (byte 4 0) cmf))
(cinfo (ldb (byte 4 4) cmf))
(check (zerop (mod (+ (* cmf 256) flg) 31)))
(dict (logbitp 5 flg))
(level (ldb (byte 2 6) flg)))
(when (not check)
(when errorp
(error "invalid zlib header checksum")))
(if (= cm 8)
(setf cm :deflate)
(progn
(when errorp
(error "invalid zlib compression type"))
(setf check nil)))
(when (> cinfo 7)
(when errorp
(error "invalid window size in zlib header"))
(setf check nil))
(when dict
(when errorp
(error "preset dictionary not supported yet"))
(setf check nil))
(values check cm cinfo dict level)))
(defun decompress-zlib (read-context state)
(check-type state zlib-state)
;; fixme: avoid duplication with these from deflate
(with-reader-contexts (read-context)
(with-accessors ((input-underrun zs-input-underrun)
(zlib-state zs-zlib-state)
(partial-bits zs-partial-bits)
(bits-remaining zs-bits-remaining)
(finished zs-finished)
(window-size zs-window-size)
(compression-level zs-compression-level)
(dict-id zs-dict-id)
(compression-method zs-compression-method)
(output-offset zs-output-offset)
(output-overflow zs-output-overflow))
state
(labels ((%fill-bits32 (n)
(multiple-value-bind (input octets)
(word32)
(declare (type (mod 5) octets))
(setf partial-bits
(logior
(ash (ldb (byte 32 0) input)
(min 32 bits-remaining))
partial-bits))
(incf bits-remaining (* 8 octets))
(>= bits-remaining n)))
(%bits (n)
(prog1 (ldb (byte n 0) partial-bits)
(setf partial-bits (ash partial-bits (- n)))
(decf bits-remaining n)))
(byte-align ()
(let ((r (mod bits-remaining 8)))
(unless (zerop r)
(setf partial-bits (ash partial-bits (- r)))
(decf bits-remaining r))))
;; these are called from 2 places to allow finishing in
;; single call, while trying to minimize conditionals
;; in hot path when working with input/output in chunks
(dictid ()
(error "preset dictionary not supported yet"))
(adler ()
(when (and (< bits-remaining 32)
(not (%fill-bits32 32)))
(setf input-underrun t)
(return-from decompress-zlib
output-offset))
(let ((adler32 (logior (ash (%bits 8) 24)
(ash (%bits 8) 16)
(ash (%bits 8) 8)
(ash (%bits 8) 0)))
(calculated (logior (zs-s1 state)
(ash (zs-s2 state) 16))))
(declare (optimize (speed 1)))
;;(format t "checksum = ~8,'0x~%" adler32)
;;(format t "calculated = ~8,'0x~%" calculated)
(assert (= adler32 calculated))
(setf finished t)))
(update-checksum ()
(declare (optimize speed))
(setf (values (zs-s1 state) (zs-s2 state))
(adler32 (zs-output-buffer state)
output-offset
(zs-s1 state) (zs-s2 state)))))
(declare (inline %fill-bits32 %bits byte-align)
(optimize (speed 1)))
(setf input-underrun nil)
(when zlib-state
(case zlib-state
(:header
(when (and (< bits-remaining 16)
(not (%fill-bits32 16)))
(setf input-underrun t)
(return-from decompress-zlib 0))
(multiple-value-bind (ok cm cinfo dict level)
(check-zlib-header (%bits 8) (%bits 8))
(declare (ignore ok))
(setf compression-level
(aref #(:fastest :fast :default :maximum) level))
(setf window-size (expt 2 (+ cinfo 8)))2
(setf compression-method cm)
(setf dict-id dict)
(when dict
(setf zlib-state :header2)
(dictid))
#++
(format t "zlib header: method ~s, level ~s, window ~s, dict ~s~%"
compression-method compression-level window-size dict-id)))
(:header2
(dictid))
(:adler
(adler)
(setf zlib-state nil)
(return-from decompress-zlib output-offset)))
(setf zlib-state nil))
(unless zlib-state
(decompress-deflate read-context state)
(when (or finished output-overflow)
(update-checksum))
(when finished
(byte-align)
(setf zlib-state :adler)
(setf finished nil)))
(when (eql :adler zlib-state)
(adler))
output-offset))))

9
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/.dir-locals.el Normal file
View file

@ -0,0 +1,9 @@
;;; Directory Local Variables
;;; For more information see (info "(emacs) Directory Variables")
((nil
(indent-tabs-mode)
(fill-column . 69))
(lisp-mode
(eval put 'test-ps-js 'common-lisp-indent-function 1)
(eval put 'test-js-eval 'common-lisp-indent-function 1)))

3
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
*.*fsl
*.*fasl
*~

31
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/COPYING Normal file
View file

@ -0,0 +1,31 @@
Copyright (c) 2005 Manuel Odendahl <manuel@bl0rg.net>
Copyright (c) 2005-2006 Edward Marco Baringer <mb@bese.it>
Copyright (c) 2007-2013, 2018 Vladimir Sedach <vas@oneofus.la>
Copyright (c) 2008, 2009 Travis Cross <tc@travislists.com>
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. 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.
3. Neither the name of the copyright holder 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.

56
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/README Normal file
View file

@ -0,0 +1,56 @@
Parenscript is a translator from an extended subset of Common Lisp to
JavaScript. Parenscript code can run almost identically on both the
browser (as JavaScript) and server (as Common Lisp).
Parenscript code is treated the same way as Common Lisp code, making
the full power of Lisp macros available for JavaScript. This provides
a web development environment that is unmatched in its ability to
reduce code duplication and provide advanced meta-programming
facilities to web developers.
At the same time, Parenscript is different from almost all other
"language X" to JavaScript translators in that it imposes almost no
overhead:
No run-time dependencies:
Any piece of Parenscript code is runnable as-is. There are no
JavaScript files to include.
Native types:
Parenscript works entirely with native JavaScript data types. There
are no new types introduced, and object prototypes are not
touched.
Native calling convention:
Any JavaScript code can be called without the need for
bindings. Likewise, Parenscript can be used to make efficient,
self-contained JavaScript libraries.
Readable code:
Parenscript generates concise, formatted, idiomatic JavaScript
code. Identifier names are preserved. This enables seamless
use of JavaScript debuggers.
Efficiency:
Parenscript introduces minimal overhead for advanced Common Lisp
features. The generated code is almost as fast as hand-written
JavaScript.
Parenscript is available via Quicklisp:
(ql:quickload :parenscript)
To run unit tests:
(ql:quickload :parenscript.tests)
(parenscript.tests:run-tests)
Contributing:
Please send patches and bug reports to the mailing list:
parenscript-devel@common-lisp.net
Documentation:
See docs/tutorial.html and docs/reference.html
Mailing list:
parenscript-devel@common-lisp.net
https://mailman.common-lisp.net/listinfo/parenscript-devel
Web site:
http://common-lisp.net/project/parenscript/
Source repository:
https://gitlab.common-lisp.net/parenscript/parenscript.git
License:
BSD-3-Clause, see the file COPYING

22
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/contributors Normal file
View file

@ -0,0 +1,22 @@
This is a list of people who have contributed to the ParenScript
project. Please contact the maintainer if you see any errors or
omissions.
Manuel Odendahl
Marco Baringer
Ivan Toshkov
Luca Capello
Alan Shields
Henrik Hjelte
Attila Lendvai
Marijn Haverbeke
Vladimir Sedach
John Fremlin
Red Daly
Travis Cross
Daniel Gackle
William Halliburton
Scott Bell
Bart Botta
Boris Smilga
Russell Sim

451
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/docs/LICENSE Normal file
View file

@ -0,0 +1,451 @@
GNU Free Documentation License
Version 1.3, 3 November 2008
Copyright (C) 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc.
<https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
0. PREAMBLE
The purpose of this License is to make a manual, textbook, or other
functional and useful document "free" in the sense of freedom: to
assure everyone the effective freedom to copy and redistribute it,
with or without modifying it, either commercially or noncommercially.
Secondarily, this License preserves for the author and publisher a way
to get credit for their work, while not being considered responsible
for modifications made by others.
This License is a kind of "copyleft", which means that derivative
works of the document must themselves be free in the same sense. It
complements the GNU General Public License, which is a copyleft
license designed for free software.
We have designed this License in order to use it for manuals for free
software, because free software needs free documentation: a free
program should come with manuals providing the same freedoms that the
software does. But this License is not limited to software manuals;
it can be used for any textual work, regardless of subject matter or
whether it is published as a printed book. We recommend this License
principally for works whose purpose is instruction or reference.
1. APPLICABILITY AND DEFINITIONS
This License applies to any manual or other work, in any medium, that
contains a notice placed by the copyright holder saying it can be
distributed under the terms of this License. Such a notice grants a
world-wide, royalty-free license, unlimited in duration, to use that
work under the conditions stated herein. The "Document", below,
refers to any such manual or work. Any member of the public is a
licensee, and is addressed as "you". You accept the license if you
copy, modify or distribute the work in a way requiring permission
under copyright law.
A "Modified Version" of the Document means any work containing the
Document or a portion of it, either copied verbatim, or with
modifications and/or translated into another language.
A "Secondary Section" is a named appendix or a front-matter section of
the Document that deals exclusively with the relationship of the
publishers or authors of the Document to the Document's overall
subject (or to related matters) and contains nothing that could fall
directly within that overall subject. (Thus, if the Document is in
part a textbook of mathematics, a Secondary Section may not explain
any mathematics.) The relationship could be a matter of historical
connection with the subject or with related matters, or of legal,
commercial, philosophical, ethical or political position regarding
them.
The "Invariant Sections" are certain Secondary Sections whose titles
are designated, as being those of Invariant Sections, in the notice
that says that the Document is released under this License. If a
section does not fit the above definition of Secondary then it is not
allowed to be designated as Invariant. The Document may contain zero
Invariant Sections. If the Document does not identify any Invariant
Sections then there are none.
The "Cover Texts" are certain short passages of text that are listed,
as Front-Cover Texts or Back-Cover Texts, in the notice that says that
the Document is released under this License. A Front-Cover Text may
be at most 5 words, and a Back-Cover Text may be at most 25 words.
A "Transparent" copy of the Document means a machine-readable copy,
represented in a format whose specification is available to the
general public, that is suitable for revising the document
straightforwardly with generic text editors or (for images composed of
pixels) generic paint programs or (for drawings) some widely available
drawing editor, and that is suitable for input to text formatters or
for automatic translation to a variety of formats suitable for input
to text formatters. A copy made in an otherwise Transparent file
format whose markup, or absence of markup, has been arranged to thwart
or discourage subsequent modification by readers is not Transparent.
An image format is not Transparent if used for any substantial amount
of text. A copy that is not "Transparent" is called "Opaque".
Examples of suitable formats for Transparent copies include plain
ASCII without markup, Texinfo input format, LaTeX input format, SGML
or XML using a publicly available DTD, and standard-conforming simple
HTML, PostScript or PDF designed for human modification. Examples of
transparent image formats include PNG, XCF and JPG. Opaque formats
include proprietary formats that can be read and edited only by
proprietary word processors, SGML or XML for which the DTD and/or
processing tools are not generally available, and the
machine-generated HTML, PostScript or PDF produced by some word
processors for output purposes only.
The "Title Page" means, for a printed book, the title page itself,
plus such following pages as are needed to hold, legibly, the material
this License requires to appear in the title page. For works in
formats which do not have any title page as such, "Title Page" means
the text near the most prominent appearance of the work's title,
preceding the beginning of the body of the text.
The "publisher" means any person or entity that distributes copies of
the Document to the public.
A section "Entitled XYZ" means a named subunit of the Document whose
title either is precisely XYZ or contains XYZ in parentheses following
text that translates XYZ in another language. (Here XYZ stands for a
specific section name mentioned below, such as "Acknowledgements",
"Dedications", "Endorsements", or "History".) To "Preserve the Title"
of such a section when you modify the Document means that it remains a
section "Entitled XYZ" according to this definition.
The Document may include Warranty Disclaimers next to the notice which
states that this License applies to the Document. These Warranty
Disclaimers are considered to be included by reference in this
License, but only as regards disclaiming warranties: any other
implication that these Warranty Disclaimers may have is void and has
no effect on the meaning of this License.
2. VERBATIM COPYING
You may copy and distribute the Document in any medium, either
commercially or noncommercially, provided that this License, the
copyright notices, and the license notice saying this License applies
to the Document are reproduced in all copies, and that you add no
other conditions whatsoever to those of this License. You may not use
technical measures to obstruct or control the reading or further
copying of the copies you make or distribute. However, you may accept
compensation in exchange for copies. If you distribute a large enough
number of copies you must also follow the conditions in section 3.
You may also lend copies, under the same conditions stated above, and
you may publicly display copies.
3. COPYING IN QUANTITY
If you publish printed copies (or copies in media that commonly have
printed covers) of the Document, numbering more than 100, and the
Document's license notice requires Cover Texts, you must enclose the
copies in covers that carry, clearly and legibly, all these Cover
Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
the back cover. Both covers must also clearly and legibly identify
you as the publisher of these copies. The front cover must present
the full title with all words of the title equally prominent and
visible. You may add other material on the covers in addition.
Copying with changes limited to the covers, as long as they preserve
the title of the Document and satisfy these conditions, can be treated
as verbatim copying in other respects.
If the required texts for either cover are too voluminous to fit
legibly, you should put the first ones listed (as many as fit
reasonably) on the actual cover, and continue the rest onto adjacent
pages.
If you publish or distribute Opaque copies of the Document numbering
more than 100, you must either include a machine-readable Transparent
copy along with each Opaque copy, or state in or with each Opaque copy
a computer-network location from which the general network-using
public has access to download using public-standard network protocols
a complete Transparent copy of the Document, free of added material.
If you use the latter option, you must take reasonably prudent steps,
when you begin distribution of Opaque copies in quantity, to ensure
that this Transparent copy will remain thus accessible at the stated
location until at least one year after the last time you distribute an
Opaque copy (directly or through your agents or retailers) of that
edition to the public.
It is requested, but not required, that you contact the authors of the
Document well before redistributing any large number of copies, to
give them a chance to provide you with an updated version of the
Document.
4. MODIFICATIONS
You may copy and distribute a Modified Version of the Document under
the conditions of sections 2 and 3 above, provided that you release
the Modified Version under precisely this License, with the Modified
Version filling the role of the Document, thus licensing distribution
and modification of the Modified Version to whoever possesses a copy
of it. In addition, you must do these things in the Modified Version:
A. Use in the Title Page (and on the covers, if any) a title distinct
from that of the Document, and from those of previous versions
(which should, if there were any, be listed in the History section
of the Document). You may use the same title as a previous version
if the original publisher of that version gives permission.
B. List on the Title Page, as authors, one or more persons or entities
responsible for authorship of the modifications in the Modified
Version, together with at least five of the principal authors of the
Document (all of its principal authors, if it has fewer than five),
unless they release you from this requirement.
C. State on the Title page the name of the publisher of the
Modified Version, as the publisher.
D. Preserve all the copyright notices of the Document.
E. Add an appropriate copyright notice for your modifications
adjacent to the other copyright notices.
F. Include, immediately after the copyright notices, a license notice
giving the public permission to use the Modified Version under the
terms of this License, in the form shown in the Addendum below.
G. Preserve in that license notice the full lists of Invariant Sections
and required Cover Texts given in the Document's license notice.
H. Include an unaltered copy of this License.
I. Preserve the section Entitled "History", Preserve its Title, and add
to it an item stating at least the title, year, new authors, and
publisher of the Modified Version as given on the Title Page. If
there is no section Entitled "History" in the Document, create one
stating the title, year, authors, and publisher of the Document as
given on its Title Page, then add an item describing the Modified
Version as stated in the previous sentence.
J. Preserve the network location, if any, given in the Document for
public access to a Transparent copy of the Document, and likewise
the network locations given in the Document for previous versions
it was based on. These may be placed in the "History" section.
You may omit a network location for a work that was published at
least four years before the Document itself, or if the original
publisher of the version it refers to gives permission.
K. For any section Entitled "Acknowledgements" or "Dedications",
Preserve the Title of the section, and preserve in the section all
the substance and tone of each of the contributor acknowledgements
and/or dedications given therein.
L. Preserve all the Invariant Sections of the Document,
unaltered in their text and in their titles. Section numbers
or the equivalent are not considered part of the section titles.
M. Delete any section Entitled "Endorsements". Such a section
may not be included in the Modified Version.
N. Do not retitle any existing section to be Entitled "Endorsements"
or to conflict in title with any Invariant Section.
O. Preserve any Warranty Disclaimers.
If the Modified Version includes new front-matter sections or
appendices that qualify as Secondary Sections and contain no material
copied from the Document, you may at your option designate some or all
of these sections as invariant. To do this, add their titles to the
list of Invariant Sections in the Modified Version's license notice.
These titles must be distinct from any other section titles.
You may add a section Entitled "Endorsements", provided it contains
nothing but endorsements of your Modified Version by various
parties--for example, statements of peer review or that the text has
been approved by an organization as the authoritative definition of a
standard.
You may add a passage of up to five words as a Front-Cover Text, and a
passage of up to 25 words as a Back-Cover Text, to the end of the list
of Cover Texts in the Modified Version. Only one passage of
Front-Cover Text and one of Back-Cover Text may be added by (or
through arrangements made by) any one entity. If the Document already
includes a cover text for the same cover, previously added by you or
by arrangement made by the same entity you are acting on behalf of,
you may not add another; but you may replace the old one, on explicit
permission from the previous publisher that added the old one.
The author(s) and publisher(s) of the Document do not by this License
give permission to use their names for publicity for or to assert or
imply endorsement of any Modified Version.
5. COMBINING DOCUMENTS
You may combine the Document with other documents released under this
License, under the terms defined in section 4 above for modified
versions, provided that you include in the combination all of the
Invariant Sections of all of the original documents, unmodified, and
list them all as Invariant Sections of your combined work in its
license notice, and that you preserve all their Warranty Disclaimers.
The combined work need only contain one copy of this License, and
multiple identical Invariant Sections may be replaced with a single
copy. If there are multiple Invariant Sections with the same name but
different contents, make the title of each such section unique by
adding at the end of it, in parentheses, the name of the original
author or publisher of that section if known, or else a unique number.
Make the same adjustment to the section titles in the list of
Invariant Sections in the license notice of the combined work.
In the combination, you must combine any sections Entitled "History"
in the various original documents, forming one section Entitled
"History"; likewise combine any sections Entitled "Acknowledgements",
and any sections Entitled "Dedications". You must delete all sections
Entitled "Endorsements".
6. COLLECTIONS OF DOCUMENTS
You may make a collection consisting of the Document and other
documents released under this License, and replace the individual
copies of this License in the various documents with a single copy
that is included in the collection, provided that you follow the rules
of this License for verbatim copying of each of the documents in all
other respects.
You may extract a single document from such a collection, and
distribute it individually under this License, provided you insert a
copy of this License into the extracted document, and follow this
License in all other respects regarding verbatim copying of that
document.
7. AGGREGATION WITH INDEPENDENT WORKS
A compilation of the Document or its derivatives with other separate
and independent documents or works, in or on a volume of a storage or
distribution medium, is called an "aggregate" if the copyright
resulting from the compilation is not used to limit the legal rights
of the compilation's users beyond what the individual works permit.
When the Document is included in an aggregate, this License does not
apply to the other works in the aggregate which are not themselves
derivative works of the Document.
If the Cover Text requirement of section 3 is applicable to these
copies of the Document, then if the Document is less than one half of
the entire aggregate, the Document's Cover Texts may be placed on
covers that bracket the Document within the aggregate, or the
electronic equivalent of covers if the Document is in electronic form.
Otherwise they must appear on printed covers that bracket the whole
aggregate.
8. TRANSLATION
Translation is considered a kind of modification, so you may
distribute translations of the Document under the terms of section 4.
Replacing Invariant Sections with translations requires special
permission from their copyright holders, but you may include
translations of some or all Invariant Sections in addition to the
original versions of these Invariant Sections. You may include a
translation of this License, and all the license notices in the
Document, and any Warranty Disclaimers, provided that you also include
the original English version of this License and the original versions
of those notices and disclaimers. In case of a disagreement between
the translation and the original version of this License or a notice
or disclaimer, the original version will prevail.
If a section in the Document is Entitled "Acknowledgements",
"Dedications", or "History", the requirement (section 4) to Preserve
its Title (section 1) will typically require changing the actual
title.
9. TERMINATION
You may not copy, modify, sublicense, or distribute the Document
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense, or distribute it is void, and
will automatically terminate your rights under this License.
However, if you cease all violation of this License, then your license
from a particular copyright holder is reinstated (a) provisionally,
unless and until the copyright holder explicitly and finally
terminates your license, and (b) permanently, if the copyright holder
fails to notify you of the violation by some reasonable means prior to
60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, receipt of a copy of some or all of the same material does
not give you any rights to use it.
10. FUTURE REVISIONS OF THIS LICENSE
The Free Software Foundation may publish new, revised versions of the
GNU Free Documentation License from time to time. Such new versions
will be similar in spirit to the present version, but may differ in
detail to address new problems or concerns. See
https://www.gnu.org/licenses/.
Each version of the License is given a distinguishing version number.
If the Document specifies that a particular numbered version of this
License "or any later version" applies to it, you have the option of
following the terms and conditions either of that specified version or
of any later version that has been published (not as a draft) by the
Free Software Foundation. If the Document does not specify a version
number of this License, you may choose any version ever published (not
as a draft) by the Free Software Foundation. If the Document
specifies that a proxy can decide which future versions of this
License can be used, that proxy's public statement of acceptance of a
version permanently authorizes you to choose that version for the
Document.
11. RELICENSING
"Massive Multiauthor Collaboration Site" (or "MMC Site") means any
World Wide Web server that publishes copyrightable works and also
provides prominent facilities for anybody to edit those works. A
public wiki that anybody can edit is an example of such a server. A
"Massive Multiauthor Collaboration" (or "MMC") contained in the site
means any set of copyrightable works thus published on the MMC site.
"CC-BY-SA" means the Creative Commons Attribution-Share Alike 3.0
license published by Creative Commons Corporation, a not-for-profit
corporation with a principal place of business in San Francisco,
California, as well as future copyleft versions of that license
published by that same organization.
"Incorporate" means to publish or republish a Document, in whole or in
part, as part of another Document.
An MMC is "eligible for relicensing" if it is licensed under this
License, and if all works that were first published under this License
somewhere other than this MMC, and subsequently incorporated in whole or
in part into the MMC, (1) had no cover texts or invariant sections, and
(2) were thus incorporated prior to November 1, 2008.
The operator of an MMC Site may republish an MMC contained in the site
under CC-BY-SA on the same site at any time before August 1, 2009,
provided the MMC is eligible for relicensing.
ADDENDUM: How to use this License for your documents
To use this License in a document you have written, include a copy of
the License in the document and put the following copyright and
license notices just after the title page:
Copyright (c) YEAR YOUR NAME.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3
or any later version published by the Free Software Foundation;
with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.
A copy of the license is included in the section entitled "GNU
Free Documentation License".
If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
replace the "with...Texts." line with this:
with the Invariant Sections being LIST THEIR TITLES, with the
Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST.
If you have Invariant Sections without Cover Texts, or some other
combination of the three, merge those two alternatives to suit the
situation.
If your document contains nontrivial examples of program code, we
recommend releasing these examples in parallel under your choice of
free software license, such as the GNU General Public License,
to permit their use in free software.

100
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/docs/introduction.lisp Normal file
View file

@ -0,0 +1,100 @@
(in-package :ps)
;;; Introduction
;;;
;;; Parenscript is a language that looks a lot like Common Lisp, but
;;; is JavaScript in disguise. This way, JavaScript programs can be
;;; seamlessly integrated in a Lisp web application. The programmer
;;; doesn't have to resort to a different syntax, and JavaScript code
;;; can easily be generated without having to resort to complicated
;;; string generation or `FORMAT' expressions.
;;;
;;; The following Lisp expression is a call to the Parenscript
;;; translator Parenscript transforms the expression in Parenscript
;;; into an equivalent, human-readable expression in JavaScript.
(ps
(defun foobar (a b)
(+ a b)))
;;; The resulting javascript is:
"
function foobar(a, b) {
return a + b;
}
"
;;; Great care has been given to the indentation and overall
;;; readability of the generated JavaScript code.
;;; Features
;;;
;;; Parenscript supports all the statements and expressions defined by
;;; the EcmaScript 262 standard. Lisp symbols are converted to
;;; camelcase, javascript-compliant syntax. This idea is taken from
;;; Linj by Antonio Menezes Leitao. Case sensitivity (using the
;;; :invert readtable-case option) is supported. Here are a few
;;; examples of Lisp symbol to JavaScript name conversion:
(ps foobar) => "foobar"
(ps foo-bar) => "fooBar"
(ps foo-b@r) => "fooBatr"
(ps *array) => "Array"
(ps FooBar) => "FooBar"
;;; Parenscript supports a subset of Common Lisp iteration constructs.
;;; `for' loops can be written using the customary `DO*' syntax.
(ps
(do* ((i 0 (incf i))
(j (aref arr i) (aref arr i)))
((>= i 10))
(alert (+ "i is " i " and j is " j))))
;; compiles to
"
for (var i = 0, j = arr[i]; i < 10; i = ++i, j = arr[i]) {
alert('i is ' + i + ' and j is ' + j);
};
"
;;; Parenscript uses the Lisp reader, allowing for reader macros. It
;;; also comes with its own macro environment, allowing host Lisp
;;; macros and Parenscript macros to coexist without interfering with
;;; each other. For example, the `1+' construct is implemented using
;;; a Parenscript macro:
(defpsmacro 1+ (form)
`(+ ,form 1))
;;; Parenscript allows the creation of JavaScript objects in a Lispy
;;; way, using keyword arguments.
(ps
(create :foo "foo"
:bla "bla"))
;; compiles to
"
{ foo : 'foo',
bla : 'bla' }
"
;;; Parenscript features a HTML generator. Using the same syntax as
;;; the HTMLGEN package of Franz, Inc., it can generate JavaScript
;;; string expressions. This allows for a clean integration of HTML in
;;; Parenscript code, instead of writing the tedious and error-prone
;;; string generation code generally found in JavaScript.
(ps
(defun add-div (name href link-text)
(funcall (getprop document 'write)
(ps-html ((:div :id name)
"The link is: "
((:a :href href) link-text))))))
;; compiles to
"
function addDiv(name, href, linkText) {
return document.write(['<div id=\\\"', name, '\\\">The link is: <a href=\\\"', href, '\\\">', linkText, '</a></div>'].join(''));
};
"

1587
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/docs/reference.html Normal file
View file

File diff suppressed because it is too large Load diff

350
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/docs/tutorial.html Normal file
View file

@ -0,0 +1,350 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="utf-8">
<meta name="viewport"
content="width=device-width, initial-scale=1"
>
<title>Parenscript Tutorial</title>
<style type="text/css">
body {
max-width: 70ex;
margin: auto;
}
pre {
border: 1px solid #d5d5d5;
background: #f9f9f9;
padding: 1ex;
}
</style>
</head>
<body>
<h1 style="text-align:center;">Parenscript Tutorial</h1>
<p>
Copyright 2009, 2018 Vladimir Sedach.<br/>
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
Version 1.3 or any later version published by the Free Software
Foundation; with no Invariant Sections, no Front-Cover Texts,
and no Back-Cover Texts. A copy of the license can be
found <a href="https://www.gnu.org/licenses/fdl.html">on the
GNU website</a>.
</p>
<h2>Introduction</h2>
<p>
This tutorial shows how to build a simple web application in
Common Lisp, specifically demonstrating
the <a href="http://common-lisp.net/project/parenscript/">Parenscript</a>
Lisp to JavaScript compiler.
</p>
<p>
The <a href="reference.html">Parenscript
reference manual</a> contains a description of Parenscript
functions and macros.
</p>
<h2>Getting Started</h2>
<p>
First, install a Common Lisp
implementation. <a href="http://sbcl.org/">SBCL</a> is a good
one; <a href="https://www.cliki.net/">CLiki</a> has
a <a href="https://www.cliki.net/Common+Lisp+implementation">comprehensive
list of Common Lisp implementations</a>. Next, get
the <a href="https://www.quicklisp.org/">Quicklisp</a> package
manager.
</p>
<p>
This tutorial uses the following libraries:
</p>
<dl>
<dt><a href="https://edicl.github.io/cl-fad/">CL-FAD</a></dt>
<dd>file utilities</dd>
<dt><a href="https://edicl.github.io/cl-who/">CL-WHO</a></dt>
<dd>HTML generator</dd>
<dt><a href="https://edicl.github.io/hunchentoot/">Hunchentoot</a></dt>
<dd>web server</dd>
<dt><a href="https://common-lisp.net/project/parenscript/">Parenscript</a></dt>
<dd>JavaScript generator</dd>
</dl>
<p>
Load them using Quicklisp:
</p>
<pre><code>(mapc #'ql:quickload '(:cl-fad :cl-who :hunchentoot :parenscript))</code></pre>
<p>
Next, define a package to hold the example code:
</p>
<pre><code>(defpackage &quot;PS-TUTORIAL&quot;
(:use &quot;COMMON-LISP&quot; &quot;HUNCHENTOOT&quot; &quot;CL-WHO&quot; &quot;PARENSCRIPT&quot; &quot;CL-FAD&quot;))
(in-package &quot;PS-TUTORIAL&quot;)</code></pre>
<p>
CL-WHO leaves it up to you to escape HTML attributes. One way to
make sure that quoted strings in inline JavaScript work inside
HTML attributes is to use double quotes for HTML attributes and
single quotes for JavaScript strings.
</p>
<pre><code>(setq cl-who:*attribute-quote-char* #\&quot;)</code></pre>
<p>
Now start the web server:
</p>
<pre><code>(start (make-instance 'easy-acceptor :port 8080))</code></pre>
<h2>Examples</h2>
<p>
The <code>ps</code> macro takes Parenscript code in the form of
s-expressions (Parenscript code and Common Lisp code share the
same representation), translates as much as it can into constant
strings at macro-expansion time, and expands into a form that
will evaluate to a string containing JavaScript code.
</p>
<pre><code>(define-easy-handler (example1 :uri "/example1") ()
(with-html-output-to-string (s)
(:html
(:head (:title "Parenscript tutorial: 1st example"))
(:body (:h2 "Parenscript tutorial: 1st example")
"Please click the link below." :br
(:a :href "#" :onclick (ps (alert "Hello World"))
"Hello World")))))</code></pre>
<p>
One way to include Parenscript code in web pages is to inline it
in HTML <code>script</code> tags:
</p>
<pre><code>(define-easy-handler (example2 :uri "/example2") ()
(with-html-output-to-string (s)
(:html
(:head
(:title "Parenscript tutorial: 2nd example")
(:script :type "text/javascript"
(str (ps
(defun greeting-callback ()
(alert "Hello World"))))))
(:body
(:h2 "Parenscript tutorial: 2nd example")
(:a :href "#" :onclick (ps (greeting-callback))
"Hello World")))))</code></pre>
<p>
Another way to integrate Parenscript into a web application is
to serve the generated JavaScript as a separate HTTP resource.
Requests to this resource can then be cached by the browser:
</p>
<pre><code>(define-easy-handler (example3 :uri "/example3.js") ()
(setf (content-type*) "text/javascript")
(ps
(defun greeting-callback ()
(alert "Hello World"))))</code></pre>
<h2>Slideshow</h2>
<p>
Next let's try a more complicated example: an image slideshow
viewer.
</p>
<p>
First we need a way to define slideshows. For this tutorial we
will assume that we have several different folders containing
image files, and we want to serve each of the folders as its own
slideshow under its own URL. We will use a custom Hunchentoot
handler to serve the slideshow
under <samp>/slideshows/{slideshow-name}</samp>, and the
built-in Hunchentoot
<a href="https://edicl.github.io/hunchentoot/#create-folder-dispatcher-and-handler">folder
dispatcher</a> to serve the image files
from <samp>/slideshow-images/{slideshow-name}/{image-file}</samp>.
</p>
<pre><code>(defvar *slideshows* (make-hash-table :test 'equalp))
(defun add-slideshow (slideshow-name image-folder)
(setf (gethash slideshow-name *slideshows*) image-folder)
(push (create-folder-dispatcher-and-handler
(format nil "/slideshow-images/~a/" slideshow-name)
image-folder)
*dispatch-table*))</code></pre>
<p>
Let's find some important pictures on our machine and get
Hunchentoot to start serving them:
</p>
<pre><code>(add-slideshow "lolcat" "/home/junk/lolcats/")
(add-slideshow "lolrus" "/home/other-junk/lolruses/")</code></pre>
<p>
Next we need to create the slideshow web page. We can use
JavaScript to view the slideshow without refreshing the whole
page, and provide regular link navigation for client browsers
that do not have JavaScript enabled. Either way, we want viewers
of our slideshow to be able to bookmark their place in the
slideshow viewing sequence.
</p>
<p>
We will need a way to generate URIs for slideshow images on both
the server and browser. We can eliminate code duplication with
the <code>defmacro+ps</code> macro, which shares macro
definitions between Common Lisp and Parenscript.
</p>
<pre><code>(defmacro+ps slideshow-image-uri (slideshow-name image-file)
`(concatenate 'string "/slideshow-images/" ,slideshow-name "/" ,image-file))</code></pre>
<p>
Next is the function to serve up the slideshow page. The pages
will be served under <samp>/slideshows/{slideshow-name}</samp>,
all of them handled by a single function that will dispatch on
<samp>{slideshow-name}</samp>.
</p>
<p>
JavaScript-enabled web browsers will get information about the
slideshow in an inline script generated
by <a href="reference.html#ps*"><code>ps*</code></a>,
a function used for translating code generated at run-time.
Slideshow navigation will be done with <code>onclick</code>
handlers, generated at compile-time by
the <a href="reference.html#ps"><code>ps</code></a>
macro.
</p>
<p>
Regular HTML slideshow navigation will be done using query
parameters.
</p>
<pre><code>(defun slideshow-handler ()
(cl-ppcre:register-groups-bind (slideshow-name)
("/slideshows/(.*)" (script-name*))
(let* ((images (mapcar
(lambda (i) (url-encode (file-namestring i)))
(list-directory
(or (gethash slideshow-name *slideshows*)
(progn (setf (return-code*) 404)
(return-from slideshow-handler))))))
(current-image-index
(or (position (url-encode (or (get-parameter "image") ""))
images
:test #'equalp)
0))
(previous-image-index (max 0
(1- current-image-index)))
(next-image-index (min (1- (length images))
(1+ current-image-index))))
(with-html-output-to-string (s)
(:html
(:head
(:title "Parenscript slideshow")
(:script
:type "text/javascript"
(str
(ps*
`(progn
(var *slideshow-name* ,slideshow-name)
(var *images* (array ,@images))
(var *current-image-index* ,current-image-index)))))
(:script :type "text/javascript" :src "/slideshow.js"))
(:body
(:div :id "slideshow-container"
:style "width:100%;text-align:center"
(:img :id "slideshow-img-object"
:src (slideshow-image-uri
slideshow-name
(elt images current-image-index)))
:br
(:a :href (format nil "/slideshows/~a?image=~a"
slideshow-name
(elt images previous-image-index))
:onclick (ps (previous-image) (return false))
"Previous")
" "
(:a :href (format nil "/slideshows/~a?image=~a"
slideshow-name
(elt images next-image-index))
:onclick (ps (next-image) (return false))
"Next"))))))))</code></pre>
<p>
Since this function is a custom handler, we need to create a new
dispatcher for it. Note that we are passing the symbol naming
the handler instead of the function object, which lets us
redefine the handler without touching the dispatcher.
</p>
<pre><code>(push (create-prefix-dispatcher "/slideshows/" 'slideshow-handler)
*dispatch-table*)</code></pre>
<p>
Last, we need to define the <samp>/slideshow.js</samp> script.
</p>
<pre><code>(define-easy-handler (js-slideshow :uri "/slideshow.js") ()
(setf (content-type*) "text/javascript")
(ps
(define-symbol-macro fragment-identifier (@ window location hash))
(defun show-image-number (image-index)
(let ((image-name (aref *images* (setf *current-image-index* image-index))))
(setf (chain document (get-element-by-id "slideshow-img-object") src)
(slideshow-image-uri *slideshow-name* image-name)
fragment-identifier
image-name)))
(defun previous-image ()
(when (> *current-image-index* 0)
(show-image-number (1- *current-image-index*))))
(defun next-image ()
(when (< *current-image-index* (1- (getprop *images* 'length)))
(show-image-number (1+ *current-image-index*))))
;; use fragment identifiers to allow bookmarking
(setf (getprop window 'onload)
(lambda ()
(when fragment-identifier
(let ((image-name (chain fragment-identifier (slice 1))))
(dotimes (i (length *images*))
(when (string= image-name (aref *images* i))
(show-image-number i)))))))))</code></pre>
<p>
Note
the <a href="reference.html#@"><code>@</code></a>
and <a href="reference.html#chain"><code>chain</code></a>
property access convenience macros. <code>(@ object slotA
slotB)</code> expands to
<code>(getprop (getprop object 'slotA)
'slotB)</code>. <code>chain</code> is similar and also provides
nested method calls.
</p>
<p style="font-size:xx-small; float:right;">Author: Vladimir Sedach &lt;<a href="mailto:vas@oneofus.la">vas@oneofus.la</a>&gt; Last modified: 2018-03-29</p>
</body>
</html>

32
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/extras/firebug-tracing.lisp Normal file
View file

@ -0,0 +1,32 @@
;; SPDX-License-Identifier: BSD-3-Clause
;; Tracing macro courtesy of William Halliburton
;; <whalliburton@gmail.com>, logs to Firebug console
;; On a happier note here is a macro I wrote to enable
;; tracing-ala-cl. Works with firebug. You'll need to (defvar
;; *trace-level*). I don't do indentation but that would be an easy
;; addition.
(defpsmacro console (&rest rest)
`(console.log ,@rest))
(defpsmacro defun-trace (name args &rest body)
(let* ((sname (ps::symbol-to-js name))
(tname (ps-gensym name))
(arg-names (loop for arg in args
unless (eq arg '&optional)
collect (if (consp arg) (car arg) arg)))
(argpairs
(loop for arg in arg-names
nconc (list (ps::symbol-to-js arg) arg))))
`(progn
(defun ,name ,arg-names
(console *trace-level* ,sname ":" ,@argpairs)
(incf *trace-level*)
(let* ((rtn (,tname ,@arg-names)))
(decf *trace-level*)
(console *trace-level* ,sname "returned" rtn)
(return rtn)))
(defun ,tname ,args
,@body))))

55
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/extras/js-expander.el Normal file
View file

@ -0,0 +1,55 @@
;; SPDX-License-Identifier: BSD-3-Clause
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; This is an extension to SLIME that is inspired by (and works
;;;; like) the SLIME 'C-c M-m' macroexpansion feature.
;;;; After loading, 'C-c j' (PS) or 'C-c d' (PS-DOC) at a ParenScript
;;;; expression in a slime-mode buffer will bring up a buffer with the
;;;; resulting Javascript code. Note that the extension does not work
;;;; in slime-repl-mode, which is intentional.
;;;; Copyright 2007, Vladimir Sedach. See the COPYING file in the
;;;; Parenscript distribution for licensing information.
;;; The code below is a generic facility for adding "macroexpand-like" buffer expansion to Slime
(defun slime-eval-custom-expand (expander exp-str package buffer-name buffer-mode printer)
(lexical-let ((package package)
(buffer-name buffer-name)
(buffer-mode buffer-mode)
(printer printer))
(slime-eval-async
(list 'swank:eval-and-grab-output (format "(%s %s)" expander exp-str))
(lambda (expansion)
(slime-with-popup-buffer (buffer-name)
(funcall buffer-mode)
(setq buffer-read-only nil)
(erase-buffer)
(insert (funcall printer (second expansion)))
(setq buffer-read-only t)
(font-lock-fontify-buffer)))
package)))
(defun* slime-add-custom-expander (key expander buffer-name &optional (buffer-mode 'slime-mode) (printer #'identity))
(define-key slime-parent-map (concat "\C-c" key)
(lexical-let ((expander expander)
(buffer-name buffer-name)
(buffer-mode buffer-mode)
(printer printer))
(lambda (&rest _)
(interactive "P")
(slime-eval-custom-expand expander
(slime-sexp-at-point)
(slime-current-package)
buffer-name
buffer-mode
printer)))))
;;; This actually defines the expander. If the code above belongs in slime.el, the code below would go into .emacs
(map nil (lambda (x)
(slime-add-custom-expander (car x)
(cdr x)
"*Parenscript generated Javascript*"
(if (featurep 'javascript-mode) 'javascript-mode 'c-mode)
#'read))
'(("j" . ps:ps) ("d" . ps:ps-doc)))

19
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/extras/swank-parenscript.lisp Normal file
View file

@ -0,0 +1,19 @@
;; SPDX-License-Identifier: BSD-3-Clause
(in-package :parenscript)
(defun parenscript-function-p (symbol)
(and (or (gethash symbol *ps-macro-toplevel* )
(gethash symbol *ps-function-toplevel-cache*))
t))
#++
(pushnew 'parenscript-function-p swank::*external-valid-function-name-p-hooks*)
(defun parenscript-arglist (fname)
(acond
((gethash fname *ps-macro-toplevel-lambda-list*)
(values it t))
((gethash fname *ps-function-toplevel-cache*)
(values it t))))
#++
(pushnew 'parenscript-arglist swank::*external-arglist-hooks*)

35
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/parenscript.asd Normal file
View file

@ -0,0 +1,35 @@
;;;; -*- lisp -*-
(defsystem :parenscript
:name "parenscript"
:author "Manuel Odendahl <manuel@bl0rg.net>"
:maintainer "Vladimir Sedach <vas@oneofus.la>"
:licence "BSD-3-Clause"
:description "Lisp to JavaScript transpiler"
:components
((:static-file "parenscript.asd")
(:module :src
:serial t
:components ((:file "package")
(:file "js-dom-symbol-exports") ;; has to be loaded here, ps-js-symbols externals are re-exported from #:parenscript package
(:file "js-ir-package")
(:file "utils")
(:file "namespace")
(:file "compiler")
(:file "printer")
(:file "compilation-interface")
(:file "non-cl")
(:file "special-operators")
(:file "parse-lambda-list")
(:file "function-definition")
(:file "macros")
(:file "deprecated-interface")
(:module :lib
:components ((:file "ps-html")
(:file "ps-loop")
(:file "ps-dom"))
:depends-on ("compilation-interface"))))
(:module :runtime
:components ((:file "ps-runtime-lib"))
:depends-on (:src)))
:depends-on (:cl-ppcre :anaphora :named-readtables))

13
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/parenscript.tests.asd Normal file
View file

@ -0,0 +1,13 @@
;;;; -*- lisp -*-
(defsystem :parenscript.tests
:license "BSD-3-Clause"
:description "Unit tests for Parenscript"
:components ((:module :tests
:serial t
:components ((:file "test-package")
(:file "test")
(:file "output-tests")
(:file "package-system-tests")
(:file "eval-tests"))))
:depends-on (:parenscript :fiveam :cl-js))

69
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/runtime/ps-runtime-lib.lisp Normal file
View file

@ -0,0 +1,69 @@
;; SPDX-License-Identifier: BSD-3-Clause
(in-package #:parenscript)
;;; Script of library functions you can include with your own code to
;;; provide standard Lisp functionality.
(defparameter *ps-lisp-library*
'(progn
(defun mapcar (fun &rest arrs)
(let ((result-array (make-array)))
(if (= 1 (length arrs))
(dolist (element (aref arrs 0))
((@ result-array push) (fun element)))
(dotimes (i (length (aref arrs 0)))
(let ((args-array (mapcar (lambda (a) (aref a i)) arrs)))
((@ result-array push) ((@ fun apply) fun args-array)))))
result-array))
(defun map-into (fn arr)
"Call FN on each element in ARR, replace element with the return value."
(let ((idx 0))
(dolist (el arr)
(setf (aref arr idx) (fn el))
(setf idx (1+ idx))))
arr)
(defun map (fn arr)
"Call FN on each element in ARR and return the returned values in a new array."
;; In newer versions of ECMAScript, this may call Array.map, too
(let ((idx 0)
(result (array)))
(dolist (el arr)
(setf (aref result idx) (fn el))
(setf idx (1+ idx)))
result))
(defun member (item arr)
"Check if ITEM is a member of ARR."
(dolist (el arr)
(if (= el item)
(return-from member true)))
false)
(defun set-difference (arr arr-to-sub)
"Return a new array with only those elements in ARR that are not in ARR-TO-SUB."
(let ((idx 0)
(result (array)))
(dolist (el arr)
(unless (member el arr-to-sub)
(setf (aref result idx) el)
(setf idx (1+ idx))))
result))
(defun reduce (func list &optional init)
(let* ((acc))
(do* ((i (if (= (length arguments) 3) -1 0)
(1+ i))
(acc (if (= (length arguments) 3) init (elt list 0))
(func acc (elt list i))))
((>= i (1- (length list)))))
acc))
(defun nconc (arr &rest arrs)
(when (and arr (> (length arr) 0))
(loop :for other :in arrs :when (and other (> (length other) 0)) :do
((@ arr :splice :apply) arr
(append (list (length arr) (length other)) other))))
arr)))

133
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/compilation-interface.lisp Normal file
View file

@ -0,0 +1,133 @@
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2006 Luca Capello
;;; Copyright 2007-2009 Red Daly
;;; Copyright 2008 Travis Cross
;;; Copyright 2007-2011 Vladimir Sedach
;;; Copyright 2009-2010 Daniel Gackle
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(defparameter *js-target-version* "1.3")
(defvar *parenscript-stream* nil)
(defmacro ps (&body body)
"Given Parenscript forms (an implicit progn), compiles those forms
to a JavaScript string at macro-expansion time. Expands into a form
which evaluates to a string."
(let ((printed-forms (parenscript-print
(compile-statement `(progn ,@body))
nil)))
(if (and (not (cdr printed-forms))
(stringp (car printed-forms)))
(car printed-forms)
(let ((s (gensym)))
`(with-output-to-string (,s)
,@(mapcar (lambda (x) `(write-string ,x ,s))
printed-forms))))))
(defmacro ps-to-stream (stream &body body)
"Given Parenscript forms (an implicit progn), compiles those forms
to a JavaScript string at macro-expansion time. Expands into a form
which writes the resulting code to stream."
(let ((printed-forms (parenscript-print
(compile-statement `(progn ,@body))
nil)))
`(let ((*parenscript-stream* ,stream))
,@(mapcar (lambda (x) `(write-string ,x *parenscript-stream*))
printed-forms))))
(defun ps* (&rest body)
"Compiles body to a JavaScript string. If *parenscript-stream* is
bound, writes the output to *parenscript-stream*, otherwise returns a
string."
(let ((*psw-stream* (or *parenscript-stream* (make-string-output-stream))))
(parenscript-print (compile-statement `(progn ,@body)) t)
(unless *parenscript-stream*
(get-output-stream-string *psw-stream*))))
(defmacro with-blank-compilation-environment (&body body)
`(let ((*ps-gensym-counter* 0)
(*special-variables* nil))
,@body))
(defmacro ps-doc (&body body)
"Expands Parenscript forms in a clean environment."
(with-blank-compilation-environment
(macroexpand-1 `(ps ,@body))))
(defun ps-doc* (&rest body)
(with-blank-compilation-environment
(apply #'ps* body)))
(defvar *js-inline-string-delimiter* #\"
"Controls the string delimiter char used when compiling Parenscript in ps-inline.")
(defun ps-inline* (form &optional
(*js-string-delimiter* *js-inline-string-delimiter*))
(concatenate 'string "javascript:" (ps* form)))
(defmacro+ps ps-inline (form &optional
(string-delimiter *js-inline-string-delimiter*))
`(concatenate 'string "javascript:"
,@(let ((*js-string-delimiter* string-delimiter))
(parenscript-print (compile-statement form) nil))))
(defvar *ps-read-function* #'read)
(defun ps-compile-stream (stream)
"Reads (using the value of *ps-read-function*, #'read by default, as
the read function) Parenscript forms from stream and compiles them as
if by ps*. If *parenscript-stream* is bound, writes the output to
*parenscript-stream*, otherwise and returns a string."
(let ((output-stream (or *parenscript-stream* (make-string-output-stream))))
(let ((*compilation-level* :toplevel)
(*readtable* *readtable*)
(*package* *package*)
(*parenscript-stream* output-stream)
(eof '#:eof))
(loop for form = (funcall *ps-read-function* stream nil eof)
until (eq form eof) do (ps* form) (fresh-line *parenscript-stream*)))
(unless *parenscript-stream*
(get-output-stream-string output-stream))))
(defun ps-compile-file (source-file &key (element-type 'character) (external-format :default))
"Opens file as input stream and calls ps-compile-stream on it."
(with-open-file (stream source-file
:direction :input
:element-type element-type
:external-format external-format)
(ps-compile-stream stream)))

405
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/compiler.lisp Normal file
View file

@ -0,0 +1,405 @@
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2006 Attila Lendvai
;;; Copyright 2006 Luca Capello
;;; Copyright 2007-2012, 2018 Vladimir Sedach
;;; Copyright 2008 Travis Cross
;;; Copyright 2009-2010 Red Daly
;;; Copyright 2009-2010 Daniel Gackle
;;; Copyright 2012, 2015 Boris Smilga
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(in-readtable :parenscript)
(defvar *version* 2.7 "Parenscript compiler version.")
(defparameter %compiling-reserved-forms-p% t
"Used to issue warnings when replacing PS special operators or macros.")
(defvar *defined-operators* ()
"Special operators and macros defined by Parenscript. Replace at your own risk!")
(defun defined-operator-override-check (name &rest body)
(when (and (not %compiling-reserved-forms-p%) (member name *defined-operators*))
(warn 'simple-style-warning
:format-control "Redefining Parenscript operator/macro ~A"
:format-arguments (list name)))
`(progn ,(when %compiling-reserved-forms-p% `(pushnew ',name *defined-operators*))
,@body))
(defvar *reserved-symbol-names*
(list "break" "case" "catch" "continue" "default" "delete" "do" "else"
"finally" "for" "function" "if" "in" "instanceof" "new" "return"
"switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"
"abstract" "boolean" "byte" "char" "class" "const" "debugger"
"double" "enum" "export" "extends" "final" "float" "goto"
"implements" "import" "int" "interface" "long" "native" "package"
"private" "protected" "public" "short" "static" "super"
"synchronized" "throws" "transient" "volatile" "{}" "true" "false"
"null" "undefined"))
(defvar *lambda-wrappable-statements*
'(throw switch for for-in while try block)
"Statement special forms that can be wrapped in a lambda to make
them into expressions. Control transfer forms like BREAK, RETURN,
and CONTINUE need special treatment, and are not included.")
(defun reserved-symbol-p (symbol)
(find (string-downcase (string symbol)) *reserved-symbol-names* :test #'string=))
;;; special forms
(defvar *special-expression-operators* (make-hash-table :test 'eq))
(defvar *special-statement-operators* (make-hash-table :test 'eq))
;; need to split special op definition into two parts - statement and expression
(defmacro %define-special-operator (type name lambda-list &body body)
(defined-operator-override-check name
`(setf (gethash ',name ,type)
(lambda (&rest whole)
(destructuring-bind ,lambda-list whole
,@body)))))
(defmacro define-expression-operator (name lambda-list &body body)
`(%define-special-operator *special-expression-operators*
,name ,lambda-list ,@body))
(defmacro define-statement-operator (name lambda-list &body body)
`(%define-special-operator *special-statement-operators*
,name ,lambda-list ,@body))
(defun special-form? (form)
(and (consp form)
(symbolp (car form))
(or (gethash (car form) *special-expression-operators*)
(gethash (car form) *special-statement-operators*))))
;;; naming, scoping, and lexical environment
(defvar *ps-gensym-counter* 0)
(defvar *vars-needing-to-be-declared* ()
"This special variable is expected to be bound to a fresh list by
special forms that introduce a new JavaScript lexical block (currently
function definitions and lambdas). Enclosed special forms are expected
to push variable declarations onto the list when the variables
declaration cannot be made by the enclosed form (for example, a x,y,z
expression progn). It is then the responsibility of the enclosing
special form to introduce the variable declarations in its lexical
block.")
(defvar *used-up-names*)
(setf (documentation '*used-up-names* 'variable)
"Names that have been already used for lexical bindings in the current function scope.")
(defvar in-case? nil
"Bind to T when compiling CASE branches.")
(defvar in-loop-scope? nil
"Used for seeing when we're in loops, so that we can introduce
proper scoping for lambdas closing over loop-bound
variables (otherwise they all share the same binding).")
(defvar *loop-return-var* nil
"Variable which is used to return values from inside loop bodies.")
(defvar *loop-return-set-var* nil
"Variable which is set by RETURN-FROM when it returns a value from inside
a loop. The value is the name of a PS variable which dynamically
indicates if the return statement indeed has been invoked.")
(defvar *loop-scope-lexicals*)
(setf (documentation '*loop-scope-lexicals* 'variable)
"Lexical variables introduced by a loop.")
(defvar *loop-scope-lexicals-captured*)
(setf (documentation '*loop-scope-lexicals-captured* 'variable)
"Lexical variables introduced by a loop that are also captured by lambdas inside a loop.")
(defvar in-function-scope? nil
"Lets the compiler know when lambda wrapping is necessary.")
(defvar *local-function-names* ()
"Functions named by flet and label.")
;; is a subset of
(defvar *enclosing-lexicals* ()
"All enclosing lexical variables (includes function names).")
(defvar *enclosing-function-arguments* ()
"Lexical variables bound in all lexically enclosing function argument lists.")
(defvar *function-block-names* ()
"All block names that this function is responsible for catching.")
(defvar *dynamic-return-tags* ()
"Tags that need to be thrown to to reach.")
(defvar *current-block-tag* nil
"Name of the lexically enclosing block, if any.")
(defvar *special-variables* ()
"Special variables declared during any Parenscript run. Re-bind this if you want to clear the list.")
(defun special-variable? (sym)
(member sym *special-variables*))
;;; meta info
(defvar *macro-toplevel-lambda-list* (make-hash-table)
"Table of lambda lists for toplevel macros.")
(defvar *function-lambda-list* (make-hash-table)
"Table of lambda lists for defined functions.")
;;; macros
(defun make-macro-dictionary ()
(make-hash-table :test 'eq))
(defvar *macro-toplevel* (make-macro-dictionary)
"Toplevel macro environment dictionary.")
(defvar *macro-env* (list *macro-toplevel*)
"Current macro environment.")
(defvar *symbol-macro-toplevel* (make-macro-dictionary))
(defvar *symbol-macro-env* (list *symbol-macro-toplevel*))
(defvar *setf-expanders* (make-macro-dictionary)
"Setf expander dictionary. Key is the symbol of the access
function of the place, value is an expansion function that takes the
arguments of the access functions as a first value and the form to be
stored as the second value.")
(defun lookup-macro-def (name env)
(loop for e in env thereis (gethash name e)))
(defun make-ps-macro-function (args body)
"Given the arguments and body to a parenscript macro, returns a
function that may be called on the entire parenscript form and outputs
some parenscript code. Returns a second value that is the effective
lambda list from a Parenscript perspective."
(let* ((whole-var (when (eql '&whole (first args)) (second args)))
(effective-lambda-list (if whole-var (cddr args) args))
(whole-arg (or whole-var (gensym "ps-macro-form-arg-"))))
(values
`(lambda (,whole-arg)
(destructuring-bind ,effective-lambda-list
(cdr ,whole-arg)
,@body))
effective-lambda-list)))
(defmacro defpsmacro (name args &body body)
(defined-operator-override-check name
(multiple-value-bind (macro-fn-form effective-lambda-list)
(make-ps-macro-function args body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (gethash ',name *macro-toplevel*) ,macro-fn-form)
(setf (gethash ',name *macro-toplevel-lambda-list*) ',effective-lambda-list)
',name))))
(defmacro define-ps-symbol-macro (symbol expansion)
(defined-operator-override-check symbol
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (gethash ',symbol *symbol-macro-toplevel*)
(lambda (form)
(declare (ignore form))
',expansion)))))
(defun import-macros-from-lisp (&rest names)
"Import the named Lisp macros into the Parenscript macro
environment. When the imported macro is macroexpanded by Parenscript,
it is first fully macroexpanded in the Lisp macro environment, and
then that expansion is further expanded by Parenscript."
(dolist (name names)
(eval `(defpsmacro ,name (&rest args)
(macroexpand `(,',name ,@args))))))
(defmacro defmacro+ps (name args &body body)
"Define a Lisp macro and a Parenscript macro with the same macro
function (ie - the same result from macroexpand-1), for cases when the
two have different full macroexpansions (for example if the CL macro
contains implementation-specific code when macroexpanded fully in the
CL environment)."
`(progn (defmacro ,name ,args ,@body)
(defpsmacro ,name ,args ,@body)))
(defun symbol-macro? (form)
"If FORM is a symbol macro, return its macro function. Otherwise,
return NIL."
(and (symbolp form)
(or (and (member form *enclosing-lexicals*)
(lookup-macro-def form *symbol-macro-env*))
(gethash form *symbol-macro-toplevel*))))
(defun ps-macroexpand-1 (form)
(aif (or (symbol-macro? form)
(and (consp form) (lookup-macro-def (car form) *macro-env*)))
(values (ps-macroexpand (funcall it form)) t)
form))
(defun ps-macroexpand (form)
(multiple-value-bind (form1 expanded?)
(ps-macroexpand-1 form)
(if expanded?
(values (ps-macroexpand form1) t)
form1)))
;;;; compiler interface
(defparameter *compilation-level* :toplevel
"This value takes on the following values:
:toplevel indicates that we are traversing toplevel forms.
:inside-toplevel-form indicates that we are inside a call to ps-compile-*
nil indicates we are no longer toplevel-related.")
(defun adjust-compilation-level (form level)
"Given the current *compilation-level*, LEVEL, and the fully macroexpanded
form, FORM, returns the new value for *compilation-level*."
(cond ((or (and (consp form)
(member (car form) '(progn locally macrolet symbol-macrolet)))
(and (symbolp form) (eq :toplevel level)))
level)
((eq :toplevel level) :inside-toplevel-form)))
(defvar compile-expression?)
(defvar clear-multiple-values? t)
(define-condition compile-expression-error (error)
((form :initarg :form :reader error-form))
(:report
(lambda (condition stream)
(format
stream
"The Parenscript form ~A cannot be compiled into an expression."
(error-form condition)))))
(defun compile-special-form (form)
(let* ((op (car form))
(statement-impl (gethash op *special-statement-operators*))
(expression-impl (gethash op *special-expression-operators*)))
(cond ((not compile-expression?)
(apply (or statement-impl expression-impl) (cdr form)))
(expression-impl
(apply expression-impl (cdr form)))
((member op *lambda-wrappable-statements*)
(compile-expression (with-lambda-scope form)))
(t
(error 'compile-expression-error :form form)))))
(defun ps-compile (form)
(macrolet
((try-expanding (form &body body)
`(multiple-value-bind (expansion expanded?)
(ps-macroexpand ,form)
(if expanded?
(ps-compile expansion)
,@body))))
(typecase form
((or null number string character)
form)
(vector
(ps-compile `(quote ,(coerce form 'list))))
(symbol
(try-expanding form form))
(cons
(try-expanding form
(let ((*compilation-level*
(adjust-compilation-level form *compilation-level*)))
(if (special-form? form)
(compile-special-form form)
(progn
(setq clear-multiple-values? t)
`(ps-js:funcall
,(if (symbolp (car form))
(maybe-rename-local-function (car form))
(compile-expression (car form)))
,@(mapcar #'compile-expression (cdr form)))))))))))
(defun compile-statement (form)
(let ((compile-expression? nil))
(ps-compile form)))
(defun compile-expression (form)
(let ((compile-expression? t))
(ps-compile form)))
(defun ps-gensym (&optional (x '_js))
(make-symbol
(if (integerp x)
(format nil "~A~A" '_js x)
(let ((prefix (string x)))
(format nil "~A~:[~;_~]~A"
prefix
(digit-char-p (char prefix (1- (length prefix))))
(incf *ps-gensym-counter*))))))
(defmacro with-ps-gensyms (symbols &body body)
"Helper macro for writing Parenscript macros. Each element of
SYMBOLS is either a symbol or a list of (symbol
gensym-prefix-string)."
`(let* ,(mapcar (lambda (symbol)
(destructuring-bind (symbol &optional prefix)
(if (consp symbol)
symbol
(list symbol))
(if prefix
`(,symbol (ps-gensym ,(string prefix)))
`(,symbol (ps-gensym ,(string symbol))))))
symbols)
,@body))
(defmacro ps-once-only ((&rest vars) &body body)
"Helper macro for writing Parenscript macros. Useful for preventing unwanted multiple evaluation."
(warn-deprecated 'ps-once-only 'maybe-once-only)
(let ((gensyms (mapcar #'ps-gensym vars)))
`(let* ,(mapcar (lambda (g v) `(,g (ps-gensym ',v)))
gensyms vars)
`(let* (,,@(mapcar (lambda (g v) `(list ,g ,v))
gensyms vars))
,(let* ,(mapcar (lambda (g v) (list v g))
gensyms vars)
,@body)))))
(defmacro maybe-once-only ((&rest vars) &body body)
"Helper macro for writing Parenscript macros. Like PS-ONCE-ONLY,
except that if the given VARS are variables or constants, no intermediate variables are created."
(let ((vars-bound (gensym)))
`(let*
((,vars-bound ())
,@(loop for var in vars collect
`(,var
(let ((form (ps-macroexpand ,var)))
(if (atom form)
form
(let ((var¹ (ps-gensym ',var)))
(push (list var¹ form) ,vars-bound)
var¹))))))
`(let* ,(nreverse ,vars-bound)
,,@body))))

162
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/deprecated-interface.lisp Normal file
View file

@ -0,0 +1,162 @@
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-06 Edward Marco Baringer
;;; Copyright 2007 Red Daly
;;; Copyright 2007 Attila Lendvai
;;; Copyright 2007-2012 Vladimir Sedach
;;; Copyright 2008 Travis Cross
;;; Coypright 2010, 2013 Daniel Gackle
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(in-readtable :parenscript)
(defun warn-deprecated (old-name &optional new-name)
(warn 'simple-style-warning
:format-control "~:@(~a~) is deprecated~:[.~;, use ~:@(~a~) instead~]"
:format-arguments (list old-name new-name new-name)))
(defmacro defun-js (old-name new-name args &body body)
`(defun ,old-name ,args
,(when (and (stringp (car body)) (< 1 (length body))) ; docstring
(car body))
(warn-deprecated ',old-name ',new-name)
,@body))
;;; DEPRECATED INTERFACE
(defmacro define-script-symbol-macro (name &body body)
(warn-deprecated 'define-script-symbol-macro 'define-ps-symbol-macro)
`(define-ps-symbol-macro ,name ,@body))
(defun js-equal (ps-form1 ps-form2)
(warn-deprecated 'js-equal)
(equalp ps-form1 ps-form2))
(defun-js js-compile compile-script (form)
(compile-script form))
(defun-js js-compile-list compile-script (form)
(compile-script form))
(defmacro defjsmacro (&rest args)
(warn-deprecated 'defjsmacro 'defpsmacro)
`(defpsmacro ,@args))
(defmacro js-inline (&rest body)
(warn-deprecated 'js-inline 'ps-inline)
`(js-inline* '(progn ,@body)))
(defun-js js-inline* ps-inline* (&rest body)
(apply #'ps-inline* body))
(defmacro with-unique-js-names (&rest args)
(warn-deprecated 'with-unique-js-names 'with-ps-gensyms)
`(with-ps-gensyms ,@args))
(defun-js gen-js-name ps-gensym (&optional (prefix "_JS_"))
(ps-gensym prefix))
(defmacro js (&rest args)
(warn-deprecated 'js 'ps)
`(ps ,@args))
(defun-js js* ps* (&rest args)
(apply #'ps* args))
(defun-js compile-script ps* (ps-form &key (output-stream nil))
"Compiles the Parenscript form PS-FORM into Javascript.
If OUTPUT-STREAM is NIL, then the result is a string; otherwise code
is output to the OUTPUT-STREAM stream."
(format output-stream "~A" (ps* ps-form)))
(defun-js symbol-to-js symbol-to-js-string (symbol)
(symbol-to-js-string symbol))
(defmacro defmacro/ps (name args &body body)
(warn-deprecated 'defmacro/ps 'defmacro+ps)
`(progn (defmacro ,name ,args ,@body)
(import-macros-from-lisp ',name)))
(defmacro defpsmacro-deprecated (old new)
`(defpsmacro ,old (&rest args)
(warn-deprecated ',old ',new)
(cons ',new args)))
(defpsmacro-deprecated slot-value getprop)
(defpsmacro-deprecated === eql)
(defpsmacro-deprecated == equal)
(defpsmacro-deprecated % rem)
(defpsmacro-deprecated concat-string stringify)
(defpsmacro !== (&rest args)
(warn-deprecated '!==)
`(not (eql ,@args)))
(defpsmacro != (&rest args)
(warn-deprecated '!=)
`(not (equal ,@args)))
(defpsmacro labeled-for (label init-forms cond-forms step-forms &rest body)
(warn-deprecated 'labeled-for 'label)
`(label ,label (for ,init-forms ,cond-forms ,step-forms ,@body)))
(defpsmacro do-set-timeout ((timeout) &body body)
(warn-deprecated 'do-set-timeout 'set-timeout)
`(set-timeout (lambda () ,@body) ,timeout))
(defun concat-string (&rest things)
(warn-deprecated 'concat-string 'stringify)
(apply #'stringify things))
(define-statement-operator with (expression &rest body)
(warn-deprecated 'with '|LET or WITH-SLOTS|)
`(ps-js:with ,(compile-expression expression)
,(compile-statement `(progn ,@body))))
(define-statement-operator while (test &rest body)
(warn-deprecated 'while '|LOOP WHILE|)
`(ps-js:while ,(compile-expression test)
,(compile-loop-body () body)))
(defmacro while (test &body body)
(warn-deprecated 'while '|LOOP WHILE|)
`(loop while ,test do (progn ,@body)))
(defpsmacro label (&rest args)
(warn-deprecated 'label 'block)
`(block ,@args))
(define-ps-symbol-macro f ps-js:false)
(setf %compiling-reserved-forms-p% nil)

283
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/function-definition.lisp Normal file
View file

@ -0,0 +1,283 @@
;;; Copyright 2011 Vladimir Sedach
;;; Copyright 2014-2015 Boris Smilga
;;; Copyright 2014 Max Rottenkolber
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(in-readtable :parenscript)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; lambda lists
(defun parse-key-spec (key-spec)
"parses an &key parameter. Returns 5 values:
var, init-form, keyword-name, supplied-p-var, init-form-supplied-p.
Syntax of key spec:
[&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
"
(let* ((var (cond ((symbolp key-spec) key-spec)
((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
((and (listp key-spec) (listp (first key-spec))) (second (first key-spec)))))
(keyword-name (if (and (listp key-spec) (listp (first key-spec)))
(first (first key-spec))
(intern (string var) :keyword)))
(init-form (if (listp key-spec) (second key-spec) nil))
(init-form-supplied-p (if (listp key-spec) t nil))
(supplied-p-var (if (listp key-spec) (third key-spec) nil)))
(values var init-form keyword-name supplied-p-var init-form-supplied-p)))
(defun parse-optional-spec (spec)
"Parses an &optional parameter. Returns 3 values: var, init-form, supplied-p-var.
[&optional {var | (var [init-form [supplied-p-parameter]])}*] "
(let* ((var (cond ((symbolp spec) spec)
((and (listp spec) (first spec)))))
(init-form (if (listp spec) (second spec)))
(supplied-p-var (if (listp spec) (third spec))))
(values var init-form supplied-p-var)))
(defun parse-body (body &key allow-docstring)
"Parses a function or block body, which may or may not include a
docstring. Returns 2 or 3 values: a docstring (if allowed for), a list
of (declare ...) forms, and the remaining body."
(let (docstring declarations)
(loop while
(cond ((and (consp (car body)) (eq (caar body) 'declare))
(push (pop body) declarations))
((and allow-docstring (not docstring)
(stringp (car body)) (cdr body))
(setf docstring (pop body)))))
(values body declarations docstring)))
(defun parse-extended-function (lambda-list body)
"The lambda list is transformed as follows:
* standard and optional variables are the mapped directly into
the js-lambda list
* keyword variables are not included in the js-lambda list, but
instead are obtained from the magic js ARGUMENTS
pseudo-array. Code assigning values to keyword vars is
prepended to the body of the function."
(multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux?
aux more? more-context more-count key-object)
(parse-lambda-list lambda-list)
(declare (ignore allow? aux? aux more? more-context more-count key-object))
(let* ( ;; optionals are of form (var default-value)
(effective-args
(remove-if #'null
(append requireds
(mapcar #'parse-optional-spec optionals))))
(opt-forms
(mapcar (lambda (opt-spec)
(multiple-value-bind (name value suppl)
(parse-optional-spec opt-spec)
(cond (suppl
`(progn
(var ,suppl (not (eql ,name undefined)))
,@(when value
`((when (not ,suppl) (setf ,name ,value))))))
(value
`(when (eql ,name undefined)
(setf ,name ,value))))))
optionals))
(key-forms
(when keys?
(with-ps-gensyms (n)
(let (defaults assigns)
(mapc
(lambda (k)
(multiple-value-bind (var init-form keyword-str suppl)
(parse-key-spec k)
(push `(var ,var ,@(when init-form `((if (undefined ,var) ,init-form ,var)))) defaults)
(when suppl (push `(var ,suppl) defaults))
(push `(,keyword-str
(setf ,var (aref arguments (1+ ,n))
,@(when suppl `(,suppl t))))
assigns)))
(reverse keys))
`((loop for ,n from ,(length requireds) below (length arguments) by 2 do
(case (aref arguments ,n)
,@assigns))
,@defaults)))))
(rest-form
(when rest?
`(var ,rest
((@ Array prototype slice call)
arguments ,(length effective-args))))))
(multiple-value-bind (fun-body declarations docstring)
(parse-body body :allow-docstring t)
(values effective-args
(append declarations
opt-forms key-forms (awhen rest-form (list it))
fun-body)
docstring)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; common
(defun collapse-function-return-blocks (body)
(append (butlast body)
(let ((last (ps-macroexpand (car (last body)))))
(if (and (listp last) (eq 'block (car last)))
;; no need for a block at the end of a function body
(progn (push (or (second last) 'nilBlock)
*function-block-names*)
(cddr last))
(list last)))))
(defun compile-function-body (args body)
(with-declaration-effects (body body)
(let* ((in-function-scope? t)
(*current-block-tag* nil)
(*vars-needing-to-be-declared* ())
(*used-up-names* ())
(returning-values? nil)
(clear-multiple-values? nil)
(*enclosing-function-arguments*
(append args *enclosing-function-arguments*))
(*enclosing-lexicals*
(set-difference *enclosing-lexicals* args))
(collapsed-body
(collapse-function-return-blocks body))
(*dynamic-return-tags*
(append (mapcar (lambda (x) (cons x nil))
*function-block-names*)
*dynamic-return-tags*))
(body
(let ((in-loop-scope? nil)
(*loop-scope-lexicals* ())
(*loop-scope-lexicals-captured* ()))
(cdr
(wrap-for-dynamic-return
*function-block-names*
(compile-statement
`(return-from %function (progn ,@collapsed-body)))))))
(var-decls
(compile-statement
`(progn
,@(mapcar
(lambda (var) `(var ,var))
(remove-duplicates *vars-needing-to-be-declared*))))))
(when in-loop-scope?
(setf *loop-scope-lexicals-captured*
(append (intersection (flatten body) *loop-scope-lexicals*)
*loop-scope-lexicals-captured*)))
`(ps-js:block ,@(reverse (cdr var-decls))
,@body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; lambda
(define-expression-operator lambda (lambda-list &rest body)
(multiple-value-bind (effective-args effective-body)
(parse-extended-function lambda-list body)
`(ps-js:lambda ,effective-args
,(let ((*function-block-names* ()))
(compile-function-body effective-args effective-body)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; named functions
(defun compile-named-function-body (name lambda-list body)
(let ((*enclosing-lexicals* (cons name *enclosing-lexicals*))
(*function-block-names* (list name)))
(multiple-value-bind (effective-args effective-body docstring)
(parse-extended-function lambda-list body)
(values effective-args
(compile-function-body effective-args effective-body)
docstring))))
(define-statement-operator defun% (name lambda-list &rest body)
(multiple-value-bind (effective-args body-block docstring)
(compile-named-function-body name lambda-list body)
(list 'ps-js:defun name effective-args docstring body-block)))
(defun maybe-rename-local-function (fun-name)
(or (getf *local-function-names* fun-name) fun-name))
(defun collect-function-names (fn-defs)
(loop for (fn-name) in fn-defs
collect fn-name
collect (if (or (member fn-name *enclosing-lexicals*)
(lookup-macro-def fn-name *symbol-macro-env*))
(ps-gensym (string fn-name))
fn-name)))
(defun compile-named-local-function (name args body)
(multiple-value-bind (args1 body-block)
(compile-named-function-body name args body)
`(ps-js:lambda ,args1 ,body-block)))
(defmacro local-functions (special-op &body bindings)
`(if in-function-scope?
(let* ((fn-renames (collect-function-names fn-defs))
,@bindings)
`(,(if compile-expression? 'ps-js:|,| 'ps-js:block)
,@definitions
,@(compile-progn body)))
(ps-compile (with-lambda-scope `(,',special-op ,fn-defs ,@body)))))
(defun compile-local-function-defs (fn-defs renames)
(loop for (fn-name . (args . body)) in fn-defs collect
(progn (when compile-expression?
(push (getf renames fn-name)
*vars-needing-to-be-declared*))
(list (if compile-expression? 'ps-js:= 'ps-js:var)
(getf renames fn-name)
(compile-named-local-function fn-name args body)))))
(define-expression-operator flet (fn-defs &rest body)
(local-functions flet
;; the function definitions need to be compiled with previous
;; lexical bindings
(definitions (compile-local-function-defs fn-defs fn-renames))
;; the flet body needs to be compiled with the extended
;; lexical environment
(*enclosing-lexicals* (append fn-renames *enclosing-lexicals*))
(*loop-scope-lexicals* (when in-loop-scope?
(append fn-renames *loop-scope-lexicals*)))
(*local-function-names* (append fn-renames *local-function-names*))))
(define-expression-operator labels (fn-defs &rest body)
(local-functions labels
(*enclosing-lexicals* (append fn-renames *enclosing-lexicals*))
(*loop-scope-lexicals* (when in-loop-scope?
(append fn-renames *loop-scope-lexicals*)))
(*local-function-names* (append fn-renames *local-function-names*))
(definitions (compile-local-function-defs fn-defs *local-function-names*))))
(define-expression-operator function (fn-name)
;; one of the things responsible for function namespace
(ps-compile (maybe-rename-local-function fn-name)))

1115
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/js-dom-symbol-exports.lisp Normal file
View file

File diff suppressed because it is too large Load diff

145
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/js-ir-package.lisp Normal file
View file

@ -0,0 +1,145 @@
;;; Copyright 2010, 2012 Vladimir Sedach
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(in-readtable :parenscript)
(defpackage #:ps-js
(:use)
(:export
;; operators
;; arithmetic
#:+
#:unary-plus
#:-
#:negate
#:*
#:/
#:%
;; bitwise
#:&
#:\|
#:^
#:~
#:>>
#:<<
#:>>>
;; assignment
#:=
#:+=
#:-=
#:*=
#:/=
#:%=
#:&=
#:\|=
#:^=
#:~=
#:>>=
#:<<=
#:>>>=
;; increment/decrement
#:++
#:--
#:post++
#:post--
;; comparison
#:==
#:===
#:!=
#:!==
#:>
#:>=
#:<
#:<=
;; logical
#:&&
#:\|\|
#:!
;; misc
#:? ;; ternary
#:|,|
#:delete
#:function
#:get
#:set
#:in
#:instanceof
#:new
#:typeof
#:void
;; literals
#:nil
#:t
#:false
#:undefined
#:this
;; statements
#:block
#:break
#:continue
#:do-while ; currently unused
#:for
#:for-in
#:if
#:label
#:return
#:switch
#:default
#:throw
#:try
#:var
#:while
#:with
#:array
#:aref
#:cond
#:lambda
#:defun
#:object
#:getprop
#:funcall
#:escape
#:regex
))

78
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/lib/ps-dom.lisp Normal file
View file

@ -0,0 +1,78 @@
;;; Copyright 2009-2010 Daniel Gackle
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
;; Utilities for accessing standard DOM functionality in a Lispier, PSier way.
(defpsmacro inner-html (el)
`(@ ,el 'inner-h-t-m-l))
(defpsmacro uri-encode (str)
`(if (null ,str) "" (encode-u-r-i-component ,str)))
(defpsmacro attribute (el attr)
`((@ ,el 'get-attribute) ,attr))
(defun assert-is-one-of (val options)
(unless (member val options)
(error "~s is not one of ~s" val options)))
(defpsmacro offset (what el)
(if (consp what)
`(offset ,(eval what) ,el)
(case what
((:top :left :height :width) `(@ ,el ,(intern (format nil "OFFSET-~a" what))))
(:right `(+ (offset :left ,el) (offset :width ,el)))
(:bottom `(+ (offset :top ,el) (offset :height ,el)))
(:hcenter `(+ (offset :left ,el) (/ (offset :width ,el) 2)))
(:vcenter `(+ (offset :top ,el) (/ (offset :height ,el) 2)))
(t (error "The OFFSET macro doesn't accept ~s as a key." what)))))
(defpsmacro scroll (what el)
(assert-is-one-of what '(:top :left :right :bottom :width :height))
(cond ((member what '(:top :left :width :height))
`(@ ,el ,(intern (format nil "SCROLL-~a" what))))
((eq what :right)
`(+ (scroll :left ,el) (offset :width ,el)))
((eq what :bottom)
`(+ (scroll :top ,el) (offset :height ,el)))))
(defpsmacro inner (what el)
(assert-is-one-of what '(:width :height))
`(@ ,el ,(intern (format nil "INNER-~a" what))))
(defpsmacro client (what el)
(assert-is-one-of what '(:width :height))
`(@ ,el ,(intern (format nil "CLIENT-~a" what))))

141
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/lib/ps-html.lisp Normal file
View file

@ -0,0 +1,141 @@
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005 Edward Marco Baringer
;;; Copyright 2007-2011 Vladimir Sedach
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(named-readtables:in-readtable :parenscript)
(defvar *ps-html-empty-tag-aware-p* t)
(defvar *ps-html-mode* :sgml "One of :sgml or :xml")
(defvar *html-empty-tags* '(:area :atop :audioscope :base :basefont :br :choose :col :frame
:hr :img :input :isindex :keygen :left :limittext :link :meta
:nextid :of :over :param :range :right :spacer :spot :tab :wbr))
(defun empty-tag-p (tag)
(and *ps-html-empty-tag-aware-p*
(member tag *html-empty-tags*)))
(defun concat-constant-strings (str-list)
(flet ((expand (expr)
(setf expr (ps-macroexpand expr))
(cond ((and (consp expr) (eq (car expr) 'quote) (symbolp (second expr)))
(symbol-to-js-string (second expr)))
((keywordp expr) (string-downcase expr))
((characterp expr) (string expr))
(t expr))))
(reverse (reduce (lambda (optimized-list next-expr)
(let ((next-obj (expand next-expr)))
(if (and (or (numberp next-obj) (stringp next-obj))
(stringp (car optimized-list)))
(cons (format nil "~a~a" (car optimized-list) next-obj) (cdr optimized-list))
(cons next-obj optimized-list))))
(cons () str-list)))))
(defun process-html-forms-lhtml (forms)
(let ((r ()))
(labels ((process-attrs (attrs)
(do (attr-test attr-name attr-val)
((not attrs))
(setf attr-name (pop attrs)
attr-test (when (not (keywordp attr-name))
(let ((test attr-name))
(setf attr-name (pop attrs))
test))
attr-val (pop attrs))
(if attr-test
(push `(if ,attr-test
(stringify ,(format nil " ~(~A~)=\"" attr-name) ,attr-val "\"")
"")
r)
(progn
(push (format nil " ~(~A~)=\"" attr-name) r)
(push attr-val r)
(push "\"" r)))))
(process-form% (tag attrs content)
(push (format nil "<~(~A~)" tag) r)
(process-attrs attrs)
(if (or content (not (empty-tag-p tag)))
(progn (push ">" r)
(map nil #'process-form content)
(push (format nil "</~(~A~)>" tag) r))
(progn (when (eql *ps-html-mode* :xml)
(push "/" r))
(push ">" r))))
(process-form (form)
(cond ((keywordp form) (process-form (list form)))
((atom form) (push form r))
((and (consp form) (keywordp (car form)))
(process-form% (car form) () (cdr form)))
((and (consp form) (consp (first form)) (keywordp (caar form)))
(process-form% (caar form) (cdar form) (cdr form)))
(t (push form r)))))
(map nil #'process-form forms)
(concat-constant-strings (reverse r)))))
(defun process-html-forms-cl-who (forms)
(let ((r ()))
(labels ((process-form (form)
(cond ((keywordp form) (process-form (list form)))
((atom form) (push form r))
((and (consp form) (keywordp (car form)))
(push (format nil "<~(~A~)" (car form)) r)
(labels ((process-attributes (el-body)
(when el-body
(if (keywordp (car el-body))
(progn
(push (format nil " ~(~A~)=\""
(car el-body)) r)
(push (cadr el-body) r)
(push "\"" r)
(process-attributes (cddr el-body)))
el-body))))
(let ((content (process-attributes (cdr form))))
(if (or content (not (empty-tag-p (car form))))
(progn (push ">" r)
(when content (map nil #'process-form content))
(push (format nil "</~(~A~)>" (car form)) r))
(progn (when (eql *ps-html-mode* :xml)
(push "/" r))
(push ">" r))))))
(t (push form r)))))
(map nil #'process-form forms)
(concat-constant-strings (reverse r)))))
(defmacro+ps ps-html (&rest html-forms)
`(stringify ,@(with-standard-io-syntax (process-html-forms-lhtml html-forms))))
(defmacro+ps who-ps-html (&rest html-forms)
`(stringify ,@(with-standard-io-syntax (process-html-forms-cl-who html-forms))))

457
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/lib/ps-loop.lisp Normal file
View file

@ -0,0 +1,457 @@
;;; Copyright 2009-2013 Daniel Gackle
;;; Copyright 2009-2012 Vladimir Sedach
;;; Copyright 2012, 2015 Boris Smilga
;;; Copyright 2018 Neil Lindquist
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(named-readtables:in-readtable :parenscript)
;;; bind and bind* - macros used for destructuring bindings in PS LOOP
(defun dot->rest (x)
(cond ((atom x) x)
((not (listp (cdr x))) ; dotted list
(list (dot->rest (car x)) '&rest (dot->rest (cdr x))))
(t (cons (dot->rest (car x)) (dot->rest (cdr x))))))
(defun property-bindings-p (x)
(when (consp x)
(every (lambda (y)
(or (keywordp y) ; standalone property name
(and (consp y) ; var name paired with property name
(= (length y) 2)
(symbolp (car y))
(not (keywordp (car y)))
(keywordp (cadr y)))))
x)))
(defun extract-bindings (x)
;; returns a pair of destructuring bindings and property bindings
(cond ((atom x) (list x nil))
((property-bindings-p x)
(let ((var (ps-gensym)))
(list var (list x var))))
(t (loop :for y :on x
:for (d p) = (extract-bindings (car y))
:collect d :into ds
:when p :append p :into ps
:finally (return (list ds ps))))))
(defun property-bindings (bindings expr body)
`(let ,(loop :for b :in bindings
:for (var p) = (cond ((consp b) b) ; var name paired with property name
(t (list (intern (string b)) b))) ; make var from prop
:collect `(,var (@ ,expr ,p)))
,@body))
(defpsmacro bind (bindings expr &body body)
(let ((bindings (dot->rest bindings)))
(destructuring-bind (d p)
(extract-bindings bindings)
(cond ((and (atom d)
(or (= (length bindings) 1)
(atom (ps-macroexpand expr))))
(property-bindings bindings expr body))
((atom d)
(with-ps-gensyms (var)
`(let ((,var ,expr))
(bind ,bindings ,var ,@body))))
((null p)
`(destructuring-bind ,bindings ,expr ,@body))
(t `(destructuring-bind ,d ,expr
(bind* ,p ,@body)))))))
(defpsmacro bind* (bindings &body body)
(cond ((= (length bindings) 2)
`(bind ,(car bindings) ,(cadr bindings) ,@body))
(t `(bind ,(car bindings) ,(cadr bindings)
(bind* ,(cddr bindings) ,@body)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *loop-keywords*
'(:named :for :repeat :with :while :until :initially :finally
:from :downfrom :to :below :downto :above :by :in :across :on := :then
:when :unless :if :else :end :do :doing :return
:sum :summing :collect :collecting :append :appending :count :counting
:minimize :minimizing :maximize :maximizing :map :mapping
:of :into))
(defun as-keyword (key)
(cond ((not (symbolp key)) key)
((keywordp key) key)
(t (intern (symbol-name key) :keyword)))))
(defmacro loop-case (key &body forms)
(loop :for (match . nil) :in forms
:for keys = (if (listp match) match (list match)) :do
(loop :for k :in keys :do
(assert (member k (append *loop-keywords* '(t otherwise)))
nil "~a isn't a recognized loop keyword." k)))
`(case (as-keyword ,key) ,@forms))
(defun err (expected got)
(error "PS-LOOP expected ~a, got ~a." expected got))
(defclass loop-state ()
((tokens :initarg :tokens :accessor tokens)
(name :initform nil :accessor name)
;; A clause is either (:BODY FORM) or (:ITER PLACE INIT STEP TEST &OPTIONAL JS-OBJ)
(clauses :initform nil :accessor clauses)
(prologue :initform nil :accessor prologue)
(finally :initform nil :accessor finally)
(accum-var :initform nil :accessor accum-var)
(accum-kind :initform nil :accessor accum-kind)))
(defun push-body-clause (clause state)
(push (list :body clause) (clauses state)))
(defun push-iter-clause (clause state)
(push (cons :iter clause) (clauses state)))
(defun push-tokens (state toks)
(setf (tokens state) (append toks (tokens state))))
(defun peek (state)
(car (tokens state)))
(defun eat (state &optional what tag)
"Consumes the next meaningful chunk of loop for processing."
(case what
(:if (when (eq (as-keyword (peek state)) tag)
(eat state)
(values (eat state) t)))
(:progn (cons 'progn (loop :collect (if (consp (peek state))
(eat state)
(err "a compound form" (peek state)))
:until (atom (peek state)))))
(otherwise (let ((tok (pop (tokens state))))
(when (and (eq what :atom) (not (atom tok)))
(err "an atom" tok))
(when (and (eq what :symbol) (not (symbolp tok)))
(err "a symbol" tok))
tok))))
(defun maybe-hoist (expr state)
(cond ((complex-js-expr? expr)
(let ((var (ps-gensym)))
(push (list 'setf var expr) (prologue state))
var))
(t expr)))
(defun for-from (from-key var state)
(unless (atom var)
(err "an atom after FROM" var))
(let ((start (eat state))
(op (loop-case from-key (:downfrom '-) (otherwise '+)))
(test-op (loop-case from-key (:downfrom '>=) (otherwise '<=)))
(by nil)
(end nil))
(loop while (member (as-keyword (peek state)) '(:to :below :downto :above :by)) do
(let ((term (eat state)))
(if (eq (as-keyword term) :by)
(setf by (eat state))
(setf op (loop-case term ((:downto :above) '-) (otherwise op))
test-op (loop-case term (:to test-op) (:below '<) (:downto '>=) (:above '>))
end (eat state)))))
(let ((test (when test-op
(list test-op var (maybe-hoist end state)))))
(push-iter-clause `(,var ,start (,op ,var ,(or by 1)) ,test) state))))
(defun for-= (place state)
(let ((start (eat state)))
(multiple-value-bind (then thenp)
(eat state :if :then)
(push-iter-clause (list place start (if thenp then start) nil) state))))
(defun for-in (place state)
(let ((arr (maybe-hoist (eat state) state))
(index (ps-gensym)))
(push-tokens state `(,index :from 0 :below (length ,arr)
,place := (aref ,arr ,index)))
(for-clause state)
(for-clause state)))
(defun for-on (place state)
(let* ((arr (eat state))
(by (or (eat state :if :by) 1))
(var (if (atom place) place (ps-gensym)))
(then (if (numberp by) `((@ ,var :slice) ,by) `(,by ,var))))
(push-tokens state `(,var := ,arr :then ,then))
(for-clause state)
;; set the end-test by snooping into the iteration clause we just added
(setf (fifth (car (clauses state))) `(> (length ,var) 0))
(unless (eq place var)
(push-tokens state `(,place := ,var))
(for-clause state))))
(defun for-keys-of (place state)
(when (clauses state)
(error "FOR..OF is only allowed as the first clause in a loop."))
(when (consp place)
(unless (<= (length place) 2) ; length 1 is ok, treat (k) as (k nil)
(error "FOR..OF must be followed by a key variable or key-value pair."))
(unless (atom (first place))
(error "The key in a FOR..OF clause must be a variable.")))
(let ((k (or (if (atom place) place (first place)) (ps-gensym)))
(v (when (consp place) (second place))))
(let ((js-obj (eat state)))
(when v ; assign JS-OBJ to a local var if we need to for value binding (otherwise inline it)
(setf js-obj (maybe-hoist js-obj state)))
(push-iter-clause (list k nil nil nil js-obj) state)
(when v
(let ((val `(getprop ,js-obj ,k)))
(push-iter-clause (list v val val nil) state))))))
(defun for-clause (state)
(let ((place (eat state))
(term (eat state :atom)))
(loop-case term
((:from :downfrom) (for-from term place state))
(:= (for-= place state))
((:in :across) (for-in place state))
(:on (for-on place state))
(:of (for-keys-of place state))
(otherwise (error "FOR ~s ~s is not valid in PS-LOOP." place term)))))
(defun a-with-clause (state) ;; so named to avoid with-xxx macro convention
(let ((place (eat state)))
(push (list 'setf place (eat state :if :=)) (prologue state))))
(defun accumulate (kind item var state)
(when (null var)
(when (and (accum-kind state) (not (eq kind (accum-kind state))))
(error "PS-LOOP encountered illegal ~a: ~a was already declared, and there can only be one kind of implicit accumulation per loop." kind (accum-kind state)))
(unless (accum-var state)
(setf (accum-var state)
(ps-gensym (string (loop-case kind
((:minimize :minimizing) 'min)
((:maximize :maximizing) 'max)
(t kind)))))
(setf (accum-kind state) kind))
(setf var (accum-var state)))
(let ((initial (loop-case kind
((:sum :summing :count :counting) 0)
((:maximize :maximizing :minimize :minimizing) nil)
((:collect :collecting :append :appending) '[])
((:map :mapping) '{}))))
(push (list 'setf var initial) (prologue state)))
(loop-case kind
((:sum :summing)`(incf ,var ,item))
((:count :counting)`(when ,item (incf ,var))) ;; note the JS semantics - neither 0 nor "" will count
((:minimize :minimizing) `(setf ,var (if (null ,var) ,item (min ,var ,item))))
((:maximize :maximizing) `(setf ,var (if (null ,var) ,item (max ,var ,item))))
((:collect :collecting) `((@ ,var 'push) ,item))
((:append :appending) `(setf ,var (append ,var ,item)))
((:map :mapping) (destructuring-bind (key val) item
`(setf (getprop ,var ,key) ,val)))))
(defun repeat-clause (state)
(let ((index (ps-gensym)))
(setf (tokens state) (append `(,index :from 0 :below ,(eat state)) (tokens state)))
(for-clause state)))
(defun while-clause (state)
(push-iter-clause (list nil nil nil (eat state)) state))
(defun until-clause (state)
(push-iter-clause (list nil nil nil `(not ,(eat state))) state))
(defun body-clause (term state)
(loop-case term
((:if :when :unless)
(let* ((test-form (eat state))
(seqs (list (body-clause (eat state :atom) state)))
(alts (list)))
(loop while (eq (as-keyword (peek state)) :and)
do (eat state)
(push (body-clause (eat state :atom) state) seqs))
(when (eq (as-keyword (peek state)) :else)
(eat state)
(push (body-clause (eat state :atom) state) alts)
(loop while (eq (as-keyword (peek state)) :and)
do (eat state)
(push (body-clause (eat state :atom) state) alts)))
(when (eq (as-keyword (peek state)) :end)
(eat state))
(if (null alts)
`(,(loop-case term ((:unless) 'unless) (otherwise 'when))
,test-form
,@(reverse seqs))
`(if ,(loop-case term
((:unless) `(not ,test-form))
(otherwise test-form))
(progn ,@(reverse seqs))
(progn ,@(reverse alts))))))
((:sum :summing :collect :collecting :append :appending :count :counting
:minimize :minimizing :maximize :maximizing)
(accumulate term (eat state) (eat state :if :into) state))
((:map :mapping) (let ((key (eat state)))
(multiple-value-bind (val valp)
(eat state :if :to)
(unless valp
(error "MAP must be followed by a TO to specify value."))
(accumulate :map (list key val) (eat state :if :into) state))))
((:do :doing) (eat state :progn))
(:return `(return-from ,(name state) ,(eat state)))
(otherwise (err "a PS-LOOP keyword" term))))
(defun clause (state)
(let ((term (eat state :atom)))
(loop-case term
(:named (setf (name state) (eat state :symbol)))
(:with (a-with-clause state))
(:initially (push (eat state :progn) (prologue state)))
(:for (for-clause state))
(:repeat (repeat-clause state))
(:while (while-clause state))
(:until (until-clause state))
(:finally (push (eat state :progn) (finally state)))
(otherwise (push-body-clause (body-clause term state) state)))))
(defun parse-ps-loop (terms)
(cond ((null terms) (err "loop definition" nil))
(t (let ((state (make-instance 'loop-state :tokens terms)))
(loop :while (tokens state) :do (clause state))
state))))
(defun fold-iterations-where-possible (clauses)
(let ((folded '()))
(loop :for clause :in clauses :do
(assert (member (car clause) '(:iter :body)))
(let ((folded? nil))
(when (and (eq (car clause) :iter) (eq (caar folded) :iter))
(destructuring-bind (tag place init step test &optional js-obj) clause
(declare (ignore tag))
(when (null place) ;; can't combine two iterations that both have state
(assert (not (or init step js-obj)) nil "Invalid iteration ~a: PLACE should not be null." clause)
(assert test nil "Iteration ~a has neither PLACE nor TEST." clause)
(unless (sixth (car folded)) ;; js-obj means a for..in loop and those can't have tests
(let ((prev-test (fifth (car folded))))
(setf (fifth (car folded)) (if prev-test `(and ,prev-test ,test) test))
(setf folded? t))))))
(unless folded?
(push clause folded))))
(nreverse folded)))
(defun organize-iterations (clauses)
;; we want clauses to start with a master loop to provide the
;; skeleton for everything else. secondary iterations are ok but
;; will be generated inside the body of this master loop
(unless (eq (caar clauses) :iter)
(push (list :iter nil nil nil t) clauses))
;; unify adjacent test expressions by ANDing them together where possible
(setf clauses (fold-iterations-where-possible clauses))
;; if leading iteration has a binding expression, replace it with a var
(destructuring-bind (tag place init step test &optional js-obj) (car clauses)
(assert (eq tag :iter))
(when (complex-js-expr? place)
(assert (null js-obj) nil "Invalid iteration ~a: FOR..IN can't have a binding expression." (car clauses))
(let ((var (ps-gensym)))
(pop clauses)
(push (list :iter place var var nil) clauses)
(push (list :iter var init step test) clauses))))
clauses)
(defun build-body (clauses firstvar)
(cond ((null clauses) nil)
((eq (caar clauses) :body)
(cons (second (car clauses)) (build-body (cdr clauses) firstvar)))
(t (destructuring-bind (tag place init step test) (car clauses)
(assert (eq tag :iter))
(let ((body (build-body (cdr clauses) firstvar)))
(when test
(push `(unless ,test (break)) body))
(when place
(let ((expr (if (tree-equal init step) init `(if ,firstvar ,init ,step))))
(setf body
(cond ((and (atom place) (eq expr init))
`((let ((,place ,expr)) ,@body)))
;; can't use LET because EXPR may reference PLACE
((atom place) `((var ,place ,expr) ,@body))
;; BIND has scoping problems. For example,
;; (loop :for (a b) = x :then b) doesn't work
;; since EXPR is referencing part of PLACE.
;; But the following is ok for known uses so far.
(t `((bind ,place ,expr ,@body)))))))
body)))))
(define-statement-operator loop-while (test &rest body)
`(ps-js:while ,(compile-expression test)
,(compile-loop-body () body)))
(defun master-loop (master-iter body)
(destructuring-bind (tag place init step test &optional js-obj) master-iter
(assert (eq tag :iter))
(cond ((null place) `(loop-while ,test ,@body))
(js-obj
(assert (not (or init step test)) nil "Unexpected iteration state in for..in loop: ~a" master-iter)
`(for-in (,place ,js-obj) ,@body))
(t (assert (atom place) nil "Unexpected destructuring list ~a in master loop" place)
`(for ((,place ,init)) (,(or test t)) ((setf ,place ,step)) ,@body)))))
(defun build-loop (clauses)
(destructuring-bind (master . rest) clauses
(assert (eq (car master) :iter) nil "First clause is not master loop: ~a" master)
(let* ((firstvar (loop :for (tag nil init step) :in rest
:when (and (eq tag :iter) (not (tree-equal init step)))
:do (return (ps-gensym 'FIRST))))
(body (build-body rest firstvar)))
(when firstvar
(setf body (append body `((setf ,firstvar nil)))))
(let ((form (master-loop master body)))
(if firstvar `(let ((,firstvar t)) ,form) form)))))
(defun prologue-wrap (prologue body)
(cond ((null prologue) body)
((equal 'setf (caar prologue))
(destructuring-bind (place expr) (cdr (car prologue))
(prologue-wrap
(cdr prologue)
(cond ((atom place) (cons `(var ,place ,expr) body))
(t `((bind ,place ,expr ,@body)))))))
(t (prologue-wrap
(cdr prologue)
(cons (car prologue) body)))))
(defpsmacro loop (&rest keywords-and-forms)
(let ((state (parse-ps-loop keywords-and-forms)))
(let* ((clauses (organize-iterations (reverse (clauses state))))
(main `(,(build-loop (organize-iterations clauses))
,@(reverse (finally state))
,@(awhen (accum-var state) (list it))))
(full `(block ,(name state) ,@(prologue-wrap (prologue state) main))))
(if (accum-var state)
(with-lambda-scope full)
full))))

548
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/macros.lisp Normal file
View file

@ -0,0 +1,548 @@
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2006 Luca Capello
;;; Copyright 2010-2012 Vladimir Sedach
;;; Copyright 2010-2013 Daniel Gackle
;;; Copyright 2012, 2014 Boris Smilga
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(in-readtable :parenscript)
(macrolet ((define-trivial-mappings (&rest mappings)
`(progn
,@(loop for (macro-name ps-op) on mappings by #'cddr collect
`(defpsmacro ,macro-name (&rest args)
(cons ',ps-op args))))))
(define-trivial-mappings
string= eql
eq eql
= eql
list array
elt aref))
(defpsmacro null (x)
`(equal ,x nil))
;;; Math
(defmacro def-js-maths (&rest mathdefs)
`(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs)))
(def-js-maths
(max (&rest nums) `((@ *math max) ,@nums))
(min (&rest nums) `((@ *math min) ,@nums))
(floor (n &optional divisor)
`((@ *math floor) ,(if divisor `(/ ,n ,divisor) n)))
(ceiling (n &optional divisor)
`((@ *math ceil) ,(if divisor `(/ ,n ,divisor) n)))
(round (n &optional divisor)
`((@ *math round) ,(if divisor `(/ ,n ,divisor) n)))
(sin (n) `((@ *math sin) ,n))
(cos (n) `((@ *math cos) ,n))
(tan (n) `((@ *math tan) ,n))
(asin (n) `((@ *math asin) ,n))
(acos (n) `((@ *math acos) ,n))
(atan (y &optional x) (if x `((@ *math atan2) ,y ,x) `((@ *math atan) ,y)))
(sinh (x)
(maybe-once-only (x)
`(/ (- (exp ,x) (exp (- ,x))) 2)))
(cosh (x)
(maybe-once-only (x)
`(/ (+ (exp ,x) (exp (- ,x))) 2)))
(tanh (x)
(maybe-once-only (x)
`(/ (- (exp ,x) (exp (- ,x))) (+ (exp ,x) (exp (- ,x))))))
(asinh (x)
(maybe-once-only (x)
`(log (+ ,x (sqrt (1+ (* ,x ,x)))))))
(acosh (x)
(maybe-once-only (x)
`(* 2 (log (+ (sqrt (/ (1+ ,x) 2)) (sqrt (/ (1- ,x) 2)))))))
(atanh (x) ;; real only for -1 < x < 1, otherwise complex
(maybe-once-only (x)
`(/ (- (log (+ 1 ,x)) (log (- 1 ,x))) 2)))
(mod (x n)
(maybe-once-only (n)
`(rem (+ (rem ,x ,n) ,n) ,n)))
(1+ (n) `(+ ,n 1))
(1- (n) `(- ,n 1))
(abs (n) `((@ *math abs) ,n))
(evenp (n) `(not (oddp ,n)))
(oddp (n) `(rem ,n 2))
(exp (n) `((@ *math exp) ,n))
(expt (base power) `((@ *math pow) ,base ,power))
(log (n &optional base)
(or (and (null base) `((@ *math log) ,n))
(and (numberp base) (= base 10) `(* (log ,n) (@ *math *log10e*)))
`(/ (log ,n) (log ,base))))
(sqrt (n) `((@ *math sqrt) ,n))
(random (&optional upto) (if upto
(maybe-once-only (upto)
`(if (rem ,upto 1)
(* ,upto (random))
(floor (* ,upto (random)))))
'(funcall (@ *math random)))))
(defpsmacro ash (integer count)
(let ((count (ps-macroexpand count)))
(cond ((and (numberp count) (> count 0)) `(<< ,integer ,count))
((numberp count) `(>> ,integer ,(- count)))
((complex-js-expr? count)
(let ((count-var (ps-gensym)))
`(let ((,count-var ,count))
(if (> ,count-var 0)
(<< ,integer ,count-var)
(>> ,integer (- ,count-var))))))
(t `(if (> ,count 0)
(<< ,integer ,count)
(>> ,integer (- ,count)))))))
(define-ps-symbol-macro pi (getprop *math '*pi*))
;;; Types
(defpsmacro stringp (x)
`(string= (typeof ,x) "string"))
(defpsmacro numberp (x)
`(string= (typeof ,x) "number"))
(defpsmacro functionp (x)
`(string= (typeof ,x) "function"))
(defpsmacro booleanp (x)
`(string= (typeof ,x) "boolean"))
(defpsmacro listp (x)
(if (js-target-at-least "1.8.5")
`(funcall (getprop Array 'is-array) ,x)
`(string= (funcall (getprop Object 'prototype 'to-string 'call) ,x)
"[object Array]")))
(defpsmacro arrayp (x)
`(listp ,x))
;;; Data structures
(defpsmacro make-array (&rest args)
(or (ignore-errors
(destructuring-bind (dim &key (initial-element nil initial-element-p)
initial-contents element-type)
args
(declare (ignore element-type))
(and (or initial-element-p initial-contents)
(not (and initial-element-p initial-contents))
(with-ps-gensyms (arr init elt i)
`(let ((,arr (new (*array ,dim))))
,@(when initial-element-p
`((let ((,elt ,initial-element))
(dotimes (,i (length ,arr))
(setf (aref ,arr ,i) ,elt)))))
,@(when initial-contents
`((let ((,init ,initial-contents))
(dotimes (,i (min (length ,arr) (length ,init)))
(setf (aref ,arr ,i) (aref ,init ,i))))))
,arr)))))
`(new (*array ,@args))))
(defpsmacro length (a)
`(getprop ,a 'length))
;;; Getters
(defpsmacro with-slots (slots object &rest body)
(flet ((slot-var (slot)
(if (listp slot)
(first slot)
slot))
(slot-symbol (slot)
(if (listp slot)
(second slot)
slot)))
(maybe-once-only (object)
`(symbol-macrolet ,(mapcar (lambda (slot)
`(,(slot-var slot) (getprop ,object ',(slot-symbol slot))))
slots)
,@body))))
;;; multiple values
(defpsmacro multiple-value-bind (vars form &body body)
(let* ((form (ps-macroexpand form))
(progn-form (when (and (consp form)
(member (car form)
'(with label let flet labels
macrolet symbol-macrolet progn)))
(pop form))))
(if progn-form
`(,progn-form
,@(butlast form)
(multiple-value-bind ,vars
,@(last form)
,@body))
;; assume function call
`(progn
(setf __PS_MV_REG '())
(let ((,(car vars) ,form))
(destructuring-bind (&optional ,@(cdr vars))
__PS_MV_REG
,@body))))))
(defpsmacro multiple-value-list (form)
(with-ps-gensyms (first-value values-list)
`(let* ((,first-value (progn
(setf __PS_MV_REG '())
,form))
(,values-list (funcall (getprop __PS_MV_REG 'slice))))
(funcall (getprop ,values-list 'unshift) ,first-value)
,values-list)))
;;; conditionals
(defpsmacro case (value &rest clauses)
(labels
((make-switch-clause (val body more)
(if (consp val)
(append (mapcar #'list (butlast val))
(make-switch-clause
(if (eq t (car (last val))) ;; literal 'true'
'%true
(car (last val)))
body
more))
`((,(cond ((member val '(t otherwise)) 'default)
((eql val '%true) t)
((eql val 'false) 'false)
((null val) 'false)
((symbolp val) (list 'quote val))
(t val))
,@body
,@(when more '(break)))))))
`(switch ,value
,@(mapcon (lambda (clause)
(make-switch-clause (car (first clause))
(cdr (first clause))
(rest clause)))
clauses))))
(defpsmacro when (test &rest body)
`(if ,test (progn ,@body)))
(defpsmacro unless (test &rest body)
`(when (not ,test) ,@body))
;;; function definition
(defpsmacro defun (name lambda-list &body body)
"An extended defun macro that allows cool things like keyword arguments.
lambda-list::=
(var*
[&optional {var | (var [init-form [supplied-p-parameter]])}*]
[&rest var]
[&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
[&aux {var | (var [init-form])}*])"
(if (symbolp name)
(progn (setf (gethash name *function-lambda-list*) lambda-list)
`(defun% ,name ,lambda-list ,@body))
(progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) ()
"(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
`(defun-setf ,(second name) ,lambda-list ,@body))))
;;; defining setf expanders
(defvar *defun-setf-name-prefix* '__setf_)
(defpsmacro defun-setf (name lambda-list &body body)
(let ((mangled-function-name
(intern (format nil "~A~A" (string *defun-setf-name-prefix*) (string name))
(symbol-package name))))
(setf (gethash name *setf-expanders*)
(lambda (access-args store-form)
`(,mangled-function-name ,store-form ,@access-args)))
`(defun ,mangled-function-name ,lambda-list ,@body)))
;;; slightly broken WRT lambda lists
(defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
(setf (gethash access-fn *setf-expanders*)
(compile
nil
(let ((var-bindings (ordered-set-difference lambda-list
lambda-list-keywords)))
`(lambda (access-fn-args store-form)
(destructuring-bind ,lambda-list
access-fn-args
(let* ((,store-var (ps-gensym))
(gensymed-names (loop repeat ,(length var-bindings)
collecting (ps-gensym)))
(gensymed-arg-bindings (mapcar #'list
gensymed-names
(list ,@var-bindings))))
(destructuring-bind ,var-bindings
gensymed-names
`(let* (,@gensymed-arg-bindings
(,,store-var ,store-form))
,,form))))))))
nil)
(defpsmacro defsetf-short (access-fn update-fn &optional docstring)
(declare (ignore docstring))
(setf (gethash access-fn *setf-expanders*)
(lambda (access-fn-args store-form)
`(,update-fn ,@access-fn-args ,store-form)))
nil)
(defpsmacro defsetf (access-fn &rest args)
`(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
;;; setf
(defpsmacro setf (&rest args)
(assert (evenp (length args)) ()
"~s does not have an even number of arguments." `(setf ,args))
`(progn ,@(loop for (place value) on args by #'cddr collect
(aif (and (listp place) (gethash (car place) *setf-expanders*))
(funcall it (cdr place) value)
`(ps-assign ,place ,value)))))
(defpsmacro psetf (&rest args)
(let ((places (loop for x in args by #'cddr collect x))
(vals (loop for x in (cdr args) by #'cddr collect x)))
(let ((gensyms (loop repeat (length places) collect (ps-gensym))))
`(let ,(mapcar #'list gensyms vals)
(setf ,@(mapcan #'list places gensyms))))))
(defun check-setq-args (args)
(let ((vars (loop for x in args by #'cddr collect x)))
(let ((non-var (find-if (complement #'symbolp) vars)))
(when non-var
(error 'type-error :datum non-var :expected-type 'symbol)))))
(defpsmacro setq (&rest args)
(check-setq-args args)
`(setf ,@args))
(defpsmacro psetq (&rest args)
(check-setq-args args)
`(psetf ,@args))
;;; iteration
(defun do-make-iteration-bindings (decls)
(mapcar (lambda (x)
(cond ((atom x) x)
((endp (cdr x)) (list (car x)))
(t (subseq x 0 2))))
decls))
(defun do-make-for-steps (decls)
(mapcar (lambda (x)
`(setf ,(first x) ,(third x)))
(remove-if (lambda (x)
(or (atom x) (< (length x) 3)))
decls)))
(defun do-make-iter-psteps (decls)
`(psetq
,@(mapcan (lambda (x)
(list (first x) (third x)))
(remove-if (lambda (x)
(or (atom x) (< (length x) 3)))
decls))))
(defpsmacro do* (decls (end-test &optional (result nil result?)) &body body)
`(block nil
(for ,(do-make-iteration-bindings decls)
((not ,end-test))
,(do-make-for-steps decls)
(locally ,@body))
,@(when result? (list result))))
(defpsmacro do (decls (end-test &optional (result nil result?)) &body body)
(multiple-value-bind (do-body declarations)
(parse-body body)
`(block nil
(let ,(do-make-iteration-bindings decls)
,@declarations
(for () ((not ,end-test)) ()
,@do-body
,(do-make-iter-psteps decls))
,@(when result? (list result))))))
(defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
`(do* ((,var 0 (1+ ,var)))
((>= ,var ,count)
,@(when result? `((let ((,var nil)) ,result))))
,@body))
(defpsmacro dolist ((var array &optional (result nil result?)) &body body)
(let* ((idx (ps-gensym '_js_idx))
(introduce-array-var? (not (symbolp array)))
(arrvar (if introduce-array-var?
(ps-gensym '_js_arrvar)
array)))
`(do* (,var
,@(when introduce-array-var?
(list (list arrvar array)))
(,idx 0 (1+ ,idx)))
((>= ,idx (getprop ,arrvar 'length))
,@(when result? `((let ((,var nil)) ,result))))
(setq ,var (aref ,arrvar ,idx))
,@body)))
;;; Concatenation
(defpsmacro concatenate (result-type &rest sequences)
(assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.")
(cons '+ sequences))
(defpsmacro append (arr1 &rest arrs)
(if arrs
`((@ ,arr1 concat) ,@arrs)
arr1))
;;; Destructuring bind
(defun complex-js-expr? (expr)
(consp (if (symbolp expr) (ps-macroexpand expr) expr)))
(defun hoist-expr? (bindings expr)
(and (> (length bindings) 1) (complex-js-expr? expr)))
(defun pop-declarations-for-var (var declarations)
(loop for declarations* on declarations
with var-declarations = nil
do (setf (first declarations*)
(loop for spec in (first declarations*)
;; We only care for SPECIAL declarations for now
;; (cf. WITH-DECLARATION-EFFECTS)
if (and (consp spec) (eq 'special (first spec)))
collect
(let ((vars* (remove var (rest spec))))
(if (eq vars* (cdr spec))
spec
(progn
(pushnew var (getf var-declarations 'special))
(cons 'special vars*))))
else
collect spec))
finally (return
(loop for (sym decls) on var-declarations by #'cddr
collect (cons sym decls)))))
(defun destructuring-wrap (arr n bindings declarations body)
(cond ((null bindings) body)
((eq (car bindings) '&rest)
(cond ((and (= (length bindings) 2) (atom (second bindings)))
`(let ((,(second bindings) (if (> (length ,arr) ,n) ((@ ,arr slice) ,n) '())))
(declare ,@(pop-declarations-for-var (second bindings) declarations))
,body))
(t (error "~a is invalid in destructuring list." bindings))))
((eq (car bindings) '&optional)
(destructuring-wrap arr n (cdr bindings) declarations body))
(t (let ((var (car bindings))
(inner-body (destructuring-wrap arr (1+ n) (cdr bindings) declarations body)))
(cond ((null var) inner-body)
((atom var) `(let ((,var (aref ,arr ,n)))
(declare ,@(pop-declarations-for-var var declarations))
,inner-body))
(t `(,'destructuring-bind ,var (aref ,arr ,n)
,@declarations
,inner-body)))))))
(defpsmacro destructuring-bind (bindings expr &body body)
(setf bindings (dot->rest bindings))
(multiple-value-bind (body1 declarations) (parse-body body)
(let* ((arr (if (hoist-expr? bindings expr) (ps-gensym '_db) expr))
(bound (destructuring-wrap arr 0 bindings declarations
(cons 'progn body1))))
(cond ((eq arr expr) bound)
(t `(let ((,arr ,expr)) ,bound))))))
;;; Control structures
(defpsmacro return (&optional result)
`(return-from nil ,result))
(defpsmacro ignore-errors (&body forms)
(with-ps-gensyms (e)
`(try (progn ,@forms)
(:catch (,e) nil))))
(defpsmacro unwind-protect (protected-form cleanup-form)
`(try ,protected-form
(:finally ,cleanup-form)))
(defpsmacro prog1 (first &rest others)
(with-ps-gensyms (val)
`(let ((,val (multiple-value-list ,first)))
,@others
(values-list ,val))))
(defpsmacro prog2 (first second &rest others)
`(progn ,first (prog1 ,second ,@others)))
(defpsmacro apply (fn &rest args)
(let ((arglist (if (> (length args) 1)
`(append (list ,@(butlast args)) ,(car (last args)))
(first args))))
(if (and (listp fn)
(find (car fn) #(getprop chain @)))
(if (and (= (length fn) 3) (symbolp (second fn)))
`(funcall (getprop ,fn 'apply) ,(second fn) ,arglist)
(let ((obj (ps-gensym)) (method (ps-gensym)))
`(let* ((,obj ,(butlast fn))
(,method (,(car fn) ,obj ,(car (last fn)))))
(funcall (getprop ,method 'apply) ,obj ,arglist))))
`(funcall (getprop ,fn 'apply) this ,arglist))))
;;; misc
(defpsmacro let* (bindings &body body)
(multiple-value-bind (let-body declarations) (parse-body body)
(loop for binding in (cons nil (reverse bindings))
for var = (if (symbolp binding) binding (car binding))
for body = let-body
then `((let (,binding)
(declare ,@(pop-declarations-for-var var declarations))
,@body))
finally (return `(progn ,@body)))))
(defpsmacro in-package (package-designator)
`(eval-when (:compile-toplevel)
(in-package ,package-designator)))
(defpsmacro use-package (package-designator &optional package)
`(eval-when (:compile-toplevel)
(use-package ,package-designator ,@(when package (list package)))))

73
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/namespace.lisp Normal file
View file

@ -0,0 +1,73 @@
;;; Copyright 2007-2010 Vladimir Sedach
;;; Copyright 2008 Travis Cross
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(in-readtable :parenscript)
(defvar *obfuscated-packages* (make-hash-table))
(defun obfuscate-package (package-designator &optional symbol-map)
(setf (gethash (find-package package-designator)
*obfuscated-packages*)
(or symbol-map
(let ((symbol-table (make-hash-table)))
(lambda (symbol)
(or (gethash symbol symbol-table)
(setf (gethash symbol symbol-table)
(ps-gensym 'g))))))))
(defun unobfuscate-package (package-designator)
(remhash (find-package package-designator) *obfuscated-packages*))
(defun maybe-obfuscate-symbol (symbol)
(if (aand (symbol-package symbol) (eq :external (nth-value 1 (find-symbol (symbol-name symbol) it))))
symbol
(aif (gethash (symbol-package symbol) *obfuscated-packages*)
(funcall it symbol)
symbol)))
(defvar *package-prefix-table* (make-hash-table))
(defmacro ps-package-prefix (package)
`(gethash (find-package ,package) *package-prefix-table*))
(defun symbol-to-js-string (symbol &optional (mangle-symbol-name? t))
(let* ((symbol-name (symbol-name (maybe-obfuscate-symbol symbol)))
(identifier (if mangle-symbol-name?
(encode-js-identifier symbol-name)
symbol-name)))
(aif (ps-package-prefix (symbol-package symbol))
(concatenate 'string it identifier)
identifier)))

247
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/non-cl.lisp Normal file
View file

@ -0,0 +1,247 @@
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2006 Luca Capello
;;; Copyright 2010-2012 Vladimir Sedach
;;; Copyright 2012, 2014, 2015 Boris Smilga
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(in-readtable :parenscript)
;;; PS operators and macros that aren't present in the Common Lisp
;;; standard but exported by Parenscript, and their Common Lisp
;;; equivalent definitions
(defmacro define-trivial-special-ops (&rest mappings)
`(progn ,@(loop for (form-name js-primitive) on mappings by #'cddr collect
`(define-expression-operator ,form-name (&rest args)
(cons ',js-primitive (mapcar #'compile-expression args))))))
(define-trivial-special-ops
array ps-js:array
instanceof ps-js:instanceof
typeof ps-js:typeof
new ps-js:new
delete ps-js:delete
in ps-js:in ;; maybe rename to slot-boundp?
break ps-js:break
<< ps-js:<<
>> ps-js:>>
)
(define-statement-operator continue (&optional label)
`(ps-js:continue ,label))
(define-statement-operator switch (test-expr &rest clauses)
`(ps-js:switch ,(compile-expression test-expr)
,@(let ((in-case? t))
(loop for (val . body) in clauses collect
(cons (if (eq val 'default)
'ps-js:default
(compile-expression val))
(flatten-blocks
(mapcar #'compile-statement body)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; objects
(define-expression-operator create (&rest arrows)
(let ((allow-accessors (js-target-at-least "1.8.5")))
(cons
'ps-js:object
(loop for (key val-expr) on arrows by #'cddr
for (accessor . accessor-args) =
(when (and allow-accessors
(consp key)
(symbolp (first key))
(symbolp (second key)))
(case (first key)
(get (and (null (third key))
`((ps-js:get ,(second key)))))
(set (and (symbolp (third key)) (null (fourth key))
`((ps-js:set ,(second key)) ,(third key))))))
collecting
(if accessor
(list accessor accessor-args
(let ((*function-block-names* ()))
(compile-function-body (third accessor)
(list val-expr))))
(cons (cond ((and (symbolp key) (reserved-symbol-p key))
(reserved-symbol-p key))
((or (stringp key) (numberp key) (symbolp key))
key)
((and (consp key)
(eq 'quote (first key))
(symbolp (second key))
(null (third key)))
(symbol-to-js-string (second key)))
(t
(error "Slot key ~s is not one of ~
~{~a~#[~;, or ~:;, ~]~}."
key
(list* "symbol" "string" "number"
(when allow-accessors
'("accessor spec"))))))
(compile-expression val-expr)))))))
(define-expression-operator %js-getprop (obj slot)
(let ((expanded-slot (ps-macroexpand slot))
(obj (compile-expression obj)))
(if (and (listp expanded-slot)
(eq 'quote (car expanded-slot)))
(aif (or (reserved-symbol-p (second expanded-slot))
(and (keywordp (second expanded-slot)) (second expanded-slot)))
`(ps-js:aref ,obj ,it)
`(ps-js:getprop ,obj ,(second expanded-slot)))
`(ps-js:aref ,obj ,(compile-expression slot)))))
(defpsmacro getprop (obj &rest slots)
(if (null (rest slots))
`(%js-getprop ,obj ,(first slots))
`(getprop (getprop ,obj ,(first slots)) ,@(rest slots))))
(defpsmacro @ (obj &rest props)
"Handy getprop/aref composition macro."
(if props
`(@ (getprop ,obj ,(if (symbolp (car props))
`',(car props)
(car props)))
,@(cdr props))
obj))
(defun chain (method-calls)
(let ((chain (car method-calls)))
(dolist (next (cdr method-calls))
(setf chain (if (consp next)
`(funcall (@ ,chain ,(car next)) ,@(cdr next))
`(@ ,chain ,next))))
chain))
(defpsmacro chain (&rest method-calls)
(chain method-calls))
;;; var
(define-expression-operator var (name &optional (value (values) value?) docstr)
(declare (ignore docstr))
(push name *vars-needing-to-be-declared*)
(when value? (compile-expression `(setf ,name ,value))))
(define-statement-operator var (name &optional (value (values) value?) docstr)
(let ((value (ps-macroexpand value)))
(if (and (listp value) (eq 'progn (car value)))
(ps-compile `(progn ,@(butlast (cdr value))
(var ,name ,(car (last value)))))
`(ps-js:var ,(ps-macroexpand name)
,@(when value? (list (compile-expression value) docstr))))))
(defmacro var (name &optional value docstr)
`(defparameter ,name ,value ,@(when docstr (list docstr))))
;;; iteration
(define-statement-operator for (init-forms cond-forms step-forms &body body)
(let ((init-forms (make-for-vars/inits init-forms)))
`(ps-js:for ,init-forms
,(mapcar #'compile-expression cond-forms)
,(mapcar #'compile-expression step-forms)
,(compile-loop-body (mapcar #'car init-forms) body))))
(define-statement-operator for-in ((var object) &rest body)
`(ps-js:for-in ,(compile-expression var)
,(compile-expression object)
,(compile-loop-body (list var) body)))
;;; misc
(define-statement-operator try (form &rest clauses)
(let ((catch (cdr (assoc :catch clauses)))
(finally (cdr (assoc :finally clauses))))
(assert (not (cdar catch)) ()
"Sorry, currently only simple catch forms are supported.")
(assert (or catch finally) ()
"Try form should have either a catch or a finally clause or both.")
`(ps-js:try
,(compile-statement `(progn ,form))
:catch ,(when catch
(list (caar catch)
(compile-statement `(progn ,@(cdr catch)))))
:finally ,(when finally
(compile-statement `(progn ,@finally))))))
(define-expression-operator regex (regex)
`(ps-js:regex ,(string regex)))
(define-expression-operator lisp (lisp-form)
;; (ps (foo (lisp bar))) is like (ps* `(foo ,bar))
;; When called from inside of ps*, lisp-form has access to the
;; dynamic environment only, analogous to eval.
`(ps-js:escape
(with-output-to-string (*psw-stream*)
(let ((compile-expression? ,compile-expression?)
(*js-string-delimiter* ,*js-string-delimiter*)
(eval-results (multiple-value-list ,lisp-form)))
(when eval-results
(parenscript-print (ps-compile (car eval-results)) t))))))
(defun lisp (x) x)
(defpsmacro undefined (x)
`(eql "undefined" (typeof ,x)))
(defpsmacro defined (x)
`(not (undefined ,x)))
(defpsmacro objectp (x)
`(string= (typeof ,x) "object"))
(define-ps-symbol-macro {} (create))
(defpsmacro [] (&rest args)
`(array ,@(mapcar (lambda (arg)
(if (and (consp arg) (not (equal '[] (car arg))))
(cons '[] arg)
arg))
args)))
(defpsmacro stringify (&rest things)
(if (and (= (length things) 1) (stringp (car things)))
(car things)
`(funcall (getprop (list ,@things) 'join) "")))
(defun stringify (&rest things)
"Like concatenate but prints all of its arguments."
(format nil "~{~A~}" things))
(define-ps-symbol-macro false ps-js:false)
(defvar false nil)

349
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/package.lisp Normal file
View file

@ -0,0 +1,349 @@
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2006 Luca Capello
;;; Copyright 2006 Atilla Lendvai
;;; Copyright 2007-2012 Vladimir Sedach
;;; Copyright 2007 Red Daly
;;; Copyright 2008 Travis Cross
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:cl)
(pushnew :parenscript *features*)
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (named-readtables:find-readtable :parenscript)
(named-readtables:defreadtable :parenscript
(:merge :standard)
(:case #.(if (eql :upcase (readtable-case *readtable*))
:invert
(readtable-case *readtable*))))))
(named-readtables:in-readtable :parenscript)
(defpackage #:parenscript
(:use #:cl #:anaphora #:named-readtables)
(:nicknames #:ps)
(:export
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler interface
;; compiler
#:*js-target-version*
#:ps
#:*parenscript-stream*
#:ps-to-stream
#:ps-doc
#:ps-doc*
#:ps*
#:ps-inline
#:ps-inline*
#:*ps-read-function*
#:ps-compile-file
#:ps-compile-stream
;; for parenscript macro definition within lisp
#:defpsmacro
#:defmacro+ps
#:import-macros-from-lisp
#:*defined-operators*
#:*version*
;; gensym
#:ps-gensym
#:with-ps-gensyms
#:ps-once-only
#:maybe-once-only
#:*ps-gensym-counter*
;; naming and namespaces
#:in-package
#:use-package
#:ps-package-prefix
#:obfuscate-package
#:unobfuscate-package
;; printer
#:symbol-to-js-string
#:*js-string-delimiter*
#:*js-inline-string-delimiter*
#:*ps-print-pretty*
#:*indent-num-spaces*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Language
;; literals
#:t
#:nil
;; array literals
#:array
#:list
#:aref
#:elt
#:make-array
#:[]
;; operators
;; logical boolean
#:not
#:and
#:or
;; bitwise boolean
#:logand
#:logior
#:logxor
#:lognot
#:ash
#:*
#:/
#:rem
#:mod
#:+
#:-
#:<
#:>
#:<=
#:>=
#:incf
#:decf
#:equal
#:eql
#:eq
#:=
;; compile-time stuff
#:eval-when
;; body forms
#:progn
;; if
#:if
#:when
#:unless
;; control flow
#:return
#:return-from
#:throw
;; assignment and binding
#:setf
#:defsetf
#:psetf
#:setq
#:psetq
#:let*
#:let
;; variables
#:defvar
;; iteration
#:do
#:do*
#:dotimes
#:dolist
#:loop
;; case
#:switch
#:case
#:default
;; function definition
#:defun
#:lambda
#:flet
#:labels
;; lambda lists
#:&key
#:&rest
#:&body
#:&optional
#:&aux
#:&environment
#:&key-object
;; macros
#:macrolet
#:symbol-macrolet
#:define-symbol-macro
#:define-ps-symbol-macro
#:defmacro
;; utils
#:max
#:min
#:floor
#:ceiling
#:round
#:sin
#:cos
#:tan
#:asin
#:acos
#:atan
#:pi
#:sinh
#:cosh
#:tanh
#:asinh
#:acosh
#:atanh
#:1+
#:1-
#:abs
#:evenp
#:oddp
#:exp
#:expt
#:log
#:sqrt
#:random
#:ignore-errors
#:concatenate
#:length
#:stringp
#:numberp
#:functionp
#:append
#:apply
#:destructuring-bind
;; js runtime utils
#:*ps-lisp-library*
#:mapcar
#:map-into
#:map
#:member
#:append
#:set-difference
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Non-Common Lisp functionality
;; DOM accessing utils
#:inner-html
#:uri-encode
#:attribute
#:offset
#:scroll
#:inner
#:client
;; utils
#:@
#:chain
#:defined
#:undefined
#:booleanp
#:objectp
#:stringify
;; html generator for javascript
#:*ps-html-empty-tag-aware-p*
#:*ps-html-mode*
#:ps-html
#:who-ps-html
;; lisp eval
#:lisp
;; js object stuff
#:delete
#:typeof
#:instanceof
#:new
#:create
;; slot access
#:with-slots
#:getprop
#:in
;; literals
#:regex
#:this
#:undefined
#:{}
#:false
;; iteration
#:for
#:for-in
#:while
;; global var
#:var
;; control flow
#:try
#:break
#:continue
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Deprecated functionality
#:define-script-symbol-macro
#:gen-js-name
#:with-unique-js-names
#:defjsmacro
#:js-compile
#:js-inline
#:js-inline*
#:js
#:js*
#:symbol-to-js
#:slot-value
#:compile-script
#:defmacro/ps
#:%
#:==
#:===
#:!=
#:!==
#:labeled-for
#:do-set-timeout
#:concat-string
#:with
#:label
#:f
#:bind
#:bind*
))

259
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/parse-lambda-list.lisp Normal file
View file

@ -0,0 +1,259 @@
;;; Copyright 2007 Red Daly
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
;;;; This software was taken from the SBCL system, mostly verbatim.
;;; if you have found this on google, THIS IS NOT AN SBCL SOURCE FILE
;;; Break something like a lambda list (but not necessarily actually a
;;; lambda list, e.g. the representation of argument types which is
;;; used within an FTYPE specification) into its component parts. We
;;; return twelve values:
;;; 1. a list of the required args;
;;; 2. a list of the &OPTIONAL arg specs;
;;; 3. true if a &REST arg was specified;
;;; 4. the &REST arg;
;;; 5. true if &KEY args are present;
;;; 6. a list of the &KEY arg specs;
;;; 7. true if &ALLOW-OTHER-KEYS was specified.;
;;; 8. true if any &AUX is present (new in SBCL vs. CMU CL);
;;; 9. a list of the &AUX specifiers;
;;; 10. true if a &MORE arg was specified;
;;; 11. the &MORE context var;
;;; 12. the &MORE count var;
;;; 13. true if any lambda list keyword is present (only for
;;; PARSE-LAMBDA-LIST-LIKE-THING).
;;; 14. the &KEY-OBJECT var
;;;
;;; The top level lambda list syntax is checked for validity, but the
;;; arg specifiers are just passed through untouched.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun collect-list-expander (n-value n-tail forms)
(let ((n-res (gensym)))
`(progn
,@(mapcar (lambda (form)
`(let ((,n-res (cons ,form nil)))
(cond (,n-tail
(setf (cdr ,n-tail) ,n-res)
(setq ,n-tail ,n-res))
(t
(setq ,n-tail ,n-res ,n-value ,n-res)))))
forms)
,n-value))))
(defmacro collect (collections &body body)
(let ((macros ())
(binds ()))
(dolist (spec collections)
;;(unless (proper-list-of-length-p spec 1 3)
;; (error "malformed collection specifier: ~S" spec))
(let* ((name (first spec))
(default (second spec))
(kind (or (third spec) 'collect))
(n-value (gensym (concatenate 'string
(symbol-name name)
"-N-VALUE-"))))
(push `(,n-value ,default) binds)
(if (eq kind 'collect)
(let ((n-tail (gensym (concatenate 'string
(symbol-name name)
"-N-TAIL-"))))
(if default
(push `(,n-tail (last ,n-value)) binds)
(push n-tail binds))
(push `(,name (&rest args)
(collect-list-expander ',n-value ',n-tail args))
macros))
(push `(,name (&rest args)
(collect-normal-expander ',n-value ',kind args))
macros))))
`(macrolet ,macros (let* ,(nreverse binds) ,@body))))
(defparameter *lambda-list-keywords*
'(&allow-other-keys &aux &body &environment &key &key-object &optional &rest &whole))
(defun style-warn (&rest args) (apply #'format t args))
(defun parse-lambda-list-like-thing (list)
(collect ((required)
(optional)
(keys)
(aux))
(let ((restp nil)
(rest nil)
(morep nil)
(more-context nil)
(more-count nil)
(keyp nil)
(auxp nil)
(allowp nil)
(key-object nil)
(state :required))
(declare (type (member :allow-other-keys :aux
:key
:more-context :more-count
:optional
:post-more :post-rest
:required :rest
:key-object :post-key)
state))
(dolist (arg list)
(if (member arg *lambda-list-keywords*)
(case arg
(&optional
(unless (eq state :required)
(format t "misplaced &OPTIONAL in lambda list: ~S"
list))
(setq state :optional))
(&rest
(unless (member state '(:required :optional))
(format t "misplaced &REST in lambda list: ~S" list))
(setq state :rest))
(&more
(unless (member state '(:required :optional))
(format t "misplaced &MORE in lambda list: ~S" list))
(setq morep t
state :more-context))
(&key
(unless (member state
'(:required :optional :post-rest :post-more))
(format t "misplaced &KEY in lambda list: ~S" list))
(when (optional)
(format t "&OPTIONAL and &KEY found in the same lambda list: ~S" list))
(setq keyp t
state :key))
(&allow-other-keys
(unless (member state '(:key :post-key))
(format t "misplaced &ALLOW-OTHER-KEYS in ~
lambda list: ~S"
list))
(setq allowp t
state :allow-other-keys))
(&aux
(when (member state '(:rest :more-context :more-count))
(format t "misplaced &AUX in lambda list: ~S" list))
(when auxp
(format t "multiple &AUX in lambda list: ~S" list))
(setq auxp t
state :aux))
(&key-object
(unless (member state '(:key :allow-other-keys))
(format t "&key-object misplaced in lmabda list: ~S. Belongs after &key" list))
(setf state :key-object))
(t (format t "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg)))
(progn
(when (symbolp arg)
(let ((name (symbol-name arg)))
(when (and (plusp (length name))
(char= (char name 0) #\&))
(style-warn
"suspicious variable in lambda list: ~S." arg))))
(case state
(:required (required arg))
(:optional (optional arg))
(:rest
(setq restp t
rest arg
state :post-rest))
(:more-context
(setq more-context arg
state :more-count))
(:more-count
(setq more-count arg
state :post-more))
(:key (keys arg))
(:key-object (setf key-object arg) (setf state :post-key))
(:aux (aux arg))
(t
(format t "found garbage in lambda list when expecting ~
a keyword: ~S"
arg))))))
(when (eq state :rest)
(format t "&REST without rest variable"))
(values (required) (optional) restp rest keyp (keys) allowp auxp (aux)
morep more-context more-count
(not (eq state :required))
key-object))))
;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument
;;; really *is* a lambda list, not just a "lambda-list-like thing", so
;;; can barf on things which're illegal as arguments in lambda lists
;;; even if they could conceivably be legal in not-quite-a-lambda-list
;;; weirdosities
(defun parse-lambda-list (lambda-list)
;; Classify parameters without checking their validity individually.
(multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
morep more-context more-count beyond-requireds? key-object)
(parse-lambda-list-like-thing lambda-list)
(declare (ignore beyond-requireds?))
;; Check validity of parameters.
(flet ((need-symbol (x why)
(unless (symbolp x)
(format t "~A is not a symbol: ~S" why x))))
(dolist (i required)
(need-symbol i "Required argument"))
(dolist (i optional)
(typecase i
(symbol)
(cons
(destructuring-bind (var &optional init-form supplied-p) i
(declare (ignore init-form supplied-p))
(need-symbol var "&OPTIONAL parameter name")))
(t
(format t "&OPTIONAL parameter is not a symbol or cons: ~S"
i))))
(when restp
(need-symbol rest "&REST argument"))
(when keyp
(dolist (i keys)
(typecase i
(symbol)
(cons
(destructuring-bind (var-or-kv &optional init-form supplied-p) i
(declare (ignore init-form supplied-p))
(if (consp var-or-kv)
(destructuring-bind (keyword-name var) var-or-kv
(declare (ignore keyword-name))
(need-symbol var "&KEY parameter name"))
(need-symbol var-or-kv "&KEY parameter name"))))
(t
(format t "&KEY parameter is not a symbol or cons: ~S"
i))))))
;; Voila.
(values required optional restp rest keyp keys allowp auxp aux
morep more-context more-count key-object)))

415
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/printer.lisp Normal file
View file

@ -0,0 +1,415 @@
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2007-2012 Vladimir Sedach
;;; Copyright 2008 Travis Cross
;;; Copyright 2009-2013 Daniel Gackle
;;; Copyright 2010 Scott Bell
;;; Copyright 2014 Boris Smilga
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(in-readtable :parenscript)
(defvar *ps-print-pretty* t)
(defvar *indent-num-spaces* 4)
(defvar *js-string-delimiter* #\'
"Specifies which character should be used for delimiting strings.
This variable is used when you want to embed the resulting JavaScript
in an html attribute delimited by #\\\" as opposed to #\\', or
vice-versa.")
(defvar *indent-level*)
(defvar *column*)
(defvar *psw-stream*)
(defun parenscript-print (form immediate?)
(declare (special immediate?))
(let ((*indent-level* 0)
(*column* 0)
(*psw-stream* (if immediate?
*psw-stream*
(make-string-output-stream)))
(%psw-accumulator ()))
(declare (special %psw-accumulator))
(with-standard-io-syntax
(if (and (listp form) (eq 'ps-js:block (car form))) ; ignore top-level block
(loop for (statement . remaining) on (cdr form) do
(ps-print statement) (psw #\;) (when remaining (psw #\Newline)))
(ps-print form)))
(unless immediate?
(reverse (cons (get-output-stream-string *psw-stream*)
%psw-accumulator)))))
(defun psw (&rest objs)
(dolist (obj objs)
(declare (special %psw-accumulator immediate?))
(typecase obj
(string
(incf *column* (length obj))
(write-string obj *psw-stream*))
(character
(if (eql obj #\Newline)
(setf *column* 0)
(incf *column*))
(write-char obj *psw-stream*))
(otherwise
(if immediate?
(let ((str (eval obj)))
(incf *column* (length str))
(write-string str *psw-stream*))
(setf %psw-accumulator
(list* obj
(get-output-stream-string *psw-stream*)
%psw-accumulator)))))))
(defgeneric ps-print (form))
(defgeneric ps-print% (js-primitive args))
(defmacro defprinter (js-primitive args &body body)
(if (listp js-primitive)
(cons 'progn (mapcar (lambda (p)
`(defprinter ,p ,args ,@body))
js-primitive))
(let ((pargs (gensym)))
`(defmethod ps-print% ((op (eql ',js-primitive)) ,pargs)
(declare (ignorable op))
(destructuring-bind ,args
,pargs
,@(loop for x in body collect
(if (or (characterp x)
(stringp x))
(list 'psw x)
x)))))))
(defmethod ps-print ((x null))
(psw "null"))
(defmethod ps-print ((x (eql t)))
(psw "true"))
(defmethod ps-print ((x (eql 'ps-js:false)))
(psw "false"))
(defmethod ps-print ((s symbol))
(if (keywordp s)
(ps-print (string-downcase s))
(psw (symbol-to-js-string s))))
(defmethod ps-print ((compiled-form cons))
(ps-print% (car compiled-form) (cdr compiled-form)))
(defun newline-and-indent (&optional indent-spaces)
(if *ps-print-pretty*
(progn (psw #\Newline)
(loop repeat (if indent-spaces
indent-spaces
(* *indent-level* *indent-num-spaces*))
do (psw #\Space)))
(psw #\Space)))
(defun print-comment (comment-str)
(when *ps-print-pretty*
(let ((lines (cl-ppcre:split #\Newline comment-str)))
(if (cdr lines)
(progn (psw "/**") (newline-and-indent)
(dolist (x lines) (psw " * " x) (newline-and-indent))
(psw " */"))
(psw "/** " comment-str " */"))
(newline-and-indent))))
(defparameter *js-lisp-escaped-chars*
(list #\' #\'
#\" #\"
#\\ #\\
#\Backspace #\b
(code-char 12) #\f
#\Newline #\n
#\Return #\r
#\Tab #\t))
(defmethod ps-print ((char character))
(ps-print (string char)))
(defmethod ps-print ((string string))
(psw *js-string-delimiter*)
(loop for char across string do
(acond ((getf *js-lisp-escaped-chars* char)
(psw #\\ it))
((or (<= (char-code char) #x1F)
(<= #x80 (char-code char) #x9F)
(member (char-code char) '(#xA0 #xAD #x200B #x200C)))
(format *psw-stream* "\\u~:@(~4,'0x~)" (char-code char)))
(t
(psw char))))
(psw *js-string-delimiter*))
(defmethod ps-print ((number number))
(format *psw-stream* (if (integerp number) "~D" "~F") number))
(let ((precedence-table (make-hash-table :test 'eq)))
(loop for level in '((ps-js:getprop ps-js:aref ps-js:funcall)
(ps-js:new)
(ps-js:lambda) ;; you won't find this in JS books
(ps-js:++ ps-js:-- ps-js:post++ ps-js:post--)
(ps-js:! ps-js:~ ps-js:negate ps-js:unary-plus ps-js:typeof ps-js:delete)
(ps-js:* ps-js:/ ps-js:%)
(ps-js:- ps-js:+)
(ps-js:<< ps-js:>> ps-js:>>>)
(ps-js:< ps-js:> ps-js:<= ps-js:>= ps-js:instanceof ps-js:in)
(ps-js:== ps-js:!= ps-js:=== ps-js:!==)
(ps-js:&)
(ps-js:^)
(ps-js:\|)
(ps-js:&&)
(ps-js:\|\|)
(ps-js:?)
(ps-js:= ps-js:*= ps-js:/= ps-js:%= ps-js:+= ps-js:-= ps-js:<<= ps-js:>>= ps-js:>>>= ps-js:&= ps-js:^= ps-js:\|=)
(ps-js:return ps-js:throw)
(ps-js:|,|))
for i from 0
do (mapc (lambda (symbol)
(setf (gethash symbol precedence-table) i))
level))
(defun precedence (op)
(gethash op precedence-table -1)))
(defun associative? (op)
(member op '(ps-js:* ps-js:& ps-js:&& ps-js:\| ps-js:\|\|
ps-js:funcall ps-js:aref ps-js:getprop))) ;; these aren't really associative, but RPN
(defun parenthesize-print (x)
(psw #\() (ps-print x) (psw #\)))
(defun print-op-argument (op argument)
(let ((arg-op (when (listp argument) (car argument))))
(if (or (< (precedence op) (precedence arg-op))
(and (= (precedence op) (precedence arg-op))
(or (not (associative? op)) (not (associative? arg-op)))))
(parenthesize-print argument)
(ps-print argument))))
(defun print-op (op)
(psw (string-downcase op)))
(defprinter (ps-js:! ps-js:~ ps-js:++ ps-js:--) (x)
(print-op op) (print-op-argument op x))
(defprinter ps-js:negate (x)
"-"(print-op-argument op x))
(defprinter ps-js:unary-plus (x)
"+"(print-op-argument op x))
(defprinter (ps-js:delete ps-js:typeof ps-js:new ps-js:throw) (x)
(print-op op)" "(print-op-argument op x))
(defprinter (ps-js:return) (&optional (x nil x?))
(print-op op)
(when x?
(psw " ") (print-op-argument op x)))
(defprinter ps-js:post++ (x)
(ps-print x)"++")
(defprinter ps-js:post-- (x)
(ps-print x)"--")
(defprinter (ps-js:+ ps-js:- ps-js:* ps-js:/ ps-js:% ps-js:&& ps-js:\|\| ps-js:& ps-js:\| ps-js:-= ps-js:+= ps-js:*= ps-js:/= ps-js:%= ps-js:^ ps-js:<< ps-js:>> ps-js:&= ps-js:^= ps-js:\|= ps-js:= ps-js:in ps-js:> ps-js:>= ps-js:< ps-js:<= ps-js:== ps-js:!= ps-js:=== ps-js:!==)
(&rest args)
(loop for (arg . remaining) on args do
(print-op-argument op arg)
(when remaining (format *psw-stream* " ~(~A~) " op))))
(defprinter ps-js:aref (array &rest indices)
(print-op-argument 'ps-js:aref array)
(dolist (idx indices)
(psw #\[) (ps-print idx) (psw #\])))
(defun print-comma-delimited-list (ps-forms)
(loop for (form . remaining) on ps-forms do
(print-op-argument 'ps-js:|,| form)
(when remaining (psw ", "))))
(defprinter ps-js:array (&rest initial-contents)
"["(print-comma-delimited-list initial-contents)"]")
(defprinter (ps-js:|,|) (&rest expressions)
(print-comma-delimited-list expressions))
(defprinter ps-js:funcall (fun-designator &rest args)
(print-op-argument op fun-designator)"("(print-comma-delimited-list args)")")
(defprinter ps-js:block (&rest statements)
"{" (incf *indent-level*)
(dolist (statement statements)
(newline-and-indent) (ps-print statement) (psw #\;))
(decf *indent-level*) (newline-and-indent)
"}")
(defprinter ps-js:lambda (args body-block)
(print-fun-def nil args body-block))
(defprinter ps-js:defun (name args docstring body-block)
(when docstring (print-comment docstring))
(print-fun-def name args body-block))
(defun print-fun-def (name args body)
(destructuring-bind (keyword name) (if (consp name) name `(function ,name))
(format *psw-stream* "~(~A~) ~:[~;~A~]("
keyword name (symbol-to-js-string name))
(loop for (arg . remaining) on args do
(psw (symbol-to-js-string arg)) (when remaining (psw ", ")))
(psw ") ")
(ps-print body)))
(defprinter ps-js:object (&rest slot-defs)
(psw "{ ")
(let ((indent? (< 2 (length slot-defs)))
(indent *column*))
(loop for ((slot-name . slot-value) . remaining) on slot-defs do
(if (consp slot-name)
(apply #'print-fun-def slot-name slot-value)
(progn
(ps-print slot-name) (psw " : ")
(if (and (consp slot-value)
(eq 'ps-js:|,| (car slot-value)))
(parenthesize-print slot-value)
(ps-print slot-value))))
(when remaining
(psw ",")
(if indent?
(newline-and-indent indent)
(psw #\Space))))
(if indent?
(newline-and-indent (- indent 2))
(psw #\Space)))
(psw "}"))
(defprinter ps-js:getprop (obj slot)
(print-op-argument op obj)"."(psw (symbol-to-js-string slot)))
(defprinter ps-js:if (test consequent &rest clauses)
"if (" (ps-print test) ") "
(ps-print consequent)
(loop while clauses do
(ecase (car clauses)
(:else-if (psw " else if (") (ps-print (cadr clauses)) (psw ") ")
(ps-print (caddr clauses))
(setf clauses (cdddr clauses)))
(:else (psw " else ")
(ps-print (cadr clauses))
(return)))))
(defprinter ps-js:? (test then else)
(print-op-argument op test) " ? "
(print-op-argument op then) " : "
(print-op-argument op else))
(defprinter ps-js:var (var-name &optional (value (values) value?) docstring)
(when docstring (print-comment docstring))
"var "(psw (symbol-to-js-string var-name))
(when value? (psw " = ") (print-op-argument 'ps-js:= value)))
(defprinter ps-js:label (label statement)
(psw (symbol-to-js-string label))": "(ps-print statement))
(defprinter (ps-js:continue ps-js:break) (&optional label)
(print-op op) (when label
(psw " " (symbol-to-js-string label))))
;;; iteration
(defprinter ps-js:for (vars tests steps body-block)
"for ("
(loop for ((var-name . var-init) . remaining) on vars
for decl = "var " then "" do
(psw decl (symbol-to-js-string var-name) " = ")
(print-op-argument 'ps-js:= var-init)
(when remaining (psw ", ")))
"; "
(loop for (test . remaining) on tests do
(ps-print test) (when remaining (psw ", ")))
"; "
(loop for (step . remaining) on steps do
(ps-print step) (when remaining (psw ", ")))
") "
(ps-print body-block))
(defprinter ps-js:for-in (var object body-block)
"for (var "(ps-print var)" in "(ps-print object)") "
(ps-print body-block))
(defprinter (ps-js:with ps-js:while) (expression body-block)
(print-op op)" ("(ps-print expression)") "
(ps-print body-block))
(defprinter ps-js:switch (test &rest clauses)
"switch ("(ps-print test)") {"
(flet ((print-body (body)
(incf *indent-level*)
(loop for statement in body do
(newline-and-indent)
(ps-print statement)
(psw #\;))
(decf *indent-level*)))
(loop for (val . statements) in clauses do
(newline-and-indent)
(if (eq val 'ps-js:default)
(progn (psw "default:")
(print-body statements))
(progn (psw "case ") (ps-print val) (psw #\:)
(print-body statements)))))
(newline-and-indent)
"}")
(defprinter ps-js:try (body-block &key catch finally)
"try "(ps-print body-block)
(when catch
(psw " catch ("(symbol-to-js-string (first catch))") ")
(ps-print (second catch)))
(when finally
(psw " finally ") (ps-print finally)))
(defprinter ps-js:regex (regex)
(let ((slash (unless (and (> (length regex) 0) (char= (char regex 0) #\/)) "/")))
(psw (concatenate 'string slash regex slash))))
(defprinter ps-js:instanceof (value type)
"("(print-op-argument op value)" instanceof "(print-op-argument op type)")")
(defprinter ps-js:escape (literal-js)
;; literal-js should be a form that evaluates to a string containing
;; valid JavaScript
(psw literal-js))

702
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/special-operators.lisp Normal file
View file

@ -0,0 +1,702 @@
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2007-2012 Vladimir Sedach
;;; Copyright 2011-2013 Daniel Gackle
;;; Copyright 2014 Boris Smilga
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(in-readtable :parenscript)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; arithmetic and logic
(define-trivial-special-ops
+ ps-js:+
- ps-js:-
* ps-js:*
rem ps-js:%
and ps-js:&&
or ps-js:\|\|
logand ps-js:&
logior ps-js:\|
logxor ps-js:^
lognot ps-js:~
aref ps-js:aref
funcall ps-js:funcall
)
(define-expression-operator / (&rest args)
`(ps-js:/ ,@(unless (cdr args) (list 1)) ,@(mapcar #'compile-expression args)))
(define-expression-operator + (&rest args)
(let ((args (mapcar #'compile-expression args)))
(cons (if (cdr args) 'ps-js:+ 'ps-js:unary-plus) args)))
(define-expression-operator - (&rest args)
(let ((args (mapcar #'compile-expression args)))
(cons (if (cdr args) 'ps-js:- 'ps-js:negate) args)))
(defun fix-nary-comparison (operator objects)
(let* ((tmp-var-forms (butlast (cdr objects)))
(tmp-vars (loop repeat (length tmp-var-forms)
collect (ps-gensym '_cmp)))
(all-comparisons (append (list (car objects))
tmp-vars
(last objects))))
`(let ,(mapcar #'list tmp-vars tmp-var-forms)
(and ,@(loop for x1 in all-comparisons
for x2 in (cdr all-comparisons)
collect (list operator x1 x2))))))
(macrolet ((define-nary-comparison-forms (&rest mappings)
`(progn
,@(loop for (form js-primitive) on mappings by #'cddr collect
`(define-expression-operator ,form (&rest objects)
(if (cddr objects)
(ps-compile
(fix-nary-comparison ',form objects))
(cons ',js-primitive
(mapcar #'compile-expression objects))))))))
(define-nary-comparison-forms
< ps-js:<
> ps-js:>
<= ps-js:<=
>= ps-js:>=
eql ps-js:===
equal ps-js:==))
(define-expression-operator /= (a b)
;; for n>2, /= is finding duplicates in an array of numbers (ie -
;; nontrivial runtime algorithm), so we restrict it to binary in PS
`(ps-js:!== ,(compile-expression a) ,(compile-expression b)))
(defun references? (exp place)
(cond ((not exp) nil)
((atom exp) (equal exp place))
(t (or (equal exp place)
(references? (car exp) place)
(references? (cdr exp) place)))))
(defmacro inc-dec (op op1 op2)
`(let ((delta (ps-macroexpand delta)))
(cond ((eql delta 1)
(list ',op1 (compile-expression x)))
((references? delta x)
(ps-compile
(let ((var (ps-gensym '_ps_incr_place)))
`(let ((,var ,delta))
(,',op ,x ,var)))))
(t
(list ',op2 (compile-expression x)
(compile-expression delta))))))
(define-expression-operator incf (x &optional (delta 1))
(inc-dec incf ps-js:++ ps-js:+=))
(define-expression-operator decf (x &optional (delta 1))
(inc-dec decf ps-js:-- ps-js:-=))
(let ((inverses (mapcan (lambda (x)
(list x (reverse x)))
'((ps-js:=== ps-js:!==)
(ps-js:== ps-js:!=)
(ps-js:< ps-js:>=)
(ps-js:> ps-js:<=)))))
(define-expression-operator not (x)
(let ((form (compile-expression x)))
(acond ((and (listp form) (eq (car form) 'ps-js:!)) ;; not not → identity
(second form))
((and (listp form) (cadr (assoc (car form) inverses))) ;; not equal → !=
`(,it ,@(cdr form)))
(t `(ps-js:! ,form))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; blocks and control flow
(defun compile-progn (body)
(let ((block (flatten-blocks (mapcar #'ps-compile body))))
(append (remove-if #'constantp (butlast block))
(unless (and (or (eq *compilation-level* :toplevel)
(not compile-expression?))
(not (car (last block))))
(last block)))))
(define-expression-operator progn (&rest body)
(if (cdr body)
`(ps-js:|,| ,@(compile-progn body))
(compile-expression (car body))))
(define-statement-operator progn (&rest body)
`(ps-js:block ,@(compile-progn body)))
(defvar returning-values? nil)
(defun wrap-for-dynamic-return (handled-tags body)
(aif (loop for (tag . thrown?) in *dynamic-return-tags*
when (and thrown? (member tag handled-tags))
collect tag)
(with-ps-gensyms (_ps_err)
(flet ((make-catch-clause (tag)
`((and ,_ps_err (eql ',tag
(getprop ,_ps_err :__ps_block_tag)))
(return-from ,tag
(getprop ,_ps_err :__ps_value)
t))))
`(ps-js:block
(ps-js:try
,body
:catch (,_ps_err
,(compile-statement
`(progn (cond
,@(mapcar #'make-catch-clause it)
(t (throw ,_ps_err))))))
:finally nil))))
body))
(define-statement-operator block (name &rest body)
(if in-function-scope?
(let* ((name (or name 'nilBlock))
(in-loop-scope? (if name in-loop-scope? nil))
(*dynamic-return-tags* (cons (cons name nil)
*dynamic-return-tags*))
(*current-block-tag* name)
(compiled-body (wrap-for-dynamic-return
(list name)
(ps-compile `(progn ,@body)))))
;; this probably does not nest correctly
(if (tree-find `(ps-js:break ,name) compiled-body)
`(ps-js:label ,name ,compiled-body)
compiled-body))
(ps-compile (with-lambda-scope `(block ,name ,@body)))))
(define-expression-operator values (&rest forms)
(ps-compile
(with-ps-gensyms (val)
`(let ((,val ,(car forms)))
(setf __PS_MV_REG (list ,@(cdr forms)))
,val))))
(define-expression-operator values-list (list)
(ps-compile
(with-ps-gensyms (values-list firstval)
`(let ((,values-list (funcall (getprop ,list 'slice))))
(setf ,firstval (funcall (getprop ,values-list 'shift))
__PS_MV_REG ,values-list)
,firstval))))
(define-statement-operator %simple-lexical-return (&rest value)
`(ps-js:return ,@value))
(defun return-exp (tag &optional (value nil value?))
(flet ((lexical-return ()
(let ((X (when value? (list (compile-expression value)))))
(ps-compile
(if (and (not returning-values?) clear-multiple-values?)
`(progn
(setf __PS_MV_REG '())
(%simple-lexical-return ,@X))
`(%simple-lexical-return ,@X))))))
(acond
((eql tag *current-block-tag*)
(compile-statement
`(progn
,@(when (and (not returning-values?) clear-multiple-values?)
'((setf __PS_MV_REG '())))
,@(when value? (list value))
(break ,tag))))
((or (eql '%function tag)
(member tag *function-block-names*))
(lexical-return))
((assoc tag *dynamic-return-tags*)
(setf (cdr it) t)
(ps-compile
`(progn
,@(unless returning-values?
'((setf __PS_MV_REG '())))
(throw (create
:__ps_block_tag ',tag
:__ps_value ,value)))))
(t
(warn "Returning from unknown block ~A" tag)
(lexical-return)))))
(defun try-expressionizing-if? (exp &optional (score 0)) ;; poor man's codewalker
"Heuristic that tries not to expressionize deeply nested if expressions."
(cond ((< 1 score) nil)
((and (listp exp) (eq (car exp) 'quote))
t)
((listp exp)
(loop for x in (cdr exp) always
(try-expressionizing-if?
(or (ignore-errors (ps-macroexpand x))
x) ;; fail
(+ score (case (car exp)
((if cond) 1)
(let (if (second exp) 1 0)) ;; ignore empty binding list
((progn) (1- (length (cdr exp))))
(otherwise 0))))))
(t t)))
(defun return-result-of (tag form)
(ps-compile
(case (car form)
((continue break throw) ;; non-local exit
form)
;; implicit progn forms
((with) ;; deprecated and will be removed
`(,(first form) ,(second form)
,@(butlast (cddr form))
(return-from ,tag ,(car (last (cddr form))))))
;; implicit body (declaration + progn) forms
((let flet labels macrolet symbol-macrolet)
(multiple-value-bind (body declarations)
(parse-body (cddr form))
`(,(first form) ,(second form)
,@declarations
,@(butlast body)
(return-from ,tag ,(car (last body))))))
((progn locally)
`(progn ,@(butlast (cdr form))
(return-from ,tag ,(car (last (cdr form))))))
(switch
`(switch
,(second form)
,@(loop for (cvalue . cbody) in (cddr form)
for remaining on (cddr form) collect
(aif (cond ((or (eq 'default cvalue) (not (cdr remaining)))
1)
((eq 'break (car (last cbody)))
2))
(let ((result-form (ps-macroexpand
(car (last cbody it)))))
`(,cvalue
,@(butlast cbody it)
(return-from ,tag
,(if (eq result-form 'break) nil result-form))))
(cons cvalue cbody)))))
(try
`(try (return-from ,tag ,(second form))
,@(let ((catch (cdr (assoc :catch (cdr form))))
(finally (assoc :finally (cdr form))))
(list (when catch
`(:catch ,(car catch)
,@(butlast (cdr catch))
(return-from ,tag
,(car (last (cdr catch))))))
finally))))
(cond
`(cond
,@(loop for clause in (cdr form) collect
`(,@(butlast clause) (return-from ,tag ,(car (last clause)))))
,@(when in-case? `((t (return-from ,tag nil))))))
(if
(if (and (try-expressionizing-if? form)
(not (tree-find 'values form))
(let ((used-up-names *used-up-names*)
(*lambda-wrappable-statements* ()))
(handler-case (compile-expression form)
(compile-expression-error ()
(setf *used-up-names* used-up-names)
nil))))
(return-from return-result-of (return-exp tag form))
`(if ,(second form)
(return-from ,tag ,(third form))
,@(when (or in-case? (fourth form))
`((return-from ,tag ,(fourth form)))))))
(block
(let* ((tag₁ (or (cadr form) 'nilBlock))
(*function-block-names* (cons tag₁ *function-block-names*))
(*dynamic-return-tags* (cons (cons tag₁ nil)
*dynamic-return-tags*)))
(return-from return-result-of
(wrap-for-dynamic-return
(list tag₁)
(ps-compile `(return-from ,tag (progn ,@(cddr form))))))))
(values
(if (cddr form)
(with-ps-gensyms (val)
`(let ((,val ,(cadr form)))
(setf __PS_MV_REG (list ,@(cddr form)))
(return-from ,tag ,val t)))
`(return-from ,tag ,@(cdr form))))
(values-list
(with-ps-gensyms (values-list firstval)
`(let ((,values-list (funcall (getprop ,(cadr form) 'slice))))
(setf ,firstval (funcall (getprop ,values-list 'shift))
__PS_MV_REG ,values-list)
(return-from ,tag ,firstval t))))
(return-from ;; this will go away someday
(unless tag
(warn 'simple-style-warning
:format-control "Trying to RETURN a RETURN without a block tag specified. Perhaps you're still returning values from functions by hand?
Parenscript now implements implicit return, update your code! Things like (lambda () (return x)) are not valid Common Lisp and may not be supported in future versions of Parenscript."))
form)
(otherwise
(return-from return-result-of
(cond ((not (gethash (car form) *special-statement-operators*))
(return-exp tag form))
(in-case?
`(ps-js:block ,(compile-statement form) ,(return-exp tag)))
(t (compile-statement form))))))))
(define-statement-operator return-from (tag &optional
(result nil result?)
returning-values?)
(setq tag (or tag 'nilBlock))
(if result?
(let ((form (ps-macroexpand result)))
(if (atom form)
(return-exp tag form)
(return-result-of tag form)))
(return-exp tag)))
(define-statement-operator throw (&rest args)
`(ps-js:throw ,@(mapcar #'compile-expression args)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; conditionals
(define-expression-operator if (test then &optional else)
`(ps-js:? ,(compile-expression test)
,(compile-expression then)
,(compile-expression else)))
(define-statement-operator if (test then &optional else)
`(ps-js:if ,(compile-expression test)
,(compile-statement `(progn ,then))
,@(when else
`(:else ,(compile-statement `(progn ,else))))))
(define-expression-operator cond (&rest clauses)
(compile-expression
(when clauses
(destructuring-bind (test &rest body) (car clauses)
(if (eq t test)
(if (null body) t `(progn ,@body))
(flet ((conditional (test body)
`(if ,test
(progn ,@body)
(cond ,@(cdr clauses)))))
(if (null body)
(with-ps-gensyms (test-result)
`(let ((,test-result ,test))
,(conditional test-result (list test-result))))
(conditional test body))))))))
(define-statement-operator cond (&rest clauses)
(let* ((test-result nil)
(clauses*
(loop for clause in clauses for (test . body) = clause
if body
collect clause
else
do (unless test-result (setq test-result (ps-gensym)))
and collect
(if (and (consp test) (eq (first test) 'return-from))
(cons `(setq ,test-result ,(third test))
`((return-from ,(second test) ,test-result)))
(cons `(setq ,test-result ,test)
`(,test-result)))))
(if-form
`(ps-js:if
,(compile-expression (caar clauses*))
,(compile-statement `(progn ,@(cdar clauses*)))
,@(loop for (test . body) in (cdr clauses*) appending
(if (eq t test)
`(:else ,(compile-statement `(progn ,@body)))
`(:else-if ,(compile-expression test)
,(compile-statement `(progn ,@body))))))))
(if test-result
`(ps-js:block (ps-js:var ,test-result) ,if-form)
if-form)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; binding
(defmacro with-declaration-effects ((var block) &body body)
(with-ps-gensyms (decls)
`(multiple-value-bind (,var ,decls) (parse-body ,block)
(let ((*special-variables*
(nconc
(loop for decl in ,decls nconc
(loop for (decl-type . decl-args) in (cdr decl)
if (eq decl-type 'special)
append decl-args))
*special-variables*)))
,@body))))
(defun maybe-rename-lexical-var (x symbols-in-bindings)
(when (or (member x *enclosing-lexicals*)
(member x *enclosing-function-arguments*)
(when (boundp '*used-up-names*)
(member x *used-up-names*))
(lookup-macro-def x *symbol-macro-env*)
(member x symbols-in-bindings))
(ps-gensym (symbol-name x))))
(defun with-lambda-scope (form)
(prog1 (if (tree-find 'this
(let ((*ps-gensym-counter* *ps-gensym-counter*))
(ps-compile `(lambda () ,form))))
`(funcall (getprop (lambda () ,form) 'call) this)
`((lambda () ,form)))
(setf *vars-needing-to-be-declared* ())))
(define-expression-operator let (bindings &body body)
(with-declaration-effects (body body)
(flet ((rename (x) (first x))
(var (x) (second x))
(val (x) (third x)))
(let* ((new-lexicals ())
(loop-scoped-lexicals ())
(normalized-bindings
(mapcar (lambda (x)
(if (symbolp x)
(list x nil)
(list (car x) (ps-macroexpand (cadr x)))))
bindings))
(symbols-in-bindings
(mapcan (lambda (x) (flatten (cadr x)))
normalized-bindings))
(lexical-bindings
(mapcan
(lambda (x)
(unless (special-variable? (car x))
(let ((renamed (maybe-rename-lexical-var
(car x) symbols-in-bindings)))
(if renamed
(when in-loop-scope?
(push renamed loop-scoped-lexicals))
(progn
(push (car x) new-lexicals)
(when (boundp '*used-up-names*)
(push (car x) *used-up-names*))))
(list (cons renamed x)))))
normalized-bindings))
(dynamic-bindings
(loop for x in normalized-bindings
when (special-variable? (car x)) collect
(cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack))
x)))
(renamed-body
`(symbol-macrolet ,(loop for x in lexical-bindings
when (rename x) collect
`(,(var x) ,(rename x)))
,@body))
(*enclosing-lexicals*
(append new-lexicals *enclosing-lexicals*))
(*loop-scope-lexicals*
(when in-loop-scope?
(append new-lexicals loop-scoped-lexicals
*loop-scope-lexicals*)))
(let-body
`(progn
,@(mapcar (lambda (x)
`(var ,(or (rename x) (var x)) ,(val x)))
lexical-bindings)
,(if dynamic-bindings
`(progn
,@(mapcar (lambda (x) `(var ,(rename x)))
dynamic-bindings)
(try
(progn
(setf ,@(loop for x in dynamic-bindings append
`(,(rename x) ,(var x)
,(var x) ,(val x))))
,renamed-body)
(:finally
(setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
dynamic-bindings)))))
renamed-body))))
(ps-compile
(cond ((or in-function-scope? (null bindings))
let-body)
;; HACK
((find-if
(lambda (x) (member x '(defun% defvar)))
(flatten
(loop for x in body collecting
(or (ignore-errors (ps-macroexpand x)) x))))
let-body)
(t
(with-lambda-scope let-body))))))))
(define-expression-operator locally (&rest body)
(with-declaration-effects (body body)
(ps-compile `(progn ,@body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; macros
(defmacro with-local-macro-environment ((var env) &body body)
`(let* ((,var (make-macro-dictionary))
(,env (cons ,var ,env)))
,@body))
(define-expression-operator macrolet (macros &body body)
(with-local-macro-environment (local-macro-dict *macro-env*)
(dolist (macro macros)
(destructuring-bind (name arglist &body body)
macro
(setf (gethash name local-macro-dict)
(eval (make-ps-macro-function arglist body)))))
(ps-compile `(locally ,@body))))
(define-expression-operator symbol-macrolet (symbol-macros &body body)
(with-local-macro-environment (local-macro-dict *symbol-macro-env*)
(with-declaration-effects (body body)
(let (local-var-bindings)
(dolist (macro symbol-macros)
(destructuring-bind (name expansion) macro
(setf (gethash name local-macro-dict) (lambda (x) (declare (ignore x)) expansion))
(push name local-var-bindings)))
(let ((*enclosing-lexicals* (append local-var-bindings *enclosing-lexicals*)))
(ps-compile `(progn ,@body)))))))
(define-expression-operator defmacro (name args &body body)
(eval `(defpsmacro ,name ,args ,@body))
nil)
(define-expression-operator define-symbol-macro (name expansion)
(eval `(define-ps-symbol-macro ,name ,expansion))
nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; assignment
(defun assignment-op (op)
(getf '(ps-js:+ ps-js:+=
ps-js:~ ps-js:~=
ps-js:& ps-js:&=
ps-js:- ps-js:-=
ps-js:* ps-js:*=
ps-js:% ps-js:%=
ps-js:>> ps-js:>>=
ps-js:^ ps-js:^=
ps-js:<< ps-js:<<=
ps-js:>>> ps-js:>>>=
ps-js:/ ps-js:/=)
op))
(define-expression-operator ps-assign (lhs rhs)
(let ((rhs (ps-macroexpand rhs)))
(if (and (listp rhs) (eq (car rhs) 'progn))
(ps-compile `(progn ,@(butlast (cdr rhs))
(ps-assign ,lhs ,(car (last (cdr rhs))))))
(let ((lhs (compile-expression lhs))
(rhs (compile-expression rhs)))
(aif (and (listp rhs)
(= 3 (length rhs))
(equal lhs (second rhs))
(assignment-op (first rhs)))
(list it lhs (if (fourth rhs)
(cons (first rhs) (cddr rhs))
(third rhs)))
(list 'ps-js:= lhs rhs))))))
(define-statement-operator defvar (name &optional
(value (values) value-provided?)
documentation)
;; this must be used as a top-level form, otherwise the resulting
;; behavior will be undefined.
(declare (ignore documentation)) ; TODO: print docstring
(pushnew name *special-variables*)
(ps-compile (if value-provided?
`(when (undefined ,name) (var ,name ,value))
(list 'var name))))
(define-statement-operator defparameter
(name &optional (value (values) value-provided?) documentation)
;; this must be used as a top-level form, otherwise the resulting
;; behavior will be undefined.
(declare (ignore documentation)) ; TODO: print docstring
(pushnew name *special-variables*)
(ps-compile `(var ,name ,@(when value-provided? (list value)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; iteration
(defun make-for-vars/inits (init-forms)
(mapcar (lambda (x)
(cons (ps-macroexpand (if (atom x) x (first x)))
(compile-expression (if (atom x) nil (second x)))))
init-forms))
(defun compile-loop-body (loop-vars body)
(let (compiled-body loop-closures?)
(let* ((in-loop-scope? t)
(*loop-scope-lexicals* ())
(*loop-scope-lexicals-captured* ())
(*ps-gensym-counter* *ps-gensym-counter*))
(setf compiled-body (compile-statement `(progn ,@body))
loop-closures? *loop-scope-lexicals-captured*))
(if loop-closures?
(compile-statement `(progn ((lambda () ,@body))))
compiled-body)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; evaluation
(define-expression-operator quote (x)
(flet ((quote% (expr) (when expr `',expr)))
(compile-expression
(typecase x
(cons `(array ,@(mapcar #'quote% x)))
((or null (eql [])) '(array))
(keyword x)
(symbol (symbol-to-js-string x))
(number x)
(string x)
(vector `(array ,@(loop for el across x collect (quote% el))))))))
(define-expression-operator eval-when (situation-list &body body)
"The body is evaluated only during the given situations. The
accepted situations are :load-toplevel, :compile-toplevel,
and :execute. The code in BODY is assumed to be Common Lisp code
in :compile-toplevel and :load-toplevel sitations, and Parenscript
code in :execute."
(when (and (member :compile-toplevel situation-list)
(member *compilation-level* '(:toplevel :inside-toplevel-form)))
(eval `(progn ,@body)))
(if (member :execute situation-list)
(ps-compile `(progn ,@body))
(ps-compile `(progn))))

153
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/src/utils.lisp Normal file
View file

@ -0,0 +1,153 @@
;;; Copyright 2005 Manuel Odendahl
;;; Copyright 2005-2006 Edward Marco Baringer
;;; Copyright 2007 Attila Lendvai
;;; Copyright 2007 Red Daly
;;; Copyright 2007-2012 Vladimir Sedach
;;; Copyright 2008 Travis Cross
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript)
(define-condition simple-style-warning (simple-warning style-warning)
())
(let ((cache (make-hash-table :test 'equal)))
(defun encode-js-identifier (identifier)
"Given a string, produces to a valid JavaScript identifier by
following transformation heuristics case conversion. For example,
paren-script becomes parenScript, *some-global* becomes SOMEGLOBAL."
(when (and (not (string= identifier "[]"))
(find #\[ identifier))
(warn 'simple-style-warning
:format-control
"Parenscript symbol ~A contains a literal array accessor.
This compound naming convention is deprecated and will be removed!
Use AREF, ELT, GETPROP, @, or CHAIN instead."
:format-arguments (list identifier)))
(when (find #\. identifier)
(warn 'simple-style-warning
:format-control
"Parenscript symbol ~A contains one or more dot operators.
This compound naming convention is deprecated and will be removed!
Use GETPROP, @, or CHAIN instead."
:format-arguments (list identifier)))
(or
(gethash identifier cache)
(setf
(gethash identifier cache)
(cond
((some (lambda (c) (find c "-*+!?#@%/=:<>^")) identifier)
(let ((lowercase t)
(all-uppercase nil))
(acond
((nth-value 1
(cl-ppcre:scan-to-strings
"[\\*|\\+](.+)[\\*|\\+](.*)"
identifier :sharedp t))
(setf all-uppercase t
identifier (concatenate
'string (aref it 0) (aref it 1))))
((and (> (length identifier) 1)
(or (eql (char identifier 0) #\+)
(eql (char identifier 0) #\*)))
(setf lowercase nil
identifier (subseq identifier 1))))
(with-output-to-string (acc)
(loop
for c across identifier
do (acond
((eql c #\-)
(setf lowercase (not lowercase)))
((position c "!?#@%+*/=:<>^")
(write-sequence
(aref #("bang" "what" "hash" "at" "percent"
"plus" "star" "slash" "equals" "colon"
"lessthan" "greaterthan" "caret")
it)
acc))
(t
(write-char
(if (and lowercase (not all-uppercase))
(char-downcase c)
(char-upcase c))
acc)
(setf lowercase t)))))))
(#.(eql :invert (readtable-case
(named-readtables:find-readtable :parenscript)))
(cond
((every #'upper-case-p
(remove-if-not #'alpha-char-p identifier))
(string-downcase identifier))
((every #'lower-case-p
(remove-if-not #'alpha-char-p identifier))
(string-upcase identifier))
(t identifier)))
(t identifier))))))
(defun ordered-set-difference (list1 list2 &key (test #'eql))
"CL set-difference may not preserve order."
(reduce (lambda (list el) (remove el list :test test))
(cons list1 list2)))
(defun flatten (x &optional acc)
(cond ((null x) acc)
((atom x) (cons x acc))
(t (flatten (car x) (flatten (cdr x) acc)))))
(defun flatten-blocks (body)
(when body
(if (and (listp (car body)) (eq 'ps-js:block (caar body)))
(append (flatten-blocks (cdr (car body)))
(flatten-blocks (cdr body)))
(cons (car body) (flatten-blocks (cdr body))))))
(defun tree-find (A tree)
(or (equal A tree)
(when (consp tree)
(loop for x on tree thereis
(or (tree-find A (car x))
(unless (listp (cdr x))
(equal A (cdr x))))))))
(defun parse-semver (semver-string)
(let ((semver-list (cl-ppcre:split "\\." semver-string))
(semver-scaled 0))
(dotimes (i 3)
(incf semver-scaled
(* (expt 1000 (- 2 i))
(parse-integer (or (nth i semver-list) "0")))))
semver-scaled))
(defun js-target-at-least (version)
(>= (parse-semver *js-target-version*) (parse-semver version)))

1092
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/tests/eval-tests.lisp Normal file
View file

File diff suppressed because it is too large Load diff

4507
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/tests/output-tests.lisp Normal file
View file

File diff suppressed because it is too large Load diff

170
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/tests/package-system-tests.lisp Normal file
View file

@ -0,0 +1,170 @@
;;; Copyright 2007 Red Daly
;;; Copyright 2007 Vladimir Sedach
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript.tests)
(fiveam:in-suite package-system-tests)
(test-ps-js operator-packages1
(#:new)
"new();")
(defpackage #:parenscript.tests.my-library
(:use #:parenscript))
(setf (ps-package-prefix '#:parenscript.tests.my-library)
"my_library_")
(test-ps-js lib-function1
(defun parenscript.tests.my-library::library-function (x y)
(+ x y))
"function my_library_libraryFunction(x, y) {
return x + y;
};")
(test-ps-js lib-function2
(defun parenscript.tests.my-library::library-function
(parenscript.tests.my-library::x
&key ((:y parenscript.tests.my-library::z) 1))
(+ parenscript.tests.my-library::x parenscript.tests.my-library::z))
"function my_library_libraryFunction(my_library_x) {
var _js2 = arguments.length;
for (var n1 = 1; n1 < _js2; n1 += 2) {
switch (arguments[n1]) {
case 'y':
my_library_z = arguments[n1 + 1];
};
};
var my_library_z = 'undefined' === typeof my_library_z ? 1 : my_library_z;
return my_library_x + my_library_z;
};")
(test-ps-js uniform-symbol-handling1
(progn (create parenscript.tests.my-library::foo 1)
(getprop foo 'parenscript.tests.my-library::foo))
"{ my_library_foo : 1 };
foo.my_library_foo;")
(let ((map (make-hash-table)))
(defun symbol-obfuscator (symbol)
(or #1=(gethash symbol map)
(setf #1# (make-symbol (map 'string (lambda (x)
(code-char (1+ (char-code x))))
(symbol-name symbol)))))))
(defpackage #:parenscript.tests.obfuscate-me)
(obfuscate-package '#:parenscript.tests.obfuscate-me
#'symbol-obfuscator)
(test-ps-js obfuscation1
(defun parenscript.tests.obfuscate-me::libfun2 (a b parenscript.tests.obfuscate-me::foo)
(+ a (parenscript.tests.my-library::library-function b parenscript.tests.obfuscate-me::foo)))
"function mjcgvo3(a, b, gpp) {
__PS_MV_REG = [];
return a + my_library_libraryFunction(b, gpp);
};")
(defpackage #:parenscript.tests.obfuscate-and-prefix)
(obfuscate-package '#:parenscript.tests.obfuscate-and-prefix #'symbol-obfuscator)
(setf (ps-package-prefix '#:parenscript.tests.obfuscate-and-prefix) "__FOO___")
(test-ps-js obfuscate-and-prefix
(defun parenscript.tests.obfuscate-and-prefix::xfun (a parenscript.tests.obfuscate-and-prefix::b parenscript.tests.my-library::d)
(* a
(parenscript.tests.obfuscate-me::libfun2 parenscript.tests.obfuscate-and-prefix::b a)
(parenscript.tests.my-library::library-function parenscript.tests.my-library::d parenscript.tests.obfuscate-and-prefix::b)))
"function __FOO___ygvo(a, __FOO___c, my_library_d) {
__PS_MV_REG = [];
return a * mjcgvo3(__FOO___c, a) * my_library_libraryFunction(my_library_d, __FOO___c);
};")
(defpackage #:parenscript.tests.pststpkg
(:use #:parenscript))
(setf (ps-package-prefix '#:parenscript.tests.pststpkg) "prefix_")
(fiveam:test namespace1 ()
(fiveam:is (string=
(ps* 'parenscript.tests.pststpkg::foo)
"prefix_foo;")))
(cl:in-package #:parenscript.tests.pststpkg)
(parenscript.tests::test-ps-js namespace-and-special-forms
(defun foo ()
(let ((foo (create bar 1 not-a-keyword something)))
(return-from foo (and (not foo) (+ (getprop foo 'bar) some-other-var)))))
"function prefix_foo() {
var foo1 = { prefix_bar : 1, prefix_notAKeyword : prefix_something };
return !foo1 && foo1.prefix_bar + prefix_someOtherVar;
};")
(parenscript.tests::test-ps-js exported-interface
(defun parenscript.tests:interface-function (baz)
(+ baz parenscript.tests.obfuscate-me::foo))
"function interfaceFunction(prefix_baz) {
return prefix_baz + gpp;
};")
(parenscript.tests::test-ps-js prefixed-symbol-macro-obj1
(symbol-macrolet ((x (+ 1 2)))
(ps:create x x))
"{ prefix_x : 1 + 2 };")
(cl:in-package #:parenscript.tests)
(fiveam:test compile-stream-in-package
(fiveam:is
(string=
(with-input-from-string (s "
(defun parenscript.tests.obfuscate-and-prefix::xfun (a parenscript.tests.obfuscate-and-prefix::b parenscript.tests.my-library::d)
(* a
(parenscript.tests.obfuscate-me::libfun2 parenscript.tests.obfuscate-and-prefix::b a)
(parenscript.tests.my-library::library-function parenscript.tests.my-library::d parenscript.tests.obfuscate-and-prefix::b)))
(in-package #:parenscript.tests.pststpkg)
(defun parenscript.tests:interface-function (baz)
(+ baz parenscript.tests.obfuscate-me::foo))
")
(ps-compile-stream s))
"function __FOO___ygvo(a, __FOO___c, my_library_d) {
__PS_MV_REG = [];
return a * mjcgvo3(__FOO___c, a) * my_library_libraryFunction(my_library_d, __FOO___c);
};
function interfaceFunction(prefix_baz) {
return prefix_baz + gpp;
};
")))

15
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/tests/test-package.lisp Normal file
View file

@ -0,0 +1,15 @@
(in-package #:cl)
(named-readtables:in-readtable :parenscript)
(defpackage #:parenscript.tests
(:use #:cl #:parenscript)
(:export
#:parenscript-tests
#:run-tests
#:interface-function
#:test-js-eval
#:test-js-eval-epsilon
#:jsarray))
(defpackage #:parenscript.eval-tests
(:use #:cl #:parenscript #:parenscript.tests))

86
quicklisp/dists/quicklisp/software/Parenscript-2.7.1/tests/test.lisp Normal file
View file

@ -0,0 +1,86 @@
;;; Copyright 2005-2006 Henrik Hjelte
;;; Copyright 2007-2012 Vladimir Sedach
;;; SPDX-License-Identifier: BSD-3-Clause
;;; Redistribution and use in source and binary forms, with or
;;; without modification, are permitted provided that the following
;;; conditions are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. 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.
;;; 3. Neither the name of the copyright holder 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.
(in-package #:parenscript.tests)
(defun normalize-js-output (str)
(cl-ppcre:regex-replace-all "\\s+" str " "))
(defmacro test-ps-js (testname parenscript javascript
&key (js-target-version *js-target-version*))
`(fiveam:test ,testname ()
(fiveam:is
(string= (normalize-js-output ,javascript)
(normalize-js-output
(let ((*js-target-version* ,js-target-version))
(ps-doc* ',parenscript)))))))
(defun js-repr (x)
(cond ((or (consp x) (simple-vector-p x))
(cl-js:js-array
(make-array (length x)
:initial-contents (map 'vector #'js-repr x)
:adjustable t)))
((null x) :null)
(t x)))
(defmacro %test-js-eval (testname parenscript test-statement
js-target-version)
`(fiveam:test ,testname ()
(cl-js:with-js-env ()
(let* ((*js-target-version* ,js-target-version)
(js-result (cl-js:run-js (ps-doc* ',parenscript))))
,test-statement))))
(defmacro test-js-eval (testname parenscript expected
&key (js-target-version *js-target-version*))
`(%test-js-eval ,testname ,parenscript
(fiveam:is (equalp js-result (js-repr ,expected)))
,js-target-version))
(defmacro test-js-eval-epsilon (testname parenscript expected
&key (js-target-version *js-target-version*))
`(%test-js-eval ,testname ,parenscript
(fiveam:is (< (abs (- js-result ,expected)) 0.0001))
,js-target-version))
(fiveam:def-suite parenscript-tests)
(fiveam:def-suite output-tests :in parenscript-tests)
(fiveam:def-suite package-system-tests :in parenscript-tests)
(fiveam:def-suite eval-tests :in parenscript-tests)
(defun run-tests ()
(let ((*js-string-delimiter* #\'))
(fiveam:run! 'parenscript-tests)))

13
quicklisp/dists/quicklisp/software/alexandria-20220707-git/.boring Normal file
View file

@ -0,0 +1,13 @@
# Boring file regexps:
~$
^_darcs
^\{arch\}
^.arch-ids
\#
\.dfsl$
\.ppcf$
\.fasl$
\.x86f$
\.fas$
\.lib$
^public_html

4
quicklisp/dists/quicklisp/software/alexandria-20220707-git/.gitignore vendored Normal file
View file

@ -0,0 +1,4 @@
*.fasl
*~
\#*
*.patch

27
quicklisp/dists/quicklisp/software/alexandria-20220707-git/.gitlab-ci.yml Normal file
View file

@ -0,0 +1,27 @@
include:
project: 'clci/gitlab-ci'
ref: release/v2-dev
file:
- definitions.gitlab-ci.yml
- test-pipeline.gitlab-ci.yml
variables:
CLCI_INSTALL_QUICKLISP_CLIENT: "yes"
# Off by default because it's proprietary and has a separate license.
CLCI_TEST_ALLEGRO: "yes"
# Off by default because the Docker image is a bit out of date, due to
# upstream churn.
CLCI_TEST_CLASP: "yes"
# Alexandria is a non-commercial project, so we can use the express version
# of Allegro for testing.
I_AGREE_TO_ALLEGRO_EXPRESS_LICENSE: "yes"
# This section is not strictly required, but prevents Gitlab CI from launching
# multiple redundent pipelines when a Merge Request is opened.
workflow:
rules:
- if: '$CI_PIPELINE_SOURCE == "merge_request_event"'
- if: '$CI_COMMIT_BRANCH && $CI_OPEN_MERGE_REQUESTS'
when: never
- if: '$CI_COMMIT_BRANCH'
- if: '$CI_COMMIT_TAG'

9
quicklisp/dists/quicklisp/software/alexandria-20220707-git/AUTHORS Normal file
View file

@ -0,0 +1,9 @@
ACTA EST FABULA PLAUDITE
Nikodemus Siivola
Attila Lendvai
Marco Baringer
Robert Strandh
Luis Oliveira
Tobias C. Rittweiler

37
quicklisp/dists/quicklisp/software/alexandria-20220707-git/LICENCE Normal file
View file

@ -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.

62
quicklisp/dists/quicklisp/software/alexandria-20220707-git/README Normal file
View file

@ -0,0 +1,62 @@
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://gitlab.common-lisp.net/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 prepare pull requests in
gitlab, though we also can pull branches off github.
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.
Versioning & Changes:
Be advised that the ALEXANDRIA-1 package is frozen; there are so many
existing users that any newly exported symbols are likely to break
someone's code.
For that reason an ALEXANDRIA-2 package is now open for additions;
to make switching over easier it will include all the symbols from
ALEXANDRIA-1 as well [just change your (:USE ALEXANDRIA) to
(:USE ALEXANDRIA-2) to get the new functions in your package].
Alexandria will be running 1.x version numbers until ALEXANDRIA-2 is
frozen as well; then a 2.0.0 will be released.

18
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/arrays.lisp Normal file
View file

@ -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))

90
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/binding.lisp Normal file
View file

@ -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))))

91
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/conditions.lisp Normal file
View file

@ -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)))))))))

112
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/control-flow.lisp Normal file
View file

@ -0,0 +1,112 @@
(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))
(let ((length (length possibilities)))
(cond
((= 1 length)
(first possibilities))
((every #'constantp possibilities)
`(svref (load-time-value (vector ,@possibilities))
(random ,length)))
(T
(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 ((,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 returned as primary, and T as secondary
value."
(with-gensyms (xor tmp true)
`(let (,tmp ,true)
(declare (ignorable ,tmp))
(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)))

37
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/definitions.lisp Normal file
View file

@ -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))))

14
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/features.lisp Normal file
View file

@ -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))))))))

161
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/functions.lisp Normal file
View file

@ -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))

101
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/hash-tables.lisp Normal file
View file

@ -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))

182
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/io.lisp Normal file
View file

@ -0,0 +1,182 @@
;; 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))
(list :element-type (or ,element-type
(default-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)))
(defun default-element-type ()
;; On Lispworks, ELEMENT-TYPE :DEFAULT selects the appropriate
;; subtype of CHARACTER for the given external format which can
;; represent all possible characters.
#+lispworks :default
;; The spec says that OPEN's default ELEMENT-TYPE (when it is not
;; specified) is CHARACTER, but on AllegroCL it's (UNSIGNED-BYTE 8).
;; No harm done by specifying it on other implementations.
#-lispworks 'character)
(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)
(element-type (stream-element-type stream)))
(with-output-to-string (datum nil :element-type element-type)
(let ((buffer (make-array buffer-size :element-type element-type)))
(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 "~@<Could not read enough bytes from the input to fulfill ~
the :START ~S requirement in ~S.~:@>" '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 "~@<Could not read enough bytes from the input to fulfill ~
the :END ~S requirement in ~S.~:@>" '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))

369
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/lists.lisp Normal file
View file

@ -0,0 +1,369 @@
(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
(unless (listp list)
(error 'type-error :datum list :expected-type 'list))
(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 property-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)))

370
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/macros.lisp Normal file
View file

@ -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 ((<gensym-1> <expr-1>)
...
(<gensym-n> <expr-n>))
<res>)
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)))

295
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/numbers.lisp Normal file
View file

@ -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))

243
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/package.lisp Normal file
View file

@ -0,0 +1,243 @@
(defpackage :alexandria
(:nicknames :alexandria.1.0.0 :alexandria-1)
(: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
))

564
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/sequences.lisp Normal file
View file

@ -0,0 +1,564 @@
(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.
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))
(sublist (nthcdr start sequence))
(small-enough-threshold 100))
;; It's fine to use a pure list shuffle if the number of items
;; to shuffle is small enough, but otherwise it's more
;; time-efficient to create an intermediate vector to work on.
;; I picked the threshold based on rudimentary benchmarks on my
;; machine, where both branches take about the same time.
(if (< n small-enough-threshold)
(do ((tail sublist (cdr tail)))
((zerop n))
(rotatef (car tail) (car (nthcdr (random n) tail)))
(decf n))
(let ((intermediate-vector (replace (make-array n) sublist)))
(replace sublist (shuffle intermediate-vector))))))
(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)))))

6
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/strings.lisp Normal file
View file

@ -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))

65
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/symbols.lisp Normal file
View file

@ -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))))))

2075
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/tests.lisp Normal file
View file

File diff suppressed because it is too large Load diff

137
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-1/types.lisp Normal file
View file

@ -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.")

43
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-2/arrays.lisp Normal file
View file

@ -0,0 +1,43 @@
(in-package :alexandria-2)
(defun dim-in-bounds-p (dimensions &rest subscripts)
"Mirrors cl:array-in-bounds-p, but takes dimensions (list of integers) as its
first argument instead of an array.
(array-in-bounds-p arr ...) == (dim-in-bounds-p (array-dimensions arr) ...)"
(and (= (length dimensions) (length subscripts))
(every (lambda (i d) (and (integerp i) (< -1 i d)))
subscripts dimensions)))
(defun row-major-index (dimensions &rest subscripts)
"Mirrors cl:array-row-major-index, but takes dimensions (list of integers)
as its first argument instead of an array.
Signals an error if lengths of dimensions and subscripts are not equal
(array-row-major-index arr ...) == (row-major-index (array-dimensions arr) ...)"
(unless (apply #'dim-in-bounds-p dimensions subscripts)
(error (format nil "Indices ~a invalid for dimensions ~a" subscripts dimensions)))
(loop with word-idx = 0
with dimprod = 1
for dim-size in (reverse dimensions)
for dim-idx in (reverse subscripts)
do
(incf word-idx (* dim-idx dimprod))
(setf dimprod (* dimprod dim-size))
finally (return word-idx)))
(defun rmajor-to-indices (dimensions index)
"The inverse function to row-major-index. Given a set of dimensions and a
row-major index, produce the list of indices <subscripts> such that
(row-major-index dimensions sucscripts) = index"
(when (null dimensions) (error "Dimensions must be non-null"))
(let ((size (reduce #'* dimensions)))
(unless (< -1 index size)
(error (format nil "Row-major index ~a invalid for array of total size ~a" index size))))
(labels ((rec (dimensions index word-sizes acc)
(if (null (cdr dimensions))
(reverse (cons index acc))
(multiple-value-bind (idx remainder) (floor index (car word-sizes))
(rec (cdr dimensions) remainder (cdr word-sizes) (cons idx acc))))))
(rec dimensions index
(cdr (reduce (lambda (x y) (cons (* x (car y)) y)) dimensions
:initial-value '(1) :from-end t))
nil)))

52
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-2/control-flow.lisp Normal file
View file

@ -0,0 +1,52 @@
(in-package :alexandria-2)
(defun line-up-iter (thread-first-p acc forms)
"Iterative implementation for `thread-iter'.
The THREAD-FIRST-P decides where to thread the FORMS, accumulating in ACC."
(if forms
(line-up-iter thread-first-p
(let ((form (car forms)))
(if (listp form)
(if thread-first-p
(apply #'list (car form) acc (cdr form))
(append form (cons acc nil)))
(list form acc)))
(cdr forms))
acc))
(defmacro line-up-first (&rest forms)
"Lines up FORMS elements as the first argument of their successor.
Example:
(line-up-first
5
(+ 20)
/
(+ 40))
is equivalent to:
(+ (/ (+ 5 20)) 40)
Note how the single '/ got converted into a list before
threading."
(line-up-iter t (car forms) (cdr forms)))
(defmacro line-up-last (&rest forms)
"Lines up FORMS elements as the last argument of their successor.
Example:
(line-up-last
5
(+ 20)
/
(+ 40))
is equivalent to:
(+ 40 (/ (+ 20 5)))
Note how the single '/ got converted into a list before
threading."
(line-up-iter nil (car forms) (cdr forms)))

24
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-2/lists.lisp Normal file
View file

@ -0,0 +1,24 @@
(in-package :alexandria-2)
(defun delete-from-plist* (plist &rest keys)
"Just like REMOVE-FROM-PLIST, but this version may destructively modify the
provided PLIST.
The second return value is an alist of the removed items, in unspecified order."
;; TODO: a plist?
(declare (optimize speed))
(loop with head = plist
with tail = nil ; a nil tail means an empty result so far
with kept = ()
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)))
(push (cons key (car rest))
kept)
(if tail
(setf (cdr tail) next)
(setf head next)))
;; keep this pair
(setf tail rest))
finally (return (values head kept))))

19
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-2/package.lisp Normal file
View file

@ -0,0 +1,19 @@
(in-package :cl-user)
(defpackage :alexandria-2
(:nicknames :alexandria.2)
(:use :cl :alexandria.1.0.0)
#+sb-package-locks
(:lock t)
(:export
;; arrays
#:dim-in-bounds-p
#:row-major-index
#:rmajor-to-indices
;; lists
#:delete-from-plist*
;; control-flow
#:line-up-first
#:line-up-last
#:subseq*
. #. (let (res) (do-external-symbols (sym :alexandria.1.0.0) (push sym res)) res)
))

9
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-2/sequences.lisp Normal file
View file

@ -0,0 +1,9 @@
(in-package :alexandria-2)
(defun subseq* (sequence start &optional end)
"Like SUBSEQ, but limits END to the length."
(subseq sequence start
(if end
(min end (length sequence)))))

189
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria-2/tests.lisp Normal file
View file

@ -0,0 +1,189 @@
(in-package :cl-user)
(defpackage :alexandria-2/tests
(:use :cl :alexandria-2 #+sbcl :sb-rt #-sbcl :rtest)
(:import-from #+sbcl :sb-rt #-sbcl :rtest
#:*compile-tests* #:*expected-failures*))
(in-package :alexandria-2/tests)
;; Arrays Tests
(deftest dim-in-bounds-p.0
(dim-in-bounds-p '(2 2) 0 1 1)
nil)
(deftest dim-in-bounds-p.1
(dim-in-bounds-p '(2 2) 0 1)
t)
(deftest dim-in-bounds-p.2
(dim-in-bounds-p '(2 2) 0 2)
nil)
(deftest row-major-index.0
(let* ((dims '(4 3 2 1))
(test-arr (make-array dims))
(idcs '(0 0 0 0)))
(= 0 (apply #'row-major-index dims idcs) (apply #'array-row-major-index test-arr idcs)))
t)
(deftest row-major-index.1
(let* ((dims '(4 3 2 1))
(test-arr (make-array dims))
(idcs '(3 2 1 0)))
(= 23 (apply #'row-major-index dims idcs) (apply #'array-row-major-index test-arr idcs)))
t)
(deftest row-major-index.2
(let* ((dims '(4 3 2 1))
(test-arr (make-array dims))
(idcs '(2 1 0 0)))
(= 14 (apply #'row-major-index dims idcs) (apply #'array-row-major-index test-arr idcs)))
t)
(deftest row-major-index.3
(let* ((dims '(4 3 2 1))
(test-arr (make-array dims))
(idcs '(0 2 1 0)))
(= 5 (apply #'row-major-index dims idcs) (apply #'array-row-major-index test-arr idcs)))
t)
(deftest rmajor-to-indices.0
(loop for dims in '((70 30 4 2) (50 200 5 7) (5 4 300 2) (5 2 30 19))
with index = 173
with indices = '(4 0 3 1)
always (and (= index (apply #'row-major-index dims (rmajor-to-indices dims index)))
(equalp indices (rmajor-to-indices dims
(apply #'row-major-index dims indices)))))
t)
;; List Tests
(deftest delete-from-plist*.middle
(let ((input (list 'a 1 'b 2 'c 3 'd 4 'd 5)))
(multiple-value-list (delete-from-plist* input 'b 'c)))
((a 1 d 4 d 5)
((c . 3) (b . 2))))
(deftest delete-from-plist*.start
(let ((input (list 'a 1 'b 2 'c 3 'd 4 'd 5)))
(multiple-value-list (delete-from-plist* input 'a 'c)))
((b 2 d 4 d 5)
((c . 3) (a . 1))))
;; Control Flow tests
(deftest line-up-first.no-form
(values
(equal (macroexpand '(line-up-first 5))
5)
(equal (macroexpand '(line-up-first (+ 1 2)))
'(+ 1 2)))
t
t)
(deftest line-up-first.function-names-are-threaded
(values
(equal (macroexpand '(line-up-first 5 -))
'(- 5))
(equal (macroexpand '(line-up-first (+ 1 2) -))
'(- (+ 1 2))))
t
t)
(deftest line-up-first.list-promotion
(macroexpand '(line-up-first
5
(+ 20)
(/ 25)
-
(+ 40)))
(+ (- (/ (+ 5 20) 25)) 40)
t)
(deftest line-up-first.multiple-args
(macroexpand '(line-up-first
"this-is-a-string"
(subseq 0 4)))
(subseq "this-is-a-string" 0 4)
t)
(deftest line-up-first.several-examples
(values
(equal (line-up-first (+ 40 2)) 42)
(equal (line-up-first
5
(+ 20)
(/ 25)
-
(+ 40)) 39)
(equal (line-up-first
"this-is-a-string"
(subseq 4 5)
(string-trim "--------good"))
"good"))
t
t
t)
;; Thread last tests
(deftest line-up-last.no-forms
(values
(equal (macroexpand '(line-up-last 5)) 5)
(equal (macroexpand '(line-up-last (+ 1 2))) '(+ 1 2)))
t
t)
(deftest line-up-last.function-names-are-threaded
(values (equal (macroexpand
'(line-up-last 5
-))
'(- 5))
(equal (macroexpand
'(line-up-last (+ 1 2)
-))
'(- (+ 1 2))))
t
t)
(deftest line-up-last.lisp-promotion
(macroexpand '(line-up-last
5
(+ 20)
(/ 25)
-
(+ 40)))
(+ 40 (- (/ 25 (+ 20 5))))
t)
(deftest line-up-last.several-examples
(values (equal (line-up-last (+ 40 2)) 42)
(equal (line-up-last
5
(+ 20)
(/ 25)
-
(+ 40))
39)
(equal (line-up-last
(list 1 -2 3 -4 5)
(mapcar #'abs)
(reduce #'+)
(format nil "abs sum is: ~D"))
"abs sum is: 15"))
t
t
t)
(deftest subseq*.1
(values (subseq* "abcdef" 0 3)
(subseq* "abcdef" 1 3)
(subseq* "abcdef" 1)
(subseq* "abcdef" 1 9))
"abc"
"bc"
"bcdef"
"bcdef")

87
quicklisp/dists/quicklisp/software/alexandria-20220707-git/alexandria.asd Normal file
View file

@ -0,0 +1,87 @@
(defsystem "alexandria"
:version "1.0.1"
: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")
(:module "alexandria-1"
:components ((: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"))))
(:module "alexandria-2"
:components ((:static-file "tests.lisp")
(:file "package")
(:file "arrays" :depends-on ("package"))
(:file "control-flow" :depends-on ("package"))
(:file "sequences" :depends-on ("package"))
(:file "lists" :depends-on ("package")))))
:in-order-to ((test-op (test-op "alexandria/tests"))))
(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 <nikodemus@sb-studio.net>, and others."
:depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt)
:components ((:file "alexandria-1/tests")
(:file "alexandria-2/tests"))
:perform (test-op (o c)
(let ((unexpected-failure-p nil))
(flet ((run-tests (&rest args)
(unless (apply (intern (string '#:run-tests) '#:alexandria/tests) args)
(setf unexpected-failure-p t))))
(run-tests :compiled nil)
(run-tests :compiled t))
(when unexpected-failure-p
(error "Unexpected test failure")))))

10
quicklisp/dists/quicklisp/software/alexandria-20220707-git/doc/.gitignore vendored Normal file
View file

@ -0,0 +1,10 @@
include
alexandria.aux
alexandria.fn
alexandria.fns
alexandria.log
alexandria.pdf
alexandria.toc
alexandria.tp
alexandria.tps

31
quicklisp/dists/quicklisp/software/alexandria-20220707-git/doc/Makefile Normal file
View file

@ -0,0 +1,31 @@
.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))' \
--eval '(with-compilation-unit () (load "docstrings.lisp"))' \
--eval '(sb-texinfo:generate-includes "include/" (list :alexandria-1 :alexandria-2) :base-package :alexandria)' \
--eval '(quit)'
pdf: include
texi2pdf alexandria.texinfo
html: include
makeinfo --html --no-split alexandria.texinfo
info: include
makeinfo alexandria.texinfo
publish:
rsync -va alexandria.pdf alexandria.html common-lisp.net:/project/alexandria/public_html/draft/

288
quicklisp/dists/quicklisp/software/alexandria-20220707-git/doc/alexandria.texinfo Normal file
View file

@ -0,0 +1,288 @@
\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
Unless otherwise noted, the symbols are exported from
the @code{"ALEXANDRIA"} package; only newer symbols
that require @code{"ALEXANDRIA-2"} are fully qualified.
The package @code{"ALEXANDRIA-2"} includes all the symbols
from @code{"ALEXANDRIA-1"}.
@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
@include include/macro-alexandria-2-line-up-first.texinfo
@include include/macro-alexandria-2-line-up-last.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-2-delete-from-plist-star.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

903
quicklisp/dists/quicklisp/software/alexandria-20220707-git/doc/docstrings.lisp Normal file
View file

@ -0,0 +1,903 @@
;;; -*- 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 <rudi@constantly.at>, 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
(defun short-name-for-symbol (symbol &optional (package *base-package*))
"Given a SYMBOL, return its name if it's available in PACKAGE,
or PACKAGE:SYMBOL otherwise."
(format nil "~@[~a:~]~a"
(unless (eq symbol
(find-symbol (symbol-name symbol)
package))
(shortest-package-name (symbol-package symbol)))
(symbol-name symbol)))
(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))
(short-name-for-symbol name))
(defmethod name-using-kind/name (kind (name list) doc)
(declare (ignore kind))
(assert (setf-name-p name))
(let ((name (short-name-for-symbol (second name))))
(format nil "(setf ~A)" 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 shortest-package-name (package)
(car (sort (copy-list (cons (package-name package) (package-nicknames package)))
#'< :key #'length)))
(defun short-package-name (package)
(unless (eq package *base-package*)
(shortest-package-name package)))
;;; 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))
(short-name-for-symbol name))
(defmethod title-using-kind/name (kind (name list) doc)
(declare (ignore kind))
(assert (setf-name-p name))
(format nil "(setf ~A)" (short-name-for-symbol (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) (lambda-list 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 &optional ht)
"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)
(unless (and ht
(nth-value 1 (alexandria:ensure-gethash symbol ht t)))
(setf (gethash symbol ht) t)
(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.
;; Texinfo > 5 doesn't allow "&" in macro names any more;
;; see also https://bugs.launchpad.net/asdf/+bug/1172567 or
;; ASDF commit dfa4643b212b194f2d673b6f0d9c7d4b19d823ba
(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
\"<doc-type>_<packagename>_<symbol-name>.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))
(syms-seen (make-hash-table :test #'eq)))
(ensure-directories-exist directory)
(dolist (package packages)
(dolist (doc (collect-documentation (find-package package) syms-seen))
(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 \"<packagename>.texinfo\" is generated.
The definitions can be referenced using Texinfo statements like
@ref{<doc-type>_<packagename>_<symbol-name>.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)))

5
quicklisp/dists/quicklisp/software/alexandria-20220707-git/scripts/ci-test.lisp Normal file
View file

@ -0,0 +1,5 @@
;; Install all the deps
(ql:quickload "alexandria/tests")
;; Run the tests!
(asdf:test-system "alexandria")

34
quicklisp/dists/quicklisp/software/anaphora-20220220-git/.travis.yml Normal file
View file

@ -0,0 +1,34 @@
language: lisp
sudo: required
env:
matrix:
- LISP=abcl
- LISP=allegro
- LISP=sbcl
- LISP=sbcl32
- LISP=ccl
- LISP=ccl32
- LISP=ecl
- LISP=clisp
- LISP=clisp32
- LISP=cmucl
matrix:
allow_failures:
# Disabled until issue #6 is fixed.
- env: LISP=clisp
- env: LISP=clisp32
# Disabled until cim supports cmucl.
- env: LISP=cmucl
install:
- curl -L https://github.com/tokenrove/cl-travis/raw/master/install.sh | sh
- if [ "${LISP:(-2)}" = "32" ]; then
sudo apt-get install -qq -y libc6-dev-i386;
fi
script:
- cl -e '(ql:quickload :anaphora/test)
(unless (asdf:oos :test-op :anaphora/test)
(uiop:quit 1))'

Some files were not shown because too many files have changed in this diff Show more