") ", 24 September 2009")
-
- (") ", 24 September 2009")
+
+ (
I programmed this thoughtlessly. Sorry for the inconvenience.")
- :banner (force-byte-vector "500 Internal error"))))))
+ (format *error-output* "~&PAGE ERROR ~A~&--- ~A~&-AGAIN PAGE ERROR ~A~&" (strcat (my canonical-name) (servestate-path*))
+ (backtrace-description e)
+ e)
+ (respond-http con done
+ :body (with-sendbuf () "
I programmed this thoughtlessly. Sorry for the inconvenience.
")
+ :banner (force-byte-vector "500 Internal error"))))))
(my-defun dispatcher register-path (path func)
(setf (gethash (force-byte-vector path) (my paths)) (alexandria:ensure-function func)))
(my-defun dispatcher 'default-http-error-page ()
- (format *trace-output* "~&Page ~A not found~&" (strcat (my canonical-name) (servestate-path*)))
- (with-sendbuf ()
+ (format *trace-output* "~&Page ~A not found~&" (strcat (my canonical-name) (servestate-path*)))
+ (with-sendbuf ()
"I made a mistake. Sorry for the inconvenience.
"))
(defvar *default-dispatcher* (make-dispatcher))
@@ -118,9 +118,9 @@
(defun find-or-make-dispatcher (host)
(let ((host (force-byte-vector host)))
(or (find-dispatcher-go host)
- (let ((it (make-dispatcher :canonical-name host)))
- (push (cons host it) *dispatchers*)
- it))))
+ (let ((it (make-dispatcher :canonical-name host)))
+ (push (cons host it) *dispatchers*)
+ it))))
(defun dispatcher-add-alias (dispatcher alias)
(check-type dispatcher dispatcher)
@@ -130,10 +130,10 @@
(print-unreadable-object (me stream :type t :identity t)
(format stream "~S" (force-string (my canonical-name)))
(loop for p being the hash-keys of (my paths)
- do (format stream " ~A" (force-string p)))))
+ do (format stream " ~A" (force-string p)))))
(defun describe-dispatchers (&optional (*standard-output* *standard-output*))
;; TODO print a list of hostnames for each dispatcher
(loop for (path . dispatcher) in *dispatchers*
- do (format t "~&~S -> ~A~&" (force-string path) dispatcher))
+ do (format t "~&~S -> ~A~&" (force-string path) dispatcher))
(format t "~&DEFAULT -> ~A~&" *default-dispatcher*))
\ No newline at end of file
diff --git a/src/http/encoding.lisp b/src/http/encoding.lisp
index c0ca18f..131742a 100644
--- a/src/http/encoding.lisp
+++ b/src/http/encoding.lisp
@@ -2,8 +2,8 @@
(defun url-encoding-decode (encoded)
(declare (type simple-byte-vector encoded)
- (optimize speed))
- (match-replace-all
+ (optimize speed))
+ (match-replace-all
encoded
((progn "%" (val (unsigned-byte :length 2 :base 16)))
(byte-vector val))
@@ -11,13 +11,13 @@
(defun percent-hexpair-encode (plain)
(declare (type byte-vector plain))
- (match-replace-all
+ (match-replace-all
plain
( (c (and (not (or (- #\A #\Z) (- #\a #\z) (- #\0 #\9) #\- #\_ )) (char)))
(labels ((digit (digit)
- (if (>= digit 10)
- (+ digit (- (char-code #\A) 10))
- (+ digit (char-code #\0)))))
+ (if (>= digit 10)
+ (+ digit (- (char-code #\A) 10))
+ (+ digit (char-code #\0)))))
(multiple-value-bind (hi lo)
- (floor (aref (the byte-vector c) 0) 16)
- (byte-vector (char-code #\%) (digit hi) (digit lo)))))))
+ (floor (aref (the byte-vector c) 0) 16)
+ (byte-vector (char-code #\%) (digit hi) (digit lo)))))))
diff --git a/src/http/headers.lisp b/src/http/headers.lisp
index 9310009..a5d3d52 100644
--- a/src/http/headers.lisp
+++ b/src/http/headers.lisp
@@ -3,27 +3,27 @@
(defun match-int (value)
(declare (type simple-byte-vector value))
(match-bind ((len (integer))) value
- len))
+ len))
(defun match-each-word (value func)
(declare (type function func))
(declare (type simple-byte-vector value))
- (match-bind (
- (+ word (or (+ (space)) (last))
- '(funcall func word)))
- value))
+ (match-bind (
+ (+ word (or (+ (space)) (last))
+ '(funcall func word)))
+ value))
(defprotocol process-headers (con process-header-func)
(declare (type function process-header-func))
(let (last-header-name)
(loop for line = (io 'recvline con)
- until (zerop (length line))
- do (without-call/cc
- (if-match-bind ((space) value)
- line
- (funcall process-header-func last-header-name value)
- (match-bind
- (header-name ":" (* (space)) value)
- line
- (funcall process-header-func header-name value)
- (setf last-header-name header-name)))))
+ until (zerop (length line))
+ do (without-call/cc
+ (if-match-bind ((space) value)
+ line
+ (funcall process-header-func last-header-name value)
+ (match-bind
+ (header-name ":" (* (space)) value)
+ line
+ (funcall process-header-func header-name value)
+ (setf last-header-name header-name)))))
(values)))
diff --git a/src/http/request.lisp b/src/http/request.lisp
index f5197e7..efbe799 100644
--- a/src/http/request.lisp
+++ b/src/http/request.lisp
@@ -1,25 +1,25 @@
(in-package #:tpd2.http)
(defun parse-http-chunk-length-line (line)
- (match-bind ((len (unsigned-byte :base 16
- :max-length 7 ; maximum chunk size of (expt 16 7) = 268435456
- )) (* (space)) (last))
- line
- len))
+ (match-bind ((len (unsigned-byte :base 16
+ :max-length 7 ; maximum chunk size of (expt 16 7) = 268435456
+ )) (* (space)) (last))
+ line
+ len))
(defprotocol http-read-chunked (con)
(let ((body
- (loop
- for line = (io 'recvline con)
- for len = (parse-http-chunk-length-line line)
- until (zerop len)
- for chunk = (io 'recv con len)
- collect (copy-byte-vector chunk)
- do
- (match-bind ((last)) (io 'recvline con)))))
-
+ (loop
+ for line = (io 'recvline con)
+ for len = (parse-http-chunk-length-line line)
+ until (zerop len)
+ for chunk = (io 'recv con len)
+ collect (copy-byte-vector chunk)
+ do
+ (match-bind ((last)) (io 'recvline con)))))
+
(loop for line = (io 'recvline con)
- until (zerop (length line)))
+ until (zerop (length line)))
(without-call/cc (apply-byte-vector-cat body))))
@@ -28,50 +28,50 @@
(defprotocol http-request (con request done &key connection-cache)
(io 'send con request)
(let ((content-length)
- (chunked)
- (gzip)
- (connection-close))
+ (chunked)
+ (gzip)
+ (connection-close))
(match-bind ("HTTP/" (version-major (integer)) "." (version-minor (integer)) (+ (space)) (code (integer)) (+ (space)))
- (io 'recvline con)
- (flet ((decode (bytes)
- (cond (gzip (error "Sorry; haven't implemented GZIP decompression yet"))
- (t (funcall done bytes :response-code code)))))
-
- (when (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor))))
- (setf connection-close t))
-
- (io 'process-headers con
- (without-call/cc (lambda(name value)
- (unless (zerop (length value))
- (case-match-fold-ascii-case name
- ("content-length"
- (setf content-length (match-int value)))
- ("connection"
- (match-each-word value
- (lambda(word)
- (case-match-fold-ascii-case word
- ("close" (setf connection-close t))
- ("keep-alive" (setf connection-close nil))) )))
- ("transfer-encoding"
- (match-each-word value
- (lambda(word)
- (case-match-fold-ascii-case word
- ("chunked" (setf chunked t))
- ("gzip" (setf gzip t)))))))))))
- (decode
- (cond
- (chunked
- (io 'http-read-chunked con))
- (content-length
- (io 'recv con content-length))
- (t
- (setf connection-close t)
- (io 'recv-until-close con))))
-
- (cond ((or connection-close (not connection-cache))
- (hangup con))
- (t
- (add-to-connection-cache con connection-cache)))))))
+ (io 'recvline con)
+ (flet ((decode (bytes)
+ (cond (gzip (error "Sorry; haven't implemented GZIP decompression yet"))
+ (t (funcall done bytes :response-code code)))))
+
+ (when (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor))))
+ (setf connection-close t))
+
+ (io 'process-headers con
+ (without-call/cc (lambda(name value)
+ (unless (zerop (length value))
+ (case-match-fold-ascii-case name
+ ("content-length"
+ (setf content-length (match-int value)))
+ ("connection"
+ (match-each-word value
+ (lambda(word)
+ (case-match-fold-ascii-case word
+ ("close" (setf connection-close t))
+ ("keep-alive" (setf connection-close nil))) )))
+ ("transfer-encoding"
+ (match-each-word value
+ (lambda(word)
+ (case-match-fold-ascii-case word
+ ("chunked" (setf chunked t))
+ ("gzip" (setf gzip t)))))))))))
+ (decode
+ (cond
+ (chunked
+ (io 'http-read-chunked con))
+ (content-length
+ (io 'recv con content-length))
+ (t
+ (setf connection-close t)
+ (io 'recv-until-close con))))
+
+ (cond ((or connection-close (not connection-cache))
+ (hangup con))
+ (t
+ (add-to-connection-cache con connection-cache)))))))
(defun http-connection-cache-timeout ()
@@ -80,12 +80,12 @@
(defun add-to-connection-cache (con key)
(con-clear-failure-callbacks con)
(unless (con-dead? con)
- (con-when-ready-to-read con (lambda() (con-fail con)))
- (con-add-failure-callback con
- (lambda(&rest args)
- (declare (ignore args))
- (debug-assert (member con (gethash key *connection-cache*)) (con key))
- (deletef con (gethash key *connection-cache*))))
+ (con-when-ready-to-read con (lambda() (con-fail con)))
+ (con-add-failure-callback con
+ (lambda(&rest args)
+ (declare (ignore args))
+ (debug-assert (member con (gethash key *connection-cache*)) (con key))
+ (deletef con (gethash key *connection-cache*))))
(reset-timeout con (http-connection-cache-timeout))
(push con (gethash key *connection-cache*))))
@@ -98,28 +98,28 @@
(defun get-http-request-con (ssl address port)
(let ((con (pop (gethash (list ssl address port) *connection-cache*))))
(cond (con
- (con-clear-failure-callbacks con)
- (reset-timeout con)
- (debug-assert (not (con-dead? con)) (address port con))
- (cond ((con-connected? con)
- con)
- (t
- (hangup con)
- (get-http-request-con ssl address port))))
- (t
- (let ((con (make-con-connect :address address :port port)))
- (when ssl
- (convert-con-to-ssl con))
- con)))))
-
-(defun launch-http-request (&key ssl (port (if ssl 443 80)) address body
- (path (force-byte-vector "/"))
- extra-header-lines
- hostname
- timeout
- failure
- done
- (method (force-byte-vector "GET")))
+ (con-clear-failure-callbacks con)
+ (reset-timeout con)
+ (debug-assert (not (con-dead? con)) (address port con))
+ (cond ((con-connected? con)
+ con)
+ (t
+ (hangup con)
+ (get-http-request-con ssl address port))))
+ (t
+ (let ((con (make-con-connect :address address :port port)))
+ (when ssl
+ (convert-con-to-ssl con))
+ con)))))
+
+(defun launch-http-request (&key ssl (port (if ssl 443 80)) address body
+ (path (force-byte-vector "/"))
+ extra-header-lines
+ hostname
+ timeout
+ failure
+ done
+ (method (force-byte-vector "GET")))
(unless address
(setf address (lookup-hostname hostname)))
(unless address
@@ -130,22 +130,22 @@
(when timeout
(reset-timeout con timeout))
(unless hostname
- (setf hostname
- (with-sendbuf (s)
- address
- (unless (eql port 80)
- (with-sendbuf-continue (s) ":" port)))))
-
- (launch-io 'http-request con
- (with-sendbuf (s)
- method " " path " HTTP/1.1" +newline+
- (unless (zerop (length body))
- (with-sendbuf-continue (s)
- "Content-Length: " (length body) +newline+))
- "User-Agent: tpd2/0" +newline+
- "Host: " hostname +newline+
- extra-header-lines
- +newline+
- body)
- (lambda(&rest args)(setf succeeded t) (apply done args))
- :connection-cache (list ssl address port))))
+ (setf hostname
+ (with-sendbuf (s)
+ address
+ (unless (eql port 80)
+ (with-sendbuf-continue (s) ":" port)))))
+
+ (launch-io 'http-request con
+ (with-sendbuf (s)
+ method " " path " HTTP/1.1" +newline+
+ (unless (zerop (length body))
+ (with-sendbuf-continue (s)
+ "Content-Length: " (length body) +newline+))
+ "User-Agent: tpd2/0" +newline+
+ "Host: " hostname +newline+
+ extra-header-lines
+ +newline+
+ body)
+ (lambda(&rest args)(setf succeeded t) (apply done args))
+ :connection-cache (list ssl address port))))
diff --git a/src/http/serve.lisp b/src/http/serve.lisp
index 9f56163..b580797 100644
--- a/src/http/serve.lisp
+++ b/src/http/serve.lisp
@@ -16,7 +16,7 @@
(match-bind (path (or (last) (progn "?" q)))
url
(setf (servestate-path*) path
- (servestate-query-string*) q)))
+ (servestate-query-string*) q)))
(defconstant-bv +header-end+ (concatenate 'simple-byte-vector +newline+ +newline+))
@@ -30,148 +30,148 @@
(defun http-serve-parse-headers-clean (con done headers)
(declare (optimize speed))
(let (
- (request-content-length 0)
- host
- (request-origin (con-peer-info con))
- connection-close)
+ (request-content-length 0)
+ host
+ (request-origin (con-peer-info con))
+ connection-close)
(flet ((handle-header (name value)
- (declare (type simple-byte-vector name value))
- (unless (zerop (length value))
- (case-match-fold-ascii-case name
- ("content-length"
- (setf request-content-length (match-int value)))
- ("host"
- (setf host value))
- ("connection"
- (match-bind (
- (+ word (or (+ (space)) (last))
- '(case-match-fold-ascii-case (the simple-byte-vector word)
- ("close" (setf connection-close t))
- ("keep-alive" (setf connection-close nil)))))
- value))
- ("x-forwarded-for"
- (setf request-origin
- (match-x-forwarded-for value)))))))
+ (declare (type simple-byte-vector name value))
+ (unless (zerop (length value))
+ (case-match-fold-ascii-case name
+ ("content-length"
+ (setf request-content-length (match-int value)))
+ ("host"
+ (setf host value))
+ ("connection"
+ (match-bind (
+ (+ word (or (+ (space)) (last))
+ '(case-match-fold-ascii-case (the simple-byte-vector word)
+ ("close" (setf connection-close t))
+ ("keep-alive" (setf connection-close nil)))))
+ value))
+ ("x-forwarded-for"
+ (setf request-origin
+ (match-x-forwarded-for value)))))))
(declare (dynamic-extent #'handle-header))
- (match-bind
- (macrolet ((lws () `(or #\Space #\Tab)))
- (progn
- method (+ (lws))
- url
- (or (progn (+ (lws)) (:? "HTTP/" (version-major (unsigned-byte :max-length 3) 1) "."
- (version-minor (unsigned-byte :max-length 3) 0) (* (lws))) +newline+)
- +newline+)
- '(setf connection-close (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor)))))
- (*
- header-name ":" (* (lws)) value +newline+
- '(handle-header header-name value)
- (* (+ (lws)) extra-value +newline+
- '(handle-header header-name extra-value))
- )
- +newline+))
- headers
-
- (http-serve-process-body con done
- url
- :request-content-length request-content-length
- :host host
- :origin request-origin
- :connection-close connection-close)))))
+ (match-bind
+ (macrolet ((lws () `(or #\Space #\Tab)))
+ (progn
+ method (+ (lws))
+ url
+ (or (progn (+ (lws)) (:? "HTTP/" (version-major (unsigned-byte :max-length 3) 1) "."
+ (version-minor (unsigned-byte :max-length 3) 0) (* (lws))) +newline+)
+ +newline+)
+ '(setf connection-close (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor)))))
+ (*
+ header-name ":" (* (lws)) value +newline+
+ '(handle-header header-name value)
+ (* (+ (lws)) extra-value +newline+
+ '(handle-header header-name extra-value))
+ )
+ +newline+))
+ headers
+
+ (http-serve-process-body con done
+ url
+ :request-content-length request-content-length
+ :host host
+ :origin request-origin
+ :connection-close connection-close)))))
(defun http-serve-parse-headers (con done headers)
(declare (optimize speed))
(let ((*servestate* (make-servestate :origin (con-peer-info con))))
(flet ((handle-header (name value)
- (declare (type simple-byte-vector name value))
- (unless (zerop (length value))
- #.`(case-match-fold-ascii-case name
- ("content-length"
- (setf (servestate-content-length*) (match-int value)))
- ("connection"
- (match-bind (
- (+ word (or (+ (space)) (last))
- '(case-match-fold-ascii-case (the simple-byte-vector word)
- ("close" (setf (servestate-connection-close*) t))
- ("keep-alive" (setf (servestate-connection-close*) nil)))))
- value))
- ("x-forwarded-for"
- (setf (servestate-origin*)
- (match-x-forwarded-for value)))
- ,@(loop for f in *stored-servestate-header-fields*
- collect
- `(,(force-string f)
- (push value (,(concat-sym 'servestate- f '*)))))))))
+ (declare (type simple-byte-vector name value))
+ (unless (zerop (length value))
+ #.`(case-match-fold-ascii-case name
+ ("content-length"
+ (setf (servestate-content-length*) (match-int value)))
+ ("connection"
+ (match-bind (
+ (+ word (or (+ (space)) (last))
+ '(case-match-fold-ascii-case (the simple-byte-vector word)
+ ("close" (setf (servestate-connection-close*) t))
+ ("keep-alive" (setf (servestate-connection-close*) nil)))))
+ value))
+ ("x-forwarded-for"
+ (setf (servestate-origin*)
+ (match-x-forwarded-for value)))
+ ,@(loop for f in *stored-servestate-header-fields*
+ collect
+ `(,(force-string f)
+ (push value (,(concat-sym 'servestate- f '*)))))))))
(declare (dynamic-extent #'handle-header))
(let ((pos 0))
- (declare (type (integer 0 100000) pos)
- (type simple-byte-vector headers))
- (macrolet (
- (e (&optional (d 0))
- `(locally (declare (optimize (safety 0))) (aref headers (+ pos ,d))))
- (u (&rest chars)
- (with-unique-names (s)
- `(let ((,s pos))
- (loop until (m ,@chars) do (incf pos))
- (subseq headers ,s pos))))
- (m (&rest chars)
- `(let ((e (e))) (declare (type (unsigned-byte 8) e)) (or ,@(loop for c in chars collect `(= e ,(char-code c))))))
- (w (&rest chars)
- `(loop while (m ,@chars) do (incf pos)))
- (s (string)
- `(progn
- ,@(loop for c across string
- for i from 0 collect
- `(assert (= (e ,i) ,(char-code c))))
- (incf pos ,(length string))))
- (i () ;; XXX hack
- `(multiple-value-prog1
- (- (e) (char-code #\0))
- (incf pos)))
- (ulws ()
- `(multiple-value-prog1 (u #\Space #\Tab) (lws)))
-
- (lws () `(w #\Space #\Tab))
- (assert-eol ()
- `(progn (incf pos) (assert (= ,(char-code #\Newline) (e))) (incf pos)))
- (line ()
- `(multiple-value-prog1 (u #\Return) (assert-eol))))
-
- (let ((version-major 0) (version-minor 9))
- (setf (servestate-method*) (ulws))
-
- (match-request-url (ulws))
-
- (cond ((= (e) (char-code #\Return)))
- (t
- (s "HTTP/")
- (setf version-major (i))
- (s ".")
- (setf version-minor (i))
- (lws)
- (assert-eol)))
- (setf (servestate-connection-close*)
- (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor)))))
- (loop until (= (e) (char-code #\Return))
- do (cond ((m #\Space #\Tab))
- (t
- (let ((header-name (u #\:)))
- (incf pos)
- (lws)
- (handle-header header-name (line))))))
- (assert-eol)
-
- (http-serve-process-body con done *servestate*)))))))
+ (declare (type (integer 0 100000) pos)
+ (type simple-byte-vector headers))
+ (macrolet (
+ (e (&optional (d 0))
+ `(locally (declare (optimize (safety 0))) (aref headers (+ pos ,d))))
+ (u (&rest chars)
+ (with-unique-names (s)
+ `(let ((,s pos))
+ (loop until (m ,@chars) do (incf pos))
+ (subseq headers ,s pos))))
+ (m (&rest chars)
+ `(let ((e (e))) (declare (type (unsigned-byte 8) e)) (or ,@(loop for c in chars collect `(= e ,(char-code c))))))
+ (w (&rest chars)
+ `(loop while (m ,@chars) do (incf pos)))
+ (s (string)
+ `(progn
+ ,@(loop for c across string
+ for i from 0 collect
+ `(assert (= (e ,i) ,(char-code c))))
+ (incf pos ,(length string))))
+ (i () ;; XXX hack
+ `(multiple-value-prog1
+ (- (e) (char-code #\0))
+ (incf pos)))
+ (ulws ()
+ `(multiple-value-prog1 (u #\Space #\Tab) (lws)))
+
+ (lws () `(w #\Space #\Tab))
+ (assert-eol ()
+ `(progn (incf pos) (assert (= ,(char-code #\Newline) (e))) (incf pos)))
+ (line ()
+ `(multiple-value-prog1 (u #\Return) (assert-eol))))
+
+ (let ((version-major 0) (version-minor 9))
+ (setf (servestate-method*) (ulws))
+
+ (match-request-url (ulws))
+
+ (cond ((= (e) (char-code #\Return)))
+ (t
+ (s "HTTP/")
+ (setf version-major (i))
+ (s ".")
+ (setf version-minor (i))
+ (lws)
+ (assert-eol)))
+ (setf (servestate-connection-close*)
+ (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor)))))
+ (loop until (= (e) (char-code #\Return))
+ do (cond ((m #\Space #\Tab))
+ (t
+ (let ((header-name (u #\:)))
+ (incf pos)
+ (lws)
+ (handle-header header-name (line))))))
+ (assert-eol)
+
+ (http-serve-process-body con done *servestate*)))))))
(defprotocol http-serve-process-body (con servestate)
(unless (zerop (servestate-content-length servestate))
(setf (servestate-post-parameters servestate)
- (force-simple-byte-vector
- (io 'recv con (servestate-content-length servestate)))))
+ (force-simple-byte-vector
+ (io 'recv con (servestate-content-length servestate)))))
(io 'dispatch-servestate con servestate)
- (cond
- ((servestate-connection-close servestate)
+ (cond
+ ((servestate-connection-close servestate)
;;; In the case where the client did not legitimately expect a
;;; connexion close, they could pipeline more requests. Closing the
@@ -187,7 +187,7 @@
;;; However, this is slow, and as we never close the socket
;;; unless the client actually itself requested the socket to
;;; be closed, we can safely hangup.
- (hangup con))
+ (hangup con))
(t (io 'http-serve con))))
(defun http-serve-wait-timeout ()
diff --git a/src/http/servestate.lisp b/src/http/servestate.lisp
index 7af11f2..dcd0dd3 100644
--- a/src/http/servestate.lisp
+++ b/src/http/servestate.lisp
@@ -5,29 +5,29 @@
(defmacro def-specialvar-struct (name &rest fields)
(let ((accessors (loop for f in fields
- for n = (force-first f)
- collect (concat-sym name '- n)))
- (special (concat-sym-from-sym-package name '* name '*)))
+ for n = (force-first f)
+ collect (concat-sym name '- n)))
+ (special (concat-sym-from-sym-package name '* name '*)))
(with-unique-names (v)
`(progn
- (defvar ,special)
- (declaim (inline ,(concat-sym-from-sym-package name 'make- name) ,@accessors
- ,@(loop for a in accessors collect `(setf ,a))))
- (defstruct ,name ,@fields)
- (declaim (type ,name ,special))
-
- ,@(loop for a in accessors
- for sa = (concat-sym a '*)
- collect `(progn
- (declaim (inline ,sa (setf ,sa)))
- (defun ,sa () (when (boundp ',special) (,a ,special)))
- (defun (setf ,sa) (,v) (setf (,a ,special) ,v))))))))
+ (defvar ,special)
+ (declaim (inline ,(concat-sym-from-sym-package name 'make- name) ,@accessors
+ ,@(loop for a in accessors collect `(setf ,a))))
+ (defstruct ,name ,@fields)
+ (declaim (type ,name ,special))
+
+ ,@(loop for a in accessors
+ for sa = (concat-sym a '*)
+ collect `(progn
+ (declaim (inline ,sa (setf ,sa)))
+ (defun ,sa () (when (boundp ',special) (,a ,special)))
+ (defun (setf ,sa) (,v) (setf (,a ,special) ,v))))))))
(defmacro def-servestate-struct (&rest fields)
`(def-specialvar-struct servestate
,@fields
,@(loop for f in *stored-servestate-header-fields*
- collect `(,f nil :type list))))
+ collect `(,f nil :type list))))
(def-servestate-struct
(method nil :type (or null simple-byte-vector))
@@ -36,14 +36,14 @@
(post-parameters nil :type (or null simple-byte-vector))
(origin nil :type simple-byte-vector)
(connection-close nil :type (member t nil))
-
+
(content-length 0 :type fixnum)
-
+
(response nil :type (or null sendbuf)))
;; Persuade SBCL's type inference that servestate-response* is a sendbuf
(declaim (inline servestate-response-as-sendbuf*)
- (ftype (function () sendbuf) servestate-response-as-sendbuf*))
+ (ftype (function () sendbuf) servestate-response-as-sendbuf*))
(defun servestate-response-as-sendbuf* ()
#-tpd2-debug (declare (optimize (safety 0)))
(let ((sendbuf (servestate-response *servestate*)))
diff --git a/src/io/con.lisp b/src/io/con.lisp
index 1a7d35b..0391119 100644
--- a/src/io/con.lisp
+++ b/src/io/con.lisp
@@ -15,11 +15,11 @@
(let ((con (apply '%make-con args)))
(let ((sock (con-socket con)))
(assert sock)
- #+tpd2-finalize-sockets
- (finalize con
- (lambda()
- (warn "Closing socket in finalizer ~A" sock)
- (ignore-errors (socket-close sock)))))
+ #+tpd2-finalize-sockets
+ (finalize con
+ (lambda()
+ (warn "Closing socket in finalizer ~A" sock)
+ (ignore-errors (socket-close sock)))))
(con-init con)
con))
@@ -28,7 +28,7 @@
(setf (my timeout) (make-timeout :func (my default-timeout-function)))))
(my-defun con default-timeout-function ()
- (lambda()
+ (lambda()
(my fail 'timeout)))
(my-defun con fail (&optional (e (make-condition 'socket-explicitly-hungup)))
@@ -54,11 +54,11 @@
(my-defun con run ()
(restart-case
- (handler-bind ((error
- (lambda(e)
- (when (normal-connection-error e)
- (invoke-restart 'hangup e)))))
- (funcall (my ready-callback)))
+ (handler-bind ((error
+ (lambda(e)
+ (when (normal-connection-error e)
+ (invoke-restart 'hangup e)))))
+ (funcall (my ready-callback)))
(hangup (&optional (err (make-condition 'socket-explicitly-hungup)))
(my fail err))))
@@ -74,17 +74,17 @@
(my-defun con add-failure-callback (func)
(let ((old (my err)))
- (setf (my err)
- (if old
- (lambda(e)
- (funcall func e)
- (funcall old e))
- func))
+ (setf (my err)
+ (if old
+ (lambda(e)
+ (funcall func e)
+ (funcall old e))
+ func))
(values)))
(my-defun con clear-failure-callbacks ()
- (setf (my err)
- nil))
+ (setf (my err)
+ nil))
(my-defun con 'recv (done amount)
(declare (type fixnum amount))
@@ -98,17 +98,17 @@
(my-defun con 'recv-some-or-nil (done)
(let ((available (recvbuf-available-to-eat (my recv))))
- (cond
+ (cond
((zerop available)
(let ((s (recvbuf-read-some (my recv) me #'my-call)))
- (case s
- ((nil))
- (0
- (funcall done nil)
- (return-from my-call))
- (t
- (debug-assert (not (zerop (recvbuf-available-to-eat (my recv)))) (me (my recv)))
- (my-call)))))
+ (case s
+ ((nil))
+ (0
+ (funcall done nil)
+ (return-from my-call))
+ (t
+ (debug-assert (not (zerop (recvbuf-available-to-eat (my recv)))) (me (my recv)))
+ (my-call)))))
(t
(funcall done (recvbuf-eat (my recv) available)))))
(values))
@@ -121,7 +121,7 @@
(acond
((recvbuf-eat-to-delimiter (my recv) delimiter)
(funcall done it))
- (t
+ (t
(recvbuf-prepare-read (my recv))
(recvbuf-recv (my recv) me #'my-call))))
@@ -134,26 +134,26 @@
((recvbuf-find (my recv) delimiter)
(setf (recvbuf-read-idx (my recv)) (+ it (length delimiter)))
(funcall done (recvbuf-store (my recv))))
- (t
+ (t
(recvbuf-recv (my recv) me #'my-call))))
(my-defun con 'recv-until-close (done)
(let ((total))
(labels ((r (buf)
- (cond ((not buf)
- (funcall done (apply-byte-vector-cat (nreverse total))))
- (t
- (push (copy-byte-vector buf) total)
- (recv-some-or-nil me #'r)))))
+ (cond ((not buf)
+ (funcall done (apply-byte-vector-cat (nreverse total))))
+ (t
+ (push (copy-byte-vector buf) total)
+ (recv-some-or-nil me #'r)))))
(recv-some-or-nil me #'r))))
(my-defun con 'recv-discard-and-close (done)
(labels ((r (buf)
- (cond ((not buf)
- (my 'hangup)
- (funcall done))
- (t
- (recv-some-or-nil me #'r)))))
+ (cond ((not buf)
+ (my 'hangup)
+ (funcall done))
+ (t
+ (recv-some-or-nil me #'r)))))
(socket-shutdown-write (my socket))
(r t)))
@@ -164,62 +164,62 @@
(funcall done))
(t
(if (socket-supports-writev (my socket))
- (sendbuf-send-writev sendbuf me done)
- (sendbuf-send-write sendbuf me done)))))
+ (sendbuf-send-writev sendbuf me done)
+ (sendbuf-send-write sendbuf me done)))))
(my-defun con 'accept (done)
- (acond
+ (acond
((socket-accept (my socket))
(funcall done it))
(t
(my when-ready-to-read #'my-call))))
(my-defun con 'hangup ()
- (my-declare-fast-inline)
+ (my-declare-fast-inline)
(timeout-cancel (my timeout))
(when (my socket)
#+tpd2-finalize-sockets (cancel-finalization me)
(handler-case
- (socket-close (my socket))
+ (socket-close (my socket))
(error (e)
- (warn "Error closing socket ~A: ~A" con e)))
+ (warn "Error closing socket ~A: ~A" con e)))
(setf (my socket) nil)
(put-recvbuf (my recv))
(when (my hangup-hook)
(funcall (my hangup-hook)))))
-(defun make-con-connect (&key address port
- (socket-family +AF_INET+)
- (socket-type +SOCK_STREAM+))
+(defun make-con-connect (&key address port
+ (socket-family +AF_INET+)
+ (socket-type +SOCK_STREAM+))
(make-con :socket (make-connect-socket
- :port port
- :address address
- :socket-family socket-family
- :socket-type socket-type)))
-
-(defun make-con-listen (&key (port 0)
- (address "0.0.0.0")
- (socket-family +AF_INET+)
- (socket-type +SOCK_STREAM+))
- (make-con
+ :port port
+ :address address
+ :socket-family socket-family
+ :socket-type socket-type)))
+
+(defun make-con-listen (&key (port 0)
+ (address "0.0.0.0")
+ (socket-family +AF_INET+)
+ (socket-type +SOCK_STREAM+))
+ (make-con
:err (lambda (e) (error "Listening connexions cannot have errors: ~A" e))
- :socket
- (make-listen-socket
- :port port
- :address address
+ :socket
+ (make-listen-socket
+ :port port
+ :address address
:socket-family socket-family
:socket-type socket-type)))
(defun make-con-bind (&key (port 0)
- (address "0.0.0.0")
- (socket-family +AF_INET+)
- (socket-type +SOCK_DGRAM+))
- (make-con :socket (make-listen-socket
- :port port
- :address address
- :socket-family socket-family
- :socket-type socket-type)))
+ (address "0.0.0.0")
+ (socket-family +AF_INET+)
+ (socket-type +SOCK_DGRAM+))
+ (make-con :socket (make-listen-socket
+ :port port
+ :address address
+ :socket-family socket-family
+ :socket-type socket-type)))
(my-defun con when-ready (events &optional callback)
(my-declare-fast-inline)
diff --git a/src/io/epoll.lisp b/src/io/epoll.lisp
index 3925ce2..6652869 100644
--- a/src/io/epoll.lisp
+++ b/src/io/epoll.lisp
@@ -17,11 +17,11 @@
(let ((events-mem (cffi:foreign-alloc 'epoll-event :count (my max-events))))
(setf (my events) events-mem)
(cancel-finalization me)
- (finalize me
- (lambda()
- (ignore-errors (syscall-close fd))
- (ignore-errors
- (cffi:foreign-free events-mem)))))))
+ (finalize me
+ (lambda()
+ (ignore-errors (syscall-close fd))
+ (ignore-errors
+ (cffi:foreign-free events-mem)))))))
(defun make-epoll ()
(let ((e (%make-epoll)))
@@ -31,10 +31,10 @@
(my-defun epoll ctl (ctl fd-wanted events-wanted)
(with-foreign-object-and-slots ((events data) event epoll-event)
(setf events
- (logior
- events-wanted
- +POLLHUP+
- +POLLERR+))
+ (logior
+ events-wanted
+ +POLLHUP+
+ +POLLERR+))
(cffi:with-foreign-slots ((fd) data epoll-data)
(setf fd fd-wanted))
(syscall-epoll_ctl (my fd) ctl fd-wanted event))
@@ -51,23 +51,23 @@
(debug-assert (not (my postponed-registrations)) (me (my postponed-registrations) (my postpone-registration)))
(setf (my postpone-registration) t)
(let ((nevents
- (syscall-retry-epoll_wait (my fd) (my events) (my max-events)
- (if timeout
- (floor (* 1000 timeout))
- -1))))
+ (syscall-retry-epoll_wait (my fd) (my events) (my max-events)
+ (if timeout
+ (floor (* 1000 timeout))
+ -1))))
(debug-assert (>= (my max-events) nevents) (me nevents))
(dotimes (i nevents)
(let ((event (cffi:mem-aref (my events) 'epoll-event i)))
- (cffi:with-foreign-slots ((events data) event epoll-event)
- (cffi:with-foreign-slots ((fd) data epoll-data)
- (awhen (my 'mux-find-fd fd)
- (unless (zerop (logand (logior +POLLIN+ +POLLOUT+) events))
- (con-run it))
- (unless (and (zerop (logand (logior +POLLERR+ +POLLHUP+) events))
- (or (zerop (logand +POLLRDHUP+ events))
- (not (zerop (logand +POLLIN+ events)))))
- (con-fail it)))))))
+ (cffi:with-foreign-slots ((events data) event epoll-event)
+ (cffi:with-foreign-slots ((fd) data epoll-data)
+ (awhen (my 'mux-find-fd fd)
+ (unless (zerop (logand (logior +POLLIN+ +POLLOUT+) events))
+ (con-run it))
+ (unless (and (zerop (logand (logior +POLLERR+ +POLLHUP+) events))
+ (or (zerop (logand +POLLRDHUP+ events))
+ (not (zerop (logand +POLLIN+ events)))))
+ (con-fail it)))))))
(debug-assert (my postpone-registration))
(setf (my postpone-registration) nil)
@@ -79,14 +79,14 @@
(defun register-fd (fd events con)
(with-shorthand-accessor (my epoll *epoll*)
- (cond ((my 'mux-find-fd fd)
- (debug-assert (eq con (my 'mux-find-fd fd)) (*epoll* con fd))
- (my ctl +EPOLL_CTL_MOD+ fd events))
- (t
- (if (my postpone-registration)
- (push (cons fd con) (my postponed-registrations))
- (my 'mux-add fd con))
- (my ctl +EPOLL_CTL_ADD+ fd events)))))
+ (cond ((my 'mux-find-fd fd)
+ (debug-assert (eq con (my 'mux-find-fd fd)) (*epoll* con fd))
+ (my ctl +EPOLL_CTL_MOD+ fd events))
+ (t
+ (if (my postpone-registration)
+ (push (cons fd con) (my postponed-registrations))
+ (my 'mux-add fd con))
+ (my ctl +EPOLL_CTL_ADD+ fd events)))))
(defun deregister-fd (fd)
(declare (optimize speed))
@@ -104,11 +104,11 @@
(setf (epoll-postpone-registration *epoll*) nil)
(epoll-handle-postponed-registrations *epoll*)
(loop for timeout = (next-timeout)
- while (or timeout (events-pending-p)) do
- (wait-for-next-event timeout)
- (let ((start-time (get-timeout-time)))
- (loop do (wait-for-next-event 1)
- thereis (/= start-time (get-timeout-time))))))
+ while (or timeout (events-pending-p)) do
+ (wait-for-next-event timeout)
+ (let ((start-time (get-timeout-time)))
+ (loop do (wait-for-next-event 1)
+ thereis (/= start-time (get-timeout-time))))))
(defun event-loop-reset ()
(setf (epoll-postpone-registration *epoll*) nil)
@@ -116,7 +116,7 @@
(mux-close-all *epoll*)
(forget-timeouts)
(setf *epoll*
- (make-epoll)))
+ (make-epoll)))
(defmacro with-independent-event-loop (() &body body)
`(with-independent-timeouts ()
diff --git a/src/io/mux.lisp b/src/io/mux.lisp
index 04f3694..13361f1 100644
--- a/src/io/mux.lisp
+++ b/src/io/mux.lisp
@@ -5,14 +5,14 @@
(defstruct mux
(fd-to-con (make-mux-array 128)
- :type (simple-array (or null con))))
+ :type (simple-array (or null con))))
(my-defun mux empty ()
- (my-declare-fast-inline)
- (every #'not (my fd-to-con)))
+ (my-declare-fast-inline)
+ (every #'not (my fd-to-con)))
(my-defun mux find-fd (fd)
- (my-declare-fast-inline)
+ (my-declare-fast-inline)
(declare (type (or null fixnum) fd))
(when fd
(when (> (length (my fd-to-con)) fd)
@@ -23,11 +23,11 @@
(when fd
(debug-assert (not (my find-fd fd)) (me con fd))
(when (>= fd (length (my fd-to-con)))
- (let ((new (make-mux-array
- (loop for length = (* 2 (length (my fd-to-con))) then (* 2 length)
- thereis (when (> length fd) length)))))
- (replace new (my fd-to-con))
- (setf (my fd-to-con) new))
+ (let ((new (make-mux-array
+ (loop for length = (* 2 (length (my fd-to-con))) then (* 2 length)
+ thereis (when (> length fd) length)))))
+ (replace new (my fd-to-con))
+ (setf (my fd-to-con) new))
(debug-assert (> (length (my fd-to-con)) fd) (me fd)))
(setf (aref (my fd-to-con) fd) con)))
@@ -40,5 +40,5 @@
(my-defun mux close-all ()
(loop for x across (my fd-to-con)
- when x
- do (hangup x)))
+ when x
+ do (hangup x)))
diff --git a/src/io/openssl.lisp b/src/io/openssl.lisp
index 8a84d36..5a500ff 100644
--- a/src/io/openssl.lisp
+++ b/src/io/openssl.lisp
@@ -93,7 +93,7 @@
(ssl-library-init)
(ssl-load-error-strings)
(setf *ssl-ctx* (ssl-ctx-new (ssl-v23-method))
- *openssl-initialized* t)))
+ *openssl-initialized* t)))
(defun ssl-ctx-set-mode (context mode)
(ssl-ctx-ctrl context +SSL_CTRL_MODE+ mode (cffi:null-pointer)))
diff --git a/src/io/posix-socket.lisp b/src/io/posix-socket.lisp
index 6b9e6e0..37ce04c 100644
--- a/src/io/posix-socket.lisp
+++ b/src/io/posix-socket.lisp
@@ -1,12 +1,12 @@
(in-package #:tpd2.io)
(defmacro socket-io-syscall (call)
- #+never `(handler-bind
- ((syscall-failed #'(lambda(e)
- (when (not (member (syscall-failed-errno e)
- '(+EINVAL+ +EBADF+)))
- (error 'socket-closed)))))
- ,call)
+ #+never `(handler-bind
+ ((syscall-failed #'(lambda(e)
+ (when (not (member (syscall-failed-errno e)
+ '(+EINVAL+ +EBADF+)))
+ (error 'socket-closed)))))
+ ,call)
call)
@@ -15,29 +15,29 @@
(declare (type fixnum offset))
(debug-assert (not (zerop (length buf))) (fd buf offset))
(let ((s
- (with-pointer-to-vector-data (ptr buf)
- (socket-io-syscall (syscall-read fd (cffi:inc-pointer ptr offset) (- (length buf) offset))))))
+ (with-pointer-to-vector-data (ptr buf)
+ (socket-io-syscall (syscall-read fd (cffi:inc-pointer ptr offset) (- (length buf) offset))))))
(case-= s
- (-1 nil)
- (t s))))
+ (-1 nil)
+ (t s))))
(defmethod socket-write ((fd integer) buf offset)
(declare (type simple-byte-vector buf))
(declare (type fixnum offset))
(let ((s
- (with-pointer-to-vector-data (ptr buf)
- (socket-io-syscall (syscall-write fd (cffi:inc-pointer ptr offset) (- (length buf) offset))))))
+ (with-pointer-to-vector-data (ptr buf)
+ (socket-io-syscall (syscall-write fd (cffi:inc-pointer ptr offset) (- (length buf) offset))))))
(case-= s
- (-1 nil)
- (t s))))
+ (-1 nil)
+ (t s))))
(defmethod socket-writev ((fd integer) iovec count)
(declare (optimize speed))
(let ((s
- (socket-io-syscall (syscall-writev fd iovec count))))
+ (socket-io-syscall (syscall-writev fd iovec count))))
(case-= s
- (-1 nil)
- (t s))))
+ (-1 nil)
+ (t s))))
(eval-always
(defun accept4-supported ()
@@ -48,30 +48,30 @@
(cffi:with-foreign-object (len :int)
(setf (cffi:mem-aref len :int) (cffi:foreign-type-size 'sockaddr_in))
(let ((s
- (socket-io-syscall
- #. (progn
- (if (accept4-supported)
- `(syscall-accept4 fd sa len
- (logior
- 0
- #-tpd2-untransformed-io +SOCK_NONBLOCK+
- )
- )
- `(syscall-accept fd sa len)
- )))))
- (case-= s
- (-1 nil)
- (t
-; (socket-set-tcp-nodelay s)
-; (socket-cork s)
-
- #.(unless (accept4-supported)
- #-tpd2-untransformed-io
- `(set-fd-nonblock s))
-
- (make-con
- :socket s
- :peer-info (sockaddr-address-bv sa))))))))
+ (socket-io-syscall
+ #. (progn
+ (if (accept4-supported)
+ `(syscall-accept4 fd sa len
+ (logior
+ 0
+ #-tpd2-untransformed-io +SOCK_NONBLOCK+
+ )
+ )
+ `(syscall-accept fd sa len)
+ )))))
+ (case-= s
+ (-1 nil)
+ (t
+; (socket-set-tcp-nodelay s)
+; (socket-cork s)
+
+ #.(unless (accept4-supported)
+ #-tpd2-untransformed-io
+ `(set-fd-nonblock s))
+
+ (make-con
+ :socket s
+ :peer-info (sockaddr-address-bv sa))))))))
(defmethod socket-close ((fd integer))
@@ -94,26 +94,26 @@
(cffi:with-foreign-object (len :int)
(setf (cffi:mem-aref len :int) (cffi:foreign-type-size 'sockaddr_in))
(with-pointer-to-vector-data (ptr buf)
- (let ((s (socket-io-syscall (syscall-recvfrom fd ptr (length buf) 0 sa len))))
- (case-= s
- (-1 (values nil nil))
- (0 (error 'socket-closed))
- (t
+ (let ((s (socket-io-syscall (syscall-recvfrom fd ptr (length buf) 0 sa len))))
+ (case-= s
+ (-1 (values nil nil))
+ (0 (error 'socket-closed))
+ (t
- (let ((sa-out (make-byte-vector (cffi:mem-aref len :int))))
- (loop for i from 0 below (length sa-out) do
- (setf (aref sa-out i) (cffi:mem-ref sa :unsigned-char i)))
- (values s sa-out)))))))))
+ (let ((sa-out (make-byte-vector (cffi:mem-aref len :int))))
+ (loop for i from 0 below (length sa-out) do
+ (setf (aref sa-out i) (cffi:mem-ref sa :unsigned-char i)))
+ (values s sa-out)))))))))
#+broken
(defmethod socket-sendto ((fd integer) sa buf)
(let ((s
- (with-pointer-to-vector-data (ptr buf)
- (with-pointer-to-vector-data (sa-ptr sa)
- (socket-io-syscall (syscall-sendto fd ptr (length buf) 0 sa-ptr (length sa)))))))
+ (with-pointer-to-vector-data (ptr buf)
+ (with-pointer-to-vector-data (sa-ptr sa)
+ (socket-io-syscall (syscall-sendto fd ptr (length buf) 0 sa-ptr (length sa)))))))
(case-= s
- (-1 nil)
- (t s))))
+ (-1 nil)
+ (t s))))
(defmethod socket-peer ((fd integer))
@@ -121,7 +121,7 @@
(cffi:with-foreign-object (len :int)
(setf (cffi:mem-aref len :int) (cffi:foreign-type-size 'sockaddr_in))
(when (zerop (getpeername fd sa len))
- (sockaddr-address-string sa)))))
+ (sockaddr-address-string sa)))))
(defmethod socket-shutdown-write ((fd integer))
(syscall-shutdown fd +SHUT_WR+))
diff --git a/src/io/protocol.lisp b/src/io/protocol.lisp
index a3d69bd..e569f87 100644
--- a/src/io/protocol.lisp
+++ b/src/io/protocol.lisp
@@ -5,29 +5,29 @@
(define-condition connection-buffer-overflow-error (protocol-error)
((con :initarg :con) (len :initarg :len))
(:report (lambda (err stream)
- (with-slots (con len)
- err
- (format stream "~A overflowed a buffer of length ~A" con len)))))
+ (with-slots (con len)
+ err
+ (format stream "~A overflowed a buffer of length ~A" con len)))))
(defmacro simple-io-function (sym)
`(get ,sym 'simple-io-function))
(defmacro with-simple-io (&body body)
`(macrolet ((io (func con-var &rest args)
- (check-symbols con-var)
- `(funcall (simple-io-function ,func) ,con-var ,@args)))
+ (check-symbols con-var)
+ `(funcall (simple-io-function ,func) ,con-var ,@args)))
(flet ((hangup (con)
- (declare (ignore con)))
- (reset-timeout (con timeout)
- (declare (ignore con timeout))))
+ (declare (ignore con)))
+ (reset-timeout (con timeout)
+ (declare (ignore con timeout))))
(declare (ignorable #'hangup #'reset-timeout))
,@body)))
(defmacro defun-simple-io (name lambda-list &body body)
`(eval-always
(setf (simple-io-function ',name)
- (defun ,(concat-sym-from-sym-package name 'simple-io- name)
- ,lambda-list (with-simple-io ,@body)))))
+ (defun ,(concat-sym-from-sym-package name 'simple-io- name)
+ ,lambda-list (with-simple-io ,@body)))))
(defun-simple-io recv (stream amount)
(let ((buf (make-string amount)))
@@ -42,7 +42,7 @@
(defun-simple-io send (stream sendbuf)
(loop for buf in (sendbuf-head sendbuf)
- do (write-string (force-string buf) stream))
+ do (write-string (force-string buf) stream))
(values))
#-tpd2-untransformed-io
@@ -51,38 +51,38 @@
(with-unique-names (done)
`(progn
(defun-simple-io ,name (,con-var ,@args)
- ,@body)
+ ,@body)
(defun ,name (,con-var ,done ,@args)
- (with-call/cc
- (funcall ,done (locally ,@body)))))))
+ (with-call/cc
+ (funcall ,done (locally ,@body)))))))
#-tpd2-untransformed-io
(defmacro io (func con-var &rest args &environment env)
(check-symbols con-var)
(with-unique-names (k)
(let* (gensyms
- (func (if (and (listp func) (eq 'quote (first func))) `(function ,@(rest func)) func))
- (arg-syms (loop for a in args collect
- (cond
- ((constantp a env)
- a)
- (t
- (let ((g (gensym (force-string a))))
- (push `(,g ,a) gensyms)
- g))))))
+ (func (if (and (listp func) (eq 'quote (first func))) `(function ,@(rest func)) func))
+ (arg-syms (loop for a in args collect
+ (cond
+ ((constantp a env)
+ a)
+ (t
+ (let ((g (gensym (force-string a))))
+ (push `(,g ,a) gensyms)
+ g))))))
`(let ,(reverse gensyms)
- (call/cc
- (lambda(,k)
- (funcall ,func ,con-var (convert-continuation-to-normal-function ,k) ,@arg-syms)))))))
+ (call/cc
+ (lambda(,k)
+ (funcall ,func ,con-var (convert-continuation-to-normal-function ,k) ,@arg-syms)))))))
(defmacro launch-io (func con-var &rest args)
(once-only (con-var)
`(progn
- (con-set-callback ,con-var
- (lambda()
- (funcall ,func ,con-var
- (lambda (&rest args) (declare (ignore args)))
- ,@args)))
+ (con-set-callback ,con-var
+ (lambda()
+ (funcall ,func ,con-var
+ (lambda (&rest args) (declare (ignore args)))
+ ,@args)))
(con-run ,con-var)
(values))))
@@ -90,17 +90,17 @@
#| ; cl-cont might overflow stack
(defprotocol accept-forever (con proto)
(loop for n = (io 'accept con)
- do (launch-io proto n)))
+ do (launch-io proto n)))
; |#
(defvar *socket-accept-burst* 16)
(my-defun con 'accept-forever (done proto)
(declare (ignore done))
- (loop repeat *socket-accept-burst*
- for new = (socket-accept (my socket))
- while new
- do (launch-io proto new))
+ (loop repeat *socket-accept-burst*
+ for new = (socket-accept (my socket))
+ while new
+ do (launch-io proto new))
(my when-ready-to-read #'my-call)
(values))
@@ -110,19 +110,19 @@
(with-unique-names (done)
`(progn
(defun-simple-io ,name (,con-var ,@args)
- ,@body)
+ ,@body)
(defun ,name (,con-var ,done ,@args)
- (funcall ,done (locally ,@body))))))
+ (funcall ,done (locally ,@body))))))
#+tpd2-untransformed-io
(defmacro io (func con-var &rest args)
(check-symbols con-var)
(with-unique-names (val)
`(let (,val)
- (funcall ,func ,con-var (lambda (&optional arg &rest args)
- (declare (ignore args))
- (setf ,val arg))
- ,@args)
+ (funcall ,func ,con-var (lambda (&optional arg &rest args)
+ (declare (ignore args))
+ (setf ,val arg))
+ ,@args)
,val)))
diff --git a/src/io/recvbuf.lisp b/src/io/recvbuf.lisp
index ef4523f..dc2980d 100644
--- a/src/io/recvbuf.lisp
+++ b/src/io/recvbuf.lisp
@@ -20,7 +20,7 @@
(my-defun recvbuf reset ()
(my-declare-fast-inline)
(setf (my write-idx) 0
- (my read-idx) 0))
+ (my read-idx) 0))
(declaim (ftype (function () recvbuf) get-recvbuf))
(defun-speedy get-recvbuf ()
@@ -50,7 +50,7 @@
(my-defun recvbuf shift-up (size)
(my-declare-fast-inline)
- (cond
+ (cond
((= (my write-idx) (my read-idx))
(when (> size (my len))
(setf (my store) (make-byte-vector size)))
@@ -77,29 +77,29 @@
(my-declare-fast-inline)
(assert (not (my full)) () 'connection-buffer-overflow-error :con con :len (my len))
(let ((s
- (socket-read (con-socket con)
- (my store)
- (my write-idx))))
- (cond
+ (socket-read (con-socket con)
+ (my store)
+ (my write-idx))))
+ (cond
((not s)
- (when retry
- (con-when-ready-to-read con retry))
- nil)
+ (when retry
+ (con-when-ready-to-read con retry))
+ nil)
(t
- (locally
- (declare (type fixnum s))
- (incf (my write-idx) s)
- s)))))
+ (locally
+ (declare (type fixnum s))
+ (incf (my write-idx) s)
+ s)))))
(my-defun recvbuf recv (con &optional done)
(my-declare-fast-inline)
(let ((s (my read-some con (when done #'my-call))))
(cond ((not s))
- ((zerop s)
- (error 'socket-closed))
- (t
- (when done
- (funcall done))))))
+ ((zerop s)
+ (error 'socket-closed))
+ (t
+ (when done
+ (funcall done))))))
(my-defun recvbuf sync ()
(my-declare-fast-inline)
@@ -127,28 +127,28 @@
(my-declare-fast-inline)
(declare (type simple-byte-vector delimiter))
(let ((limit (- (my write-idx) (1- (length delimiter))))
- (trigger (aref delimiter 0)))
+ (trigger (aref delimiter 0)))
(loop for i from (my read-idx) below limit
- thereis
- (and (= trigger (aref (my store) i))
- (unless
- (loop for j from 1 below (length delimiter)
- thereis (/= (aref delimiter j) (aref (my store) (+ i j))))
- i)))))
+ thereis
+ (and (= trigger (aref (my store) i))
+ (unless
+ (loop for j from 1 below (length delimiter)
+ thereis (/= (aref delimiter j) (aref (my store) (+ i j))))
+ i)))))
(my-defun recvbuf eat-to-delimiter (delimiter)
(my-declare-fast-inline)
(let ((ending (my find delimiter)))
(when ending
- (prog1
+ (prog1
(my eat-to-idx ending)
(incf (my read-idx) (length delimiter))
- (my sync)))))
+ (my sync)))))
(my-defun recvbuf 'print-object (stream)
(print-unreadable-object (me stream :type t :identity t)
(format stream "read ~D/~D bytes: ~A~%|~%~A"
- (my read-idx)
- (my write-idx)
- (force-string (subseq (my store) 0 (my read-idx)))
- (force-string (subseq (my store) (my read-idx) (my write-idx))))))
+ (my read-idx)
+ (my write-idx)
+ (force-string (subseq (my store) 0 (my read-idx)))
+ (force-string (subseq (my store) (my read-idx) (my write-idx))))))
diff --git a/src/io/repeater.lisp b/src/io/repeater.lisp
index dc05f74..487929a 100644
--- a/src/io/repeater.lisp
+++ b/src/io/repeater.lisp
@@ -20,18 +20,18 @@
(when (my fd)
(let ((events 0))
(unless (recvbuf-empty (my buf-to-send))
- (setf events (logior events +POLLOUT+)))
+ (setf events (logior events +POLLOUT+)))
(unless (or (recvbuf-half-full-or-more (my recv)) (my other-has-hung-up))
- (setf events (logior events +POLLIN+)))
-
+ (setf events (logior events +POLLIN+)))
+
(con-when-ready (my con) events))))
(my-defun repeater io ()
(when (my fd)
(when (not (recvbuf-empty (my buf-to-send)))
(let ((s (socket-write (my fd) (recvbuf-peek (my buf-to-send)) 0)))
- (when s
- (recvbuf-eat (my buf-to-send) s))))
+ (when s
+ (recvbuf-eat (my buf-to-send) s))))
(when (and (recvbuf-empty (my buf-to-send)) (my other-has-hung-up))
(hangup (my con))))
@@ -47,22 +47,22 @@
(setf (my other) other)
(setf (repeater-other (my other)) me)
(con-set-callback (my con)
- (lambda() (my io)))
+ (lambda() (my io)))
(my register-wait))
(defun do-repeat (con generator)
(let ((target (funcall generator)))
(let ((a (make-repeater :con con))
- (b (make-repeater :con target)))
+ (b (make-repeater :con target)))
(repeater-launch-io a b)
(repeater-launch-io b a))))
(defprotocol repeat (con generator)
(loop for new = (io 'accept con)
- do
- (do-repeat new generator)))
+ do
+ (do-repeat new generator)))
(defun forward-port (&key (src-address "127.0.0.1") src-port (dst-address "127.0.0.1") dst-port)
(launch-io 'repeat (make-con-listen :port src-port :address src-address)
- (lambda()(make-con-connect :address dst-address :port dst-port))))
+ (lambda()(make-con-connect :address dst-address :port dst-port))))
diff --git a/src/io/sendbuf.lisp b/src/io/sendbuf.lisp
index a8aabc5..eb6dfe9 100644
--- a/src/io/sendbuf.lisp
+++ b/src/io/sendbuf.lisp
@@ -15,14 +15,14 @@
(my-declare-fast-inline)
(the simple-byte-vector
(if (not (cdr (my head)))
- (if (my head) (the simple-byte-vector (car (my head))) (force-byte-vector nil))
- (let ((result (make-byte-vector (+ (my len) (my offset)))) (i 0))
- (declare (type fixnum i))
- (loop for s in (my head) do
- (loop for c of-type (unsigned-byte 8) across (the simple-byte-vector s) do
- (setf (aref result i) c)
- (incf i)))
- result))))
+ (if (my head) (the simple-byte-vector (car (my head))) (force-byte-vector nil))
+ (let ((result (make-byte-vector (+ (my len) (my offset)))) (i 0))
+ (declare (type fixnum i))
+ (loop for s in (my head) do
+ (loop for c of-type (unsigned-byte 8) across (the simple-byte-vector s) do
+ (setf (aref result i) c)
+ (incf i)))
+ result))))
(my-defun sendbuf add-simple (buf)
(my-declare-fast-inline)
@@ -32,17 +32,17 @@
(incf (my len) (the sendbuf-small-integer (length buf)))
(let ((n (cons buf nil)))
(cond ((my head)
- (setf (cdr (my tail)) n
- (my tail) n))
- (t (setf (my head) n
- (my tail) n))))))
+ (setf (cdr (my tail)) n
+ (my tail) n))
+ (t (setf (my head) n
+ (my tail) n))))))
(my-defun sendbuf add (x)
(my-declare-fast-inline)
(typecase x
(simple-byte-vector
(my add-simple x))
- (sendbuf
+ (sendbuf
(my merge x))
(t
(my add-simple (force-simple-byte-vector x))))
@@ -51,34 +51,34 @@
(my-defun sendbuf merge (other)
(my-declare-fast-inline)
(declare (dynamic-extent other))
- (cond
+ (cond
((my head)
(setf (cdr (my tail)) (sendbuf-head other))
(when (sendbuf-tail other)
(setf (my tail) (sendbuf-tail other))))
(t (setf (my head) (sendbuf-head other)
- (my tail) (sendbuf-tail other))))
+ (my tail) (sendbuf-tail other))))
(incf (my len) (sendbuf-len other))
(incf (my num-bufs) (sendbuf-num-bufs other))
- (setf (sendbuf-num-bufs other) 0
- (sendbuf-head other) nil
- (sendbuf-tail other) nil
- (sendbuf-len other) 0)
+ (setf (sendbuf-num-bufs other) 0
+ (sendbuf-head other) nil
+ (sendbuf-tail other) nil
+ (sendbuf-len other) 0)
(values))
(defmacro with-sendbuf-continue ((var) &body body &environment env)
`(progn
,@(loop for form in (merge-constant-arguments body :join 'byte-vector-cat :env env)
- collect
- (typecase form
- (null nil)
- (simple-byte-vector
- (when (length form)
- `(sendbuf-add-simple ,var ,form)))
- (t
- `(sendbuf-add ,var
- ,form))))
+ collect
+ (typecase form
+ (null nil)
+ (simple-byte-vector
+ (when (length form)
+ `(sendbuf-add-simple ,var ,form)))
+ (t
+ `(sendbuf-add ,var
+ ,form))))
(values)))
(defmacro with-sendbuf ((&optional (var (gensym "sendbuf"))) &body body)
@@ -95,7 +95,7 @@
(my-defun sendbuf check-done (con finished my-call)
(my-declare-fast-inline)
- (cond
+ (cond
((my done)
(setf (my tail) nil)
(funcall finished))
@@ -111,37 +111,37 @@
(incf s (my offset))
(setf (my offset) 0)
(loop until (zerop s)
- do
- (debug-assert (my head) (me s))
- (let ((buf (car (my head))))
- (declare (type simple-byte-vector buf))
- (cond
- ((>= s (length buf))
- (decf s (length buf))
- (decf (my num-bufs))
- (setf (my head)
- (cdr (my head))))
- (t
- (setf (my offset) s)
- (return))))))
+ do
+ (debug-assert (my head) (me s))
+ (let ((buf (car (my head))))
+ (declare (type simple-byte-vector buf))
+ (cond
+ ((>= s (length buf))
+ (decf s (length buf))
+ (decf (my num-bufs))
+ (setf (my head)
+ (cdr (my head))))
+ (t
+ (setf (my offset) s)
+ (return))))))
#- (and) ;; broken
(my-defun sendbuf send-write-piece-by-piece (con done)
(loop for buf of-type simple-byte-vector = (car (my head))
- for tmp-buf = (make-displaced-vector buf :start (my offset)) then buf
- while
- (let ((s (socket-write (con-socket con) tmp-buf)))
- (declare (type (or null sendbuf-small-integer) s))
- (when s
- (decf (my len) s)
- (cond ((> (length tmp-buf) s)
- (setf (my offset) s)
- nil)
- (t
- (setf (my head) (cdr (my head))
- (my offset) 0)
- (decf (my num-bufs))
- (my head))))))
+ for tmp-buf = (make-displaced-vector buf :start (my offset)) then buf
+ while
+ (let ((s (socket-write (con-socket con) tmp-buf)))
+ (declare (type (or null sendbuf-small-integer) s))
+ (when s
+ (decf (my len) s)
+ (cond ((> (length tmp-buf) s)
+ (setf (my offset) s)
+ nil)
+ (t
+ (setf (my head) (cdr (my head))
+ (my offset) 0)
+ (decf (my num-bufs))
+ (my head))))))
(my check-done con done #'my-call))
(my-defun sendbuf send-write (con done)
@@ -150,7 +150,7 @@
(let ((s (socket-write (con-socket con) buf (my offset))))
(declare (type (or null sendbuf-small-integer) s))
(when s
- (my shift-up s))))
+ (my shift-up s))))
(my check-done con done #'my-call))
(my-defun sendbuf send-writev (con done)
@@ -159,25 +159,25 @@
(let ((count (min +max-iovecs+ (my num-bufs))))
(declare (type (integer 0 #.+max-iovecs+) count))
(cffi:with-foreign-object (vecs 'iovec count)
- (loop for i below count
- for buf of-type simple-byte-vector in (my head)
- for offset fixnum = (my offset) then 0
- do
- (with-pointer-to-vector-data (ptr buf)
- (cffi:with-foreign-slots ((base len) (cffi:mem-aref vecs 'iovec i) iovec)
- (setf base (cffi:inc-pointer ptr offset))
- (setf len (- (length buf) offset)))))
- (let ((s (socket-writev (con-socket con) vecs count)))
- (declare (type (or null sendbuf-small-integer) s))
- (when s
- (my shift-up s))))))
+ (loop for i below count
+ for buf of-type simple-byte-vector in (my head)
+ for offset fixnum = (my offset) then 0
+ do
+ (with-pointer-to-vector-data (ptr buf)
+ (cffi:with-foreign-slots ((base len) (cffi:mem-aref vecs 'iovec i) iovec)
+ (setf base (cffi:inc-pointer ptr offset))
+ (setf len (- (length buf) offset)))))
+ (let ((s (socket-writev (con-socket con) vecs count)))
+ (declare (type (or null sendbuf-small-integer) s))
+ (when s
+ (my shift-up s))))))
(my check-done con done #'my-call))
(my-defun sendbuf 'print-object (stream)
(cond (*print-readably* (call-next-method))
- (t (write (force-string (my to-byte-vector)) :stream stream))))
+ (t (write (force-string (my to-byte-vector)) :stream stream))))
(my-defun sendbuf empty ()
(my-declare-fast-inline)
diff --git a/src/io/ssl.lisp b/src/io/ssl.lisp
index 8047337..2cb2e90 100644
--- a/src/io/ssl.lisp
+++ b/src/io/ssl.lisp
@@ -12,7 +12,7 @@
(cmd :int)
(larg :long)
(parg :pointer))
-
+
(defun ssl-socket-init (ss)
(initialize-openssl)
(let ((context *ssl-ctx*))
@@ -24,8 +24,8 @@
(setf (ssl-socket-state ss) 'connect)
(let ((socket (ssl-socket-ssl ss)))
- (trivial-garbage:finalize ss (lambda()
- (ssl-free socket)))))
+ (trivial-garbage:finalize ss (lambda()
+ (ssl-free socket)))))
(defun convert-con-to-ssl (con)
(let ((ss (make-ssl-socket :transport (con-socket con))))
@@ -43,25 +43,25 @@
(print-unreadable-object (ss stream :identity t)
(with-slots (call-name return-code ssl-error-code errno) ss
(format stream "~A returned ~A; SSL_Get_Error ~A; errno ~A"
- call-name return-code ssl-error-code errno))))
-
+ call-name return-code ssl-error-code errno))))
+
(defun ssl-socket-check-error (ss rc call-name)
(when (> 0 rc)
(case (ssl-get-error (ssl-socket-ssl ss) rc)
(#.+SSL_ERROR_NONE+ nil)
(#.+SSL_ERROR_WANT_READ+ (setf (ssl-socket-event-wanted ss) +POLLIN+))
(#.+SSL_ERROR_WANT_WRITE+ (setf (ssl-socket-event-wanted ss) +POLLOUT+))
- (otherwise
+ (otherwise
(error 'ssl-error :call-name call-name :rc rc :ssl-error-code (ssl-get-error (ssl-socket-ssl ss) rc))))))
(defun ssl-socket-process-state (ss)
(setf (ssl-socket-event-wanted ss) 0)
(ecase (ssl-socket-state ss)
- (connect
- (unless
- (or
- (ssl-socket-check-error ss (ssl-connect (ssl-socket-ssl ss)) "SSL_Connect")
- (eq +SSL_ST_CONNECT+ (ssl-state (ssl-socket-ssl ss))))
+ (connect
+ (unless
+ (or
+ (ssl-socket-check-error ss (ssl-connect (ssl-socket-ssl ss)) "SSL_Connect")
+ (eq +SSL_ST_CONNECT+ (ssl-state (ssl-socket-ssl ss))))
(setf (ssl-socket-state ss) 'running)))
(running
nil))
@@ -70,24 +70,24 @@
(defmethod socket-write ((ss ssl-socket) buf offset)
(unless (ssl-socket-process-state ss)
(let ((written
- (cffi:with-pointer-to-vector-data (out-ptr buf)
- (ssl-write (ssl-socket-ssl ss) (cffi:inc-pointer out-ptr offset) (- (length buf) offset)))))
+ (cffi:with-pointer-to-vector-data (out-ptr buf)
+ (ssl-write (ssl-socket-ssl ss) (cffi:inc-pointer out-ptr offset) (- (length buf) offset)))))
(ssl-socket-check-error ss written "SSL_Write")
(when (> written 0)
- written))))
+ written))))
(defmethod socket-read ((ss ssl-socket) buf offset)
(unless (ssl-socket-process-state ss)
(let ((amount
- (cffi:with-pointer-to-vector-data (in-ptr buf)
- (ssl-read (ssl-socket-ssl ss) (cffi:inc-pointer in-ptr offset) (- (length buf) offset)))))
+ (cffi:with-pointer-to-vector-data (in-ptr buf)
+ (ssl-read (ssl-socket-ssl ss) (cffi:inc-pointer in-ptr offset) (- (length buf) offset)))))
(ssl-socket-check-error ss amount "SSL_Read")
- (cond ((and (zerop amount)
- (eql (ssl-get-error (ssl-socket-ssl ss) 0) +SSL_ERROR_ZERO_RETURN+))
- 0)
- ((> amount 0) amount)
- (t nil)))))
-
+ (cond ((and (zerop amount)
+ (eql (ssl-get-error (ssl-socket-ssl ss) 0) +SSL_ERROR_ZERO_RETURN+))
+ 0)
+ ((> amount 0) amount)
+ (t nil)))))
+
(defmethod socket-peer ((ss ssl-socket))
(socket-peer (ssl-socket-transport ss)))
@@ -98,8 +98,8 @@
(defmethod socket-register ((ss ssl-socket) events con)
(debug-assert (eql ss (con-socket con)) (ss con))
- (register-fd (ssl-socket-transport ss)
- (if (zerop (ssl-socket-event-wanted ss))
- events
- (ssl-socket-event-wanted ss))
- con))
+ (register-fd (ssl-socket-transport ss)
+ (if (zerop (ssl-socket-event-wanted ss))
+ events
+ (ssl-socket-event-wanted ss))
+ con))
diff --git a/src/io/syscalls.lisp b/src/io/syscalls.lisp
index 31fcb9b..5a7a64c 100644
--- a/src/io/syscalls.lisp
+++ b/src/io/syscalls.lisp
@@ -174,8 +174,8 @@
((errno :initarg :errno :reader syscall-failed-errno)
(syscall :initarg :syscall))
(:report (lambda (condition stream)
- (with-slots (errno syscall) condition
- (format stream "~A failed: ~A (errno ~A)" syscall (strerror errno) errno)))))
+ (with-slots (errno syscall) condition
+ (format stream "~A failed: ~A (errno ~A)" syscall (strerror errno) errno)))))
(eval-always
(defun syscall-name (name)
@@ -194,43 +194,43 @@
(destructuring-bind (name &key (would-block '(+EAGAIN+ +EINPROGRESS+)) (error t))
(force-list name-and-options)
(let ((direct-sym (direct-syscall-sym name))
- (noretry-sym (noretry-syscall-sym name))
- (syscall-name (syscall-name name))
- (arg-names (mapcar #'first args))
- (func (concat-sym-from-sym-package 'def-simple-syscall 'syscall- name)))
+ (noretry-sym (noretry-syscall-sym name))
+ (syscall-name (syscall-name name))
+ (arg-names (mapcar #'first args))
+ (func (concat-sym-from-sym-package 'def-simple-syscall 'syscall- name)))
`(progn
- (declaim (inline ,func ,direct-sym ,noretry-sym))
- (declaim (ftype (function (,@(mapcar (constantly t) arg-names)) (or null syscall-return-integer)) ,noretry-sym)
- (ftype (function (,@(mapcar (constantly t) arg-names)) syscall-return-integer) ,func ,direct-sym))
- (def-syscall ,name ,@args)
- (defun ,noretry-sym ,arg-names
- (declare (optimize speed (safety 0)))
- (let ((val (,direct-sym ,@arg-names)))
- (cond ((/= val -1) val)
- (t
- (let ((errno errno))
- (cond ((or ,@(loop for e in would-block collect `(= errno ,e)))
- -1)
- ((= errno +EINTR+)
- nil)
- (t
- ,(if error
- `(error 'syscall-failed :errno errno :syscall ,syscall-name)
- -1) )))))))
-
- (defun ,func ,arg-names
- (declare (optimize speed (safety 0)))
- (loop
- (let ((val (,noretry-sym ,@arg-names)))
- (when val (return val)))))))))
+ (declaim (inline ,func ,direct-sym ,noretry-sym))
+ (declaim (ftype (function (,@(mapcar (constantly t) arg-names)) (or null syscall-return-integer)) ,noretry-sym)
+ (ftype (function (,@(mapcar (constantly t) arg-names)) syscall-return-integer) ,func ,direct-sym))
+ (def-syscall ,name ,@args)
+ (defun ,noretry-sym ,arg-names
+ (declare (optimize speed (safety 0)))
+ (let ((val (,direct-sym ,@arg-names)))
+ (cond ((/= val -1) val)
+ (t
+ (let ((errno errno))
+ (cond ((or ,@(loop for e in would-block collect `(= errno ,e)))
+ -1)
+ ((= errno +EINTR+)
+ nil)
+ (t
+ ,(if error
+ `(error 'syscall-failed :errno errno :syscall ,syscall-name)
+ -1) )))))))
+
+ (defun ,func ,arg-names
+ (declare (optimize speed (safety 0)))
+ (loop
+ (let ((val (,noretry-sym ,@arg-names)))
+ (when val (return val)))))))))
(def-simple-syscall (close :would-block nil)
(fd :int))
(defconstant +SHUT_RD+ 0)
-(defconstant +SHUT_WR+ 1)
-(defconstant +SHUT_RDWR+ 2)
+(defconstant +SHUT_WR+ 1)
+(defconstant +SHUT_RDWR+ 2)
(def-simple-syscall (shutdown :would-block (+ENOTCONN+))
(fd :int)
@@ -242,8 +242,8 @@
(cffi:defcfun ("signal" syscall-signal)
:pointer
- (signum :int)
- (action :pointer))
+ (signum :int)
+ (action :pointer))
(cffi:defctype size_t :unsigned-long)
@@ -286,33 +286,33 @@
(defconstant +SOCK_NONBLOCK+ #o04000)
-(def-simple-syscall (accept4 :would-block (+EAGAIN+
- +EMFILE+
- +EINPROGRESS+
- +ENETDOWN+
- +EPROTO+
- +ENOPROTOOPT+
- +EHOSTDOWN+
- +ENONET+
- +EHOSTUNREACH+
- +EOPNOTSUPP+
- +ENETUNREACH+))
+(def-simple-syscall (accept4 :would-block (+EAGAIN+
+ +EMFILE+
+ +EINPROGRESS+
+ +ENETDOWN+
+ +EPROTO+
+ +ENOPROTOOPT+
+ +EHOSTDOWN+
+ +ENONET+
+ +EHOSTUNREACH+
+ +EOPNOTSUPP+
+ +ENETUNREACH+))
(sockfd :int)
(addr :pointer)
(addrlen :pointer)
(flags :int))
-(def-simple-syscall (accept :would-block (+EAGAIN+
- +EMFILE+
- +EINPROGRESS+
- +ENETDOWN+
- +EPROTO+
- +ENOPROTOOPT+
- +EHOSTDOWN+
- +ENONET+
- +EHOSTUNREACH+
- +EOPNOTSUPP+
- +ENETUNREACH+))
+(def-simple-syscall (accept :would-block (+EAGAIN+
+ +EMFILE+
+ +EINPROGRESS+
+ +ENETDOWN+
+ +EPROTO+
+ +ENOPROTOOPT+
+ +EHOSTDOWN+
+ +ENONET+
+ +EHOSTUNREACH+
+ +EOPNOTSUPP+
+ +ENETUNREACH+))
(sockfd :int)
(addr :pointer)
(addrlen :pointer))
@@ -338,13 +338,13 @@
(defun grovel-from-c-defines (string)
(dolist (line (cl-ppcre:split "\\n" string))
(cl-ppcre:register-groups-bind (name val description)
- ("^#define\\s+(\\S+)\\s+(\\S+)\\s*(?:/\\*\\s*(.*?)\\s*\\*/)?" line)
- (format t "(defconstant +~A+ ~A \"~A\")~&"
- name val (or description name)))
+ ("^#define\\s+(\\S+)\\s+(\\S+)\\s*(?:/\\*\\s*(.*?)\\s*\\*/)?" line)
+ (format t "(defconstant +~A+ ~A \"~A\")~&"
+ name val (or description name)))
(cl-ppcre:register-groups-bind (name val description)
- ("^\\s*(\\S+)\\s*=\\s*(\\S+?(?:,)?)\\s*(?:/\\*\\s*(.*?)\\s*\\*/)?" line)
- (format t "(defconstant +~A+ ~A \"~A\")~&"
- name val (or description name)))))
+ ("^\\s*(\\S+)\\s*=\\s*(\\S+?(?:,)?)\\s*(?:/\\*\\s*(.*?)\\s*\\*/)?" line)
+ (format t "(defconstant +~A+ ~A \"~A\")~&"
+ name val (or description name)))))
|#
@@ -459,7 +459,7 @@
(defun socket-cork (fd)
(setsockopt-int fd +IPPROTO_TCP+ +TCP_CORK+ 1))
-
+
(defun socket-uncork (fd)
(setsockopt-int fd +IPPROTO_TCP+ +TCP_CORK+ 0))
@@ -527,7 +527,7 @@
(next :pointer))
-(cffi:defcfun getaddrinfo
+(cffi:defcfun getaddrinfo
:int
(node :string)
(service :string)
@@ -542,11 +542,11 @@
(cffi:with-foreign-object (res :pointer)
(let ((ret (getaddrinfo hostname (cffi:null-pointer) (cffi:null-pointer) res)))
(when (zerop ret)
- (let ((ai (cffi:mem-ref res :pointer)))
- (unwind-protect
- (sockaddr-address-string-with-ntop
- (cffi:foreign-slot-value ai 'addrinfo 'addr))
- (freeaddrinfo ai)))))))
+ (let ((ai (cffi:mem-ref res :pointer)))
+ (unwind-protect
+ (sockaddr-address-string-with-ntop
+ (cffi:foreign-slot-value ai 'addrinfo 'addr))
+ (freeaddrinfo ai)))))))
(def-simple-syscall setsockopt
(fd :int)
@@ -559,14 +559,14 @@
(cffi:with-foreign-object (on :int)
(setf (cffi:mem-ref on :int) value)
(syscall-setsockopt fd level optname
- on (cffi:foreign-type-size :int))))
+ on (cffi:foreign-type-size :int))))
(defun sockaddr-address-string-with-ntop (sa)
(cffi:with-foreign-pointer-as-string ((str str-size) 200)
(unless (inet_ntop (cffi:foreign-slot-value sa 'sockaddr_in 'family)
- (cffi:foreign-slot-pointer sa 'sockaddr_in 'addr)
- str
- str-size)
+ (cffi:foreign-slot-pointer sa 'sockaddr_in 'addr)
+ str
+ str-size)
(error "Cannot convert address: ~A" (strerror errno)))))
#+tpd2-old-sockaddr-address-string
@@ -583,8 +583,8 @@
#.`(strcat ,@(loop for i below 4 unless (= i 0) collect "." collect `(the simple-string (aref octet-to-string (ldb (byte 8 (* 8 ,i)) addr))))))))
(alexandria:define-constant +octet-to-bv+
- (make-array 256 :element-type 'simple-byte-vector
- :initial-contents (mapcar 'force-simple-byte-vector (loop for i from 0 below 256 collect (format nil "~3,'0D" i))))
+ (make-array 256 :element-type 'simple-byte-vector
+ :initial-contents (mapcar 'force-simple-byte-vector (loop for i from 0 below 256 collect (format nil "~3,'0D" i))))
:test 'equalp)
(defun-speedy bv-from-address (addr)
@@ -593,62 +593,62 @@
(let ((dest (make-byte-vector (1- (* 4 4)))))
(declare (type simple-byte-vector dest))
(macrolet ((write-one (offset &optional terminate?)
- `(let ((str (aref +octet-to-bv+ (logand addr #xff))))
- (declare (type simple-byte-vector str))
- ,(when terminate? `(setf addr (ash addr -8)))
- ,@(loop for i below 3 collect `(setf (aref dest ,(+ i offset)) (aref str ,i)))
- ,(when terminate?
- `(setf (aref dest ,(+ offset 3)) ,(char-code #\.)))))
- (write-all ()
- `(progn ,@(loop for i below 4
- collect `(write-one ,(* i 4) ,(> 3 i))))))
- (write-all)
- dest)))
+ `(let ((str (aref +octet-to-bv+ (logand addr #xff))))
+ (declare (type simple-byte-vector str))
+ ,(when terminate? `(setf addr (ash addr -8)))
+ ,@(loop for i below 3 collect `(setf (aref dest ,(+ i offset)) (aref str ,i)))
+ ,(when terminate?
+ `(setf (aref dest ,(+ offset 3)) ,(char-code #\.)))))
+ (write-all ()
+ `(progn ,@(loop for i below 4
+ collect `(write-one ,(* i 4) ,(> 3 i))))))
+ (write-all)
+ dest)))
(defun-speedy sockaddr-address-bv (sa)
(declare (optimize speed (safety 0)))
(bv-from-address (cffi:foreign-slot-value sa 'sockaddr_in 'addr)))
-
-
-(defun new-socket-helper (&key
- port
- address
- socket-family
- socket-type
- action)
+
+
+(defun new-socket-helper (&key
+ port
+ address
+ socket-family
+ socket-type
+ action)
(let ((fd (syscall-socket socket-family socket-type 0)))
- (signal-protect
+ (signal-protect
(let ((network-port (htons port)))
(setsockopt-int fd +SOL_SOCKET+ +SO_REUSEADDR+ 1)
(set-fd-nonblock fd)
(with-foreign-object-and-slots ((addr port family) sa sockaddr_in)
- (setf family socket-family)
- (cffi:with-foreign-string (src address)
- (when (<= (inet_pton socket-family src
- (cffi:foreign-slot-pointer sa 'sockaddr_in 'addr)) 0)
- (error "Internet address is not valid: ~A" address)))
- (setf port network-port)
- (funcall action fd sa (cffi:foreign-type-size 'sockaddr_in)))
+ (setf family socket-family)
+ (cffi:with-foreign-string (src address)
+ (when (<= (inet_pton socket-family src
+ (cffi:foreign-slot-pointer sa 'sockaddr_in 'addr)) 0)
+ (error "Internet address is not valid: ~A" address)))
+ (setf port network-port)
+ (funcall action fd sa (cffi:foreign-type-size 'sockaddr_in)))
fd)
(syscall-close fd))))
(defun make-listen-socket (&rest args)
- (apply 'new-socket-helper :action
- (lambda(fd sa len)
- (syscall-bind fd sa len)
- (syscall-listen fd 1024))
- args))
+ (apply 'new-socket-helper :action
+ (lambda(fd sa len)
+ (syscall-bind fd sa len)
+ (syscall-listen fd 1024))
+ args))
(defun make-bind-socket (&rest args)
- (apply 'new-socket-helper :action
- (lambda(fd sa len)
- (syscall-bind fd sa len))
- args))
+ (apply 'new-socket-helper :action
+ (lambda(fd sa len)
+ (syscall-bind fd sa len))
+ args))
(defun make-connect-socket (&rest args)
- (apply 'new-socket-helper
- :action 'syscall-connect
- args))
+ (apply 'new-socket-helper
+ :action 'syscall-connect
+ args))
(defconstant +max-iovecs+ 1024)
@@ -660,8 +660,8 @@
(sec :unsigned-long)
(usec :unsigned-long))
-(def-simple-syscall gettimeofday
- (tv :pointer)
+(def-simple-syscall gettimeofday
+ (tv :pointer)
(tz :pointer))
(defconstant +unix-epoch-to-universal-time-offset+ 2208988800)
@@ -683,11 +683,11 @@
(defun syscall-retry-epoll_wait (epfd events maxevents timeout-ms)
(let ((start (get-internal-real-time)))
(loop
- (let ((retval (syscall-noretry-epoll_wait epfd events maxevents timeout-ms)))
- (when retval (return retval))
- (unless (>= 0 timeout-ms)
- (setf timeout-ms
- (max (- timeout-ms (floor (- (get-internal-real-time) start) (ceiling internal-time-units-per-second 1000))) 0)))))))
+ (let ((retval (syscall-noretry-epoll_wait epfd events maxevents timeout-ms)))
+ (when retval (return retval))
+ (unless (>= 0 timeout-ms)
+ (setf timeout-ms
+ (max (- timeout-ms (floor (- (get-internal-real-time) start) (ceiling internal-time-units-per-second 1000))) 0)))))))
(def-simple-syscall epoll_ctl
(epfd :int)
@@ -734,7 +734,7 @@
#+sbcl ; debug
(defun check-fd-dead (fd)
(assert (not
- (ignore-errors
- (sb-posix:readlink (format nil "/proc/~A/fd/~A" (sb-posix:getpid) fd))))
- (fd)
- "FD ~A still alive" fd))
\ No newline at end of file
+ (ignore-errors
+ (sb-posix:readlink (format nil "/proc/~A/fd/~A" (sb-posix:getpid) fd))))
+ (fd)
+ "FD ~A still alive" fd))
\ No newline at end of file
diff --git a/src/lib/byte-vector.lisp b/src/lib/byte-vector.lisp
index 02bf42b..2e87c29 100644
--- a/src/lib/byte-vector.lisp
+++ b/src/lib/byte-vector.lisp
@@ -5,27 +5,27 @@
(once-only (lisp-vector)
(with-unique-names (tmp real-vector offset cffi-ptr)
`(let ((,tmp))
- (multiple-value-bind
- (,real-vector ,offset)
- (array-displacement ,lisp-vector)
- (when ,real-vector
- (setf ,lisp-vector ,real-vector))
- (cffi:with-pointer-to-vector-data (,cffi-ptr ,lisp-vector)
- (let ((,ptr (cffi:inc-pointer ,cffi-ptr ,offset)))
- (setf ,tmp (multiple-value-list (locally ,@body)))))
- (values-list ,tmp))))))
+ (multiple-value-bind
+ (,real-vector ,offset)
+ (array-displacement ,lisp-vector)
+ (when ,real-vector
+ (setf ,lisp-vector ,real-vector))
+ (cffi:with-pointer-to-vector-data (,cffi-ptr ,lisp-vector)
+ (let ((,ptr (cffi:inc-pointer ,cffi-ptr ,offset)))
+ (setf ,tmp (multiple-value-list (locally ,@body)))))
+ (values-list ,tmp))))))
(defun-speedy concatenate-simple-byte-vectors (args)
(let ((len 0))
(declare (type fixnum len))
- (loop for x in args do
- (incf len (the fixnum (length (the simple-byte-vector x)))))
+ (loop for x in args do
+ (incf len (the fixnum (length (the simple-byte-vector x)))))
(let ((ret (make-byte-vector len)) (i 0))
(declare (type fixnum i))
- (loop for x in args do
- (loop for c across (the simple-byte-vector x) do
- (setf (aref ret i) c)
- (incf i)))
+ (loop for x in args do
+ (loop for c across (the simple-byte-vector x) do
+ (setf (aref ret i) c)
+ (incf i)))
ret)))
@@ -33,26 +33,26 @@
(declare (dynamic-extent args))
(let ((ret (make-byte-vector (length args))))
(loop for i from 0
- for arg in args
- do (setf (aref ret i) arg))
+ for arg in args
+ do (setf (aref ret i) arg))
ret))
(define-constant +byte-to-digit-table+
- (make-array 256 :element-type '(integer -1 36)
- :initial-contents (loop for i from 0 below 256
- collect
- (labels ((c (x) (char-code x))
- (in-range (a b x offset)
- (let ((l (min (c a) (c b)))
- (m (max (c a) (c b))))
- (when
- (and (>= x l)
- (>= m x))
- (+ (- x l) offset)))))
- (or (in-range #\a #\z i 10)
- (in-range #\A #\Z i 10)
- (in-range #\0 #\9 i 0)
- -1))))
+ (make-array 256 :element-type '(integer -1 36)
+ :initial-contents (loop for i from 0 below 256
+ collect
+ (labels ((c (x) (char-code x))
+ (in-range (a b x offset)
+ (let ((l (min (c a) (c b)))
+ (m (max (c a) (c b))))
+ (when
+ (and (>= x l)
+ (>= m x))
+ (+ (- x l) offset)))))
+ (or (in-range #\a #\z i 10)
+ (in-range #\A #\Z i 10)
+ (in-range #\0 #\9 i 0)
+ -1))))
:test 'equalp)
(declaim-defun-consistent-ftype byte-to-digit ((unsigned-byte 8)) (integer -1 36))
@@ -67,16 +67,16 @@
(declare (type byte-vector string))
(let ((i 0) (val 0) (sign 1))
(flet ((cur ()
- (aref string i))
- (eat ()
- (incf i)))
+ (aref string i))
+ (eat ()
+ (incf i)))
(declare (ftype (function () (unsigned-byte 8)) cur))
(when (= (char-code #\-) (cur))
- (setf sign -1)
- (eat))
+ (setf sign -1)
+ (eat))
(loop while (> (length string) i) do
- (setf val (+ (byte-to-digit (cur)) (* val base)))
- (eat))
+ (setf val (+ (byte-to-digit (cur)) (* val base)))
+ (eat))
(* sign val))))
@@ -96,47 +96,47 @@
(declare (type simple-byte-vector a b))
(and (= (length a) (length b))
(loop for i from 0 below (length a)
- always (eql-fold-ascii-case (aref a i) (aref b i)))))
+ always (eql-fold-ascii-case (aref a i) (aref b i)))))
(defun-speedy unsafe-length-byte-vector=-fold-ascii-case (a b)
(declare (type simple-byte-vector a b)
- (optimize speed (safety 0)))
+ (optimize speed (safety 0)))
(loop for i from 0 below (length a)
- always (= (aref b i) (byte-to-ascii-upper (aref a i)))))
+ always (= (aref b i) (byte-to-ascii-upper (aref a i)))))
(defmacro case-match-fold-ascii-case (keyform &rest clauses)
;;; could be improved not to duplicate the clauses code and to handle non-constant forms much better
(flet ((give-up ()
- (return-from case-match-fold-ascii-case (generate-case-key keyform :test 'byte-vector=-fold-ascii-case :transform 'force-byte-vector :clauses clauses))))
+ (return-from case-match-fold-ascii-case (generate-case-key keyform :test 'byte-vector=-fold-ascii-case :transform 'force-byte-vector :clauses clauses))))
(let ((table (make-hash-table :test #'equalp)) otherwise)
(loop for (val . body) in clauses
- for vals = (force-list val)
- do
- (unless (every #'constantp vals)
- (give-up))
- (loop for v in vals
- for bv = (force-simple-byte-vector (map 'byte-vector 'byte-to-ascii-upper
- (force-byte-vector (eval v))))
- do
- (case v
- ((t otherwise)
- (assert (not otherwise))
- (setf otherwise body))
- (t
- (push (cons bv body) (gethash (length bv) table))))))
+ for vals = (force-list val)
+ do
+ (unless (every #'constantp vals)
+ (give-up))
+ (loop for v in vals
+ for bv = (force-simple-byte-vector (map 'byte-vector 'byte-to-ascii-upper
+ (force-byte-vector (eval v))))
+ do
+ (case v
+ ((t otherwise)
+ (assert (not otherwise))
+ (setf otherwise body))
+ (t
+ (push (cons bv body) (gethash (length bv) table))))))
(with-unique-names (key)
`(let ((,key (force-byte-vector ,keyform)))
- (case (length ,key)
- ,@(loop for len being the hash-keys of table using (hash-value vb)
- do (when otherwise (give-up))
- collect
- `(,len
- ,(generate-case-key key
- :test 'unsafe-length-byte-vector=-fold-ascii-case
- :clauses vb)))
- ,@(when otherwise
- `((otherwise ,otherwise)))))))))
+ (case (length ,key)
+ ,@(loop for len being the hash-keys of table using (hash-value vb)
+ do (when otherwise (give-up))
+ collect
+ `(,len
+ ,(generate-case-key key
+ :test 'unsafe-length-byte-vector=-fold-ascii-case
+ :clauses vb)))
+ ,@(when otherwise
+ `((otherwise ,otherwise)))))))))
(defun copy-byte-vector (a)
(let ((b (make-byte-vector (length a))))
diff --git a/src/lib/callcc.lisp b/src/lib/callcc.lisp
index a0cbf1f..e6ddfce 100644
--- a/src/lib/callcc.lisp
+++ b/src/lib/callcc.lisp
@@ -5,7 +5,7 @@
k
#+use-arnesi-for-continuations (lambda(&optional x) (arnesi:kall k x)))
-(cl-cont:defcpstransformer without-call/cc (cons k-expr env)
+(cl-cont:defcpstransformer without-call/cc (cons k-expr env)
(declare (ignore env))
`(funcall ,k-expr (locally ,@(cdr cons))))
@@ -18,26 +18,26 @@
(defmacro cl-cont-pass-through-constructs (&rest names)
`(progn
,@(loop for n in names collect
- `(cl-cont-pass-through-one-construct ,n))))
-
+ `(cl-cont-pass-through-one-construct ,n))))
+
(defmacro with-join-spawn/cc ((&optional (name (gensym "join"))) &body body)
(with-unique-names (k)
`(call/cc
(lambda (,k)
(let ((,name 1))
- (flet ((,name ()
- (assert (plusp ,name) (,name) "spawn/cc returned too much")
- (decf ,name)
- (when (zerop ,name)
- (funcall ,k))))
- (macrolet ((spawn/cc ((&optional (name ',name)) &body body)
- `(progn
- (incf ,name)
- (with-call/cc
- ,@body
- (,name)))))
- ,@body)
- (,name)))))))
+ (flet ((,name ()
+ (assert (plusp ,name) (,name) "spawn/cc returned too much")
+ (decf ,name)
+ (when (zerop ,name)
+ (funcall ,k))))
+ (macrolet ((spawn/cc ((&optional (name ',name)) &body body)
+ `(progn
+ (incf ,name)
+ (with-call/cc
+ ,@body
+ (,name)))))
+ ,@body)
+ (,name)))))))
(eval-always
(cl-cont-pass-through-constructs
@@ -45,11 +45,11 @@
handler-bind
restart-case
restart-bind
-
+
without-call/cc
cl-irregsexp::with-match))
-#+extra-bugs-please
+#+extra-bugs-please
(defmacro cl-cont:call/cc (cc)
"Implements delimited continuations."
(declare (ignore cc))
diff --git a/src/lib/macros.lisp b/src/lib/macros.lisp
index 35b0c76..58340a3 100644
--- a/src/lib/macros.lisp
+++ b/src/lib/macros.lisp
@@ -6,17 +6,17 @@
(defmacro check-symbols (&rest names)
`(progn
- ,@(loop for n in names collect
+ ,@(loop for n in names collect
`(check-type ,n symbol))))
(defmacro with-package (package &body body)
(let ((*package* (find-package package)))
(labels ((substitute-symbols-into-package (form)
- (etypecase form
- (cons (mapcar #'substitute-symbols-into-package form))
- (symbol (intern (symbol-name form)))
- (atom form))))
+ (etypecase form
+ (cons (mapcar #'substitute-symbols-into-package form))
+ (symbol (intern (symbol-name form)))
+ (atom form))))
`(let ((*package* (find-package ',package)))
,@(substitute-symbols-into-package body)))))
@@ -28,13 +28,13 @@
(defmacro acond (&rest clauses)
(when clauses
(destructuring-bind ((test &rest body) &rest left-over)
- clauses
+ clauses
`(aif ,test (progn ,@(or body `(it)))
- (acond ,@left-over)))))
+ (acond ,@left-over)))))
(defmacro awhen (test &body body)
`(aif ,test
- (progn ,@body)))
+ (progn ,@body)))
(defmacro awhile (test &body body)
`(loop for it = ,test
@@ -63,17 +63,17 @@
(defun generate-case-key (keyform &key test (transform 'identity) clauses)
(with-unique-names (xkeyform)
(flet ((apply-transform (form)
- (if (eq transform 'identity)
- form
- `(,transform ,form))))
+ (if (eq transform 'identity)
+ form
+ `(,transform ,form))))
`(let ((,xkeyform ,(apply-transform keyform)))
- (cond ,@(mapcar
- (lambda(clause)
- (list* (typecase (first clause)
- ((member t otherwise) t)
- (list `(member ,xkeyform (list ,@(mapcar #'apply-transform (first clause))) :test (function ,test)))
- (t `(,test ,xkeyform ,(apply-transform (first clause)))))
- (rest clause))) clauses))))))
+ (cond ,@(mapcar
+ (lambda(clause)
+ (list* (typecase (first clause)
+ ((member t otherwise) t)
+ (list `(member ,xkeyform (list ,@(mapcar #'apply-transform (first clause))) :test (function ,test)))
+ (t `(,test ,xkeyform ,(apply-transform (first clause)))))
+ (rest clause))) clauses))))))
(defmacro case-func (keyform func &rest clauses)
(generate-case-key keyform :test func :clauses clauses))
@@ -93,8 +93,8 @@
(defmacro ignorable-let (let-name bindings &body body)
(let ((names (mapcar 'force-first bindings)))
`(,let-name ,bindings
- (declare (ignorable ,@names))
- ,@body)))
+ (declare (ignorable ,@names))
+ ,@body)))
(defun filter-until-full (fn list max-num)
(remove-if-not fn list :count max-num))
@@ -106,11 +106,11 @@
(let ((ret-t) (ret-nil))
(dolist (var list)
(if (funcall fn var)
- (push var ret-t)
- (push var ret-nil)))
-
+ (push var ret-t)
+ (push var ret-nil)))
+
(values (nreverse ret-t)
- (nreverse ret-nil))))
+ (nreverse ret-nil))))
(defun filter-non-nil (list)
(filter #'identity list))
@@ -118,35 +118,35 @@
(defun merge-constant-arguments (args &key (process-one 'identity) join env)
(let ((joined))
(labels (
- (out (list)
- (cond
- ((or (every 'constantp list)
- (loop for x in list for exp = (macroexpand x env)
- always (constantp exp)
- collect exp into e
- finally (setf list e)))
- (eval `(,join ,@list)))
- ((rest list)
- `(read-only-load-time-value (,join ,@list)))
- (t
- `(read-only-load-time-value ,(first list)))))
- (constants ()
- (when joined
- (prog1
- (out joined)
- (setf joined nil))))
- (process-one (arg)
- (if (eq 'identity process-one)
- arg
- `(,process-one ,arg))))
- (filter-non-nil
+ (out (list)
+ (cond
+ ((or (every 'constantp list)
+ (loop for x in list for exp = (macroexpand x env)
+ always (constantp exp)
+ collect exp into e
+ finally (setf list e)))
+ (eval `(,join ,@list)))
+ ((rest list)
+ `(read-only-load-time-value (,join ,@list)))
+ (t
+ `(read-only-load-time-value ,(first list)))))
+ (constants ()
+ (when joined
+ (prog1
+ (out joined)
+ (setf joined nil))))
+ (process-one (arg)
+ (if (eq 'identity process-one)
+ arg
+ `(,process-one ,arg))))
+ (filter-non-nil
(append
- (loop for arg in args
- if (load-time-constantp arg env)
- do (appendf joined (list (process-one arg)))
- else append (append (list (constants)) (list (process-one arg)))
- and do (setf joined nil))
- (when joined (list (constants))))))))
+ (loop for arg in args
+ if (load-time-constantp arg env)
+ do (appendf joined (list (process-one arg)))
+ else append (append (list (constants)) (list (process-one arg)))
+ and do (setf joined nil))
+ (when joined (list (constants))))))))
(defun separate-declarations (declarations-and-body)
(loop for form in declarations-and-body
@@ -158,20 +158,20 @@
(defun separate-keywords (arglist)
(let ((keywords) (non-keywords))
(loop for remaining = arglist then (if (keywordp (first remaining))
- (progn
- (push (first remaining) keywords)
- (push (second remaining) keywords)
- (cddr remaining))
- (progn
- (push (first remaining) non-keywords)
- (cdr remaining)))
+ (progn
+ (push (first remaining) keywords)
+ (push (second remaining) keywords)
+ (cddr remaining))
+ (progn
+ (push (first remaining) non-keywords)
+ (cdr remaining)))
while remaining)
(values (nreverse keywords) (nreverse non-keywords))))
(defmacro signal-protect (protected &body cleanup)
(with-unique-names (c)
- `(handler-bind
- ((t (lambda(,c) (declare (ignore ,c)) ,@cleanup)))
+ `(handler-bind
+ ((t (lambda(,c) (declare (ignore ,c)) ,@cleanup)))
,protected)))
@@ -183,11 +183,11 @@
(defmacro with-preserve-specials (specials &body body)
(let ((tmps (mapcar (lambda(x)(gensym (symbol-name x))) specials)))
`(let ,(loop for s in specials
- for m in tmps
- collect `(,m (when (boundp ',s),s)))
+ for m in tmps
+ collect `(,m (when (boundp ',s),s)))
(macrolet ((with-specials-restored (&body body)
- `(let ,',(loop for s in specials
- for m in tmps
- collect `(,s ,m))
- ,@body)))
- ,@body))))
+ `(let ,',(loop for s in specials
+ for m in tmps
+ collect `(,s ,m))
+ ,@body)))
+ ,@body))))
diff --git a/src/lib/my.lisp b/src/lib/my.lisp
index fcae1be..8e56f7d 100644
--- a/src/lib/my.lisp
+++ b/src/lib/my.lisp
@@ -1,8 +1,8 @@
(in-package #:tpd2.lib)
-(defvar *my-fast-inline-declaration*
+(defvar *my-fast-inline-declaration*
(progn '(declare (optimize speed))
- #+tpd2-debug '(declare)))
+ #+tpd2-debug '(declare)))
(defgeneric copy (original))
(defgeneric assign (original copy))
@@ -21,12 +21,12 @@
; (copy-structure original))
(defmethod copy ((original array))
(let ((new
- (apply #'make-array
- (list* (array-dimensions original)
- :element-type (array-element-type original)
- :adjustable (adjustable-array-p original)
- :fill-pointer (when (array-has-fill-pointer-p original)
- (fill-pointer original))))))
+ (apply #'make-array
+ (list* (array-dimensions original)
+ :element-type (array-element-type original)
+ :adjustable (adjustable-array-p original)
+ :fill-pointer (when (array-has-fill-pointer-p original)
+ (fill-pointer original))))))
(assign original new)
new))
(defmethod copy ((original standard-object))
@@ -56,20 +56,20 @@
(defun parse-defstruct (name-and-options)
(values
(force-first name-and-options)
- (loop for x in (force-rest name-and-options)
- if (and (listp x) (eq (first x) :include))
- collect (second x))))
+ (loop for x in (force-rest name-and-options)
+ if (and (listp x) (eq (first x) :include))
+ collect (second x))))
(defun generate-defmyclass-defstruct (&key name superclasses slots conc-name predicate-sym)
`(eval-always
(defclass ,name (,@superclasses)
,(mapcar (lambda(slot-spec)
- (let ((slot-name (force-first slot-spec)))
- `(,slot-name
- :initarg ,(intern (symbol-name slot-name) :keyword)
- :initform ,(when (and (force-rest slot-spec) (not (keywordp (second slot-spec))))
- (second slot-spec))
- :accessor ,(concat-sym conc-name slot-name)))) slots))
+ (let ((slot-name (force-first slot-spec)))
+ `(,slot-name
+ :initarg ,(intern (symbol-name slot-name) :keyword)
+ :initform ,(when (and (force-rest slot-spec) (not (keywordp (second slot-spec))))
+ (second slot-spec))
+ :accessor ,(concat-sym conc-name slot-name)))) slots))
(defun ,(concat-sym-from-sym-package name 'make- name) (&rest args)
(apply #'make-instance ',name args))
(defgeneric ,predicate-sym (var))
@@ -84,7 +84,7 @@
(multiple-value-bind (name superclasses)
(parse-defstruct name-and-options)
(generate-defmyclass-defstruct
- :name name
+ :name name
:superclasses superclasses
:slots slots
:conc-name (concat-sym name '-)
@@ -94,31 +94,31 @@
(multiple-value-bind (name superclasses)
(parse-defstruct name-and-options)
`(eval-always
- (progn
- (,defstruct ,name-and-options ,@slots)
- (defmethod assign ((original ,name) (copy ,name))
- ,@(mapcar (lambda(slot)
- (let ((slot-name (force-first slot)))
- `(setf (slot-value copy ',slot-name) (copy (slot-value original ',slot-name))))) slots)
- ,@(when superclasses
- `((call-next-method)))
- copy)
- (defmethod my-auto-prefices ((class (eql (find-class ',name))))
- (cons ',name (my-auto-prefices ',superclasses)))
- (find-class ',(force-first name-and-options))))))
+ (progn
+ (,defstruct ,name-and-options ,@slots)
+ (defmethod assign ((original ,name) (copy ,name))
+ ,@(mapcar (lambda(slot)
+ (let ((slot-name (force-first slot)))
+ `(setf (slot-value copy ',slot-name) (copy (slot-value original ',slot-name))))) slots)
+ ,@(when superclasses
+ `((call-next-method)))
+ copy)
+ (defmethod my-auto-prefices ((class (eql (find-class ',name))))
+ (cons ',name (my-auto-prefices ',superclasses)))
+ (find-class ',(force-first name-and-options))))))
(defmacro defmystruct (name-and-options &rest slots)
- (generate-defstruct
- :defstruct 'defstruct
- :name-and-options name-and-options
+ (generate-defstruct
+ :defstruct 'defstruct
+ :name-and-options name-and-options
:slots slots))
(defmacro defmyclass (name-and-options &rest slots)
- (generate-defstruct
+ (generate-defstruct
:defstruct 'defmyclass-defstruct
- :name-and-options name-and-options
+ :name-and-options name-and-options
:slots slots))
-
+
(defun my-function (func prefices)
(let ((possibilities (mapcar (lambda(prefix) (concat-sym prefix '- func)) prefices)))
(or (find-if 'fboundp possibilities) (first possibilities))))
@@ -137,36 +137,36 @@
(let ((sym (its-type-sym instance)))
(when sym
(multiple-value-bind
- (type valid)
- (macroexpand-1 sym env)
- (when valid type)))))
+ (type valid)
+ (macroexpand-1 sym env)
+ (when valid type)))))
(defmacro its (func instance &rest args &environment env)
(check-type func symbol)
(let ((its-known-type (its-known-type instance env)))
(cond (its-known-type
- `(,(my-function func (my-auto-prefices its-known-type)) ,instance ,@args))
- (t
- (once-only (instance)
- `(funcall (my-function ',func (my-auto-prefices ,instance)) ,instance ,@args))))))
+ `(,(my-function func (my-auto-prefices its-known-type)) ,instance ,@args))
+ (t
+ (once-only (instance)
+ `(funcall (my-function ',func (my-auto-prefices ,instance)) ,instance ,@args))))))
(defmacro set-its (new-value func instance &rest args &environment env)
(let ((its-known-type (its-known-type instance env)))
(cond (its-known-type
- `(setf (,(my-function func (my-auto-prefices its-known-type)) ,instance ,@args) ,new-value))
- (t
- `(set-its-dynamic ,new-value ',func ,instance ,@args)))))
+ `(setf (,(my-function func (my-auto-prefices its-known-type)) ,instance ,@args) ,new-value))
+ (t
+ `(set-its-dynamic ,new-value ',func ,instance ,@args)))))
(defun set-its-dynamic (new-value func instance &rest args)
(check-type func symbol)
(eval `(setf (,(my-function func (my-auto-prefices instance)) ,instance ,@args) ',new-value)))
-(define-setf-expander its (func instance &rest args)
- ; cannot use defsetf because need to control evaluation of func argument
+(define-setf-expander its (func instance &rest args)
+ ; cannot use defsetf because need to control evaluation of func argument
; XXX maybe evaluates thing too many times . . .
(check-type func symbol)
(with-unique-names (new-value)
- (values
+ (values
nil
nil
(list new-value)
@@ -176,19 +176,19 @@
(defun my-func-name-to-symbol (class func)
(etypecase func
(symbol (my-function func (my-auto-prefices class)))
- (list
+ (list
(ecase (first func)
(quote
- (unquote-quoted-symbol func))
+ (unquote-quoted-symbol func))
(setf
- (list 'setf (my-func-name-to-symbol class (second func))))))))
+ (list 'setf (my-func-name-to-symbol class (second func))))))))
(defmacro with-shorthand-accessor ((accessor class &optional (instance class)) &body body)
(check-type class symbol)
(once-only ((instance ignorable `(type ,class)))
`(macrolet ((,accessor (func &rest args)
- `(,(my-func-name-to-symbol ',class func)
- ,',instance ,@args)))
+ `(,(my-func-name-to-symbol ',class func)
+ ,',instance ,@args)))
,@body)))
(defun structure-classp (class)
@@ -196,40 +196,40 @@
(defmacro my-defun (class func lambda-list &body body)
(flet ((my-make-def (class func args)
- (multiple-value-bind (def my-arg)
- (let ((func-sym (my-func-name-to-symbol class func)))
- (if (and (fboundp func-sym) (subtypep (type-of (fdefinition func-sym)) 'generic-function))
- (values 'defmethod `(,class ,class))
- (values 'defun class)))
- (if (and (listp func) (eq (first func) 'setf))
- (values def (list 'setf (my-func-name-to-symbol class (second func)))
- (list* (first args) my-arg (rest args)))
- (values def (my-func-name-to-symbol class func) (list* my-arg args))))))
+ (multiple-value-bind (def my-arg)
+ (let ((func-sym (my-func-name-to-symbol class func)))
+ (if (and (fboundp func-sym) (subtypep (type-of (fdefinition func-sym)) 'generic-function))
+ (values 'defmethod `(,class ,class))
+ (values 'defun class)))
+ (if (and (listp func) (eq (first func) 'setf))
+ (values def (list 'setf (my-func-name-to-symbol class (second func)))
+ (list* (first args) my-arg (rest args)))
+ (values def (my-func-name-to-symbol class func) (list* my-arg args))))))
(check-type class symbol)
(multiple-value-bind (combination-type args declarations-and-body)
- (if (keywordp lambda-list)
- (values lambda-list (first body) (rest body))
- (values nil lambda-list body))
+ (if (keywordp lambda-list)
+ (values lambda-list (first body) (rest body))
+ (values nil lambda-list body))
(multiple-value-bind (declarations-and-body inline)
- (if (equalp '(my-declare-fast-inline) (first declarations-and-body))
- (values (cons *my-fast-inline-declaration* (rest declarations-and-body)) t)
- (values declarations-and-body nil))
- (multiple-value-bind (declarations body)
- (separate-declarations declarations-and-body)
- (multiple-value-bind
- (def name lambda-list)
- (my-make-def class func args)
- `(progn
- ,(when inline `(declaim (inline ,name)))
- #+tpd2-debug (declaim (notinline ,name))
- (,def ,name ,@(force-list combination-type) ,lambda-list
- ,@declarations
- (labels ((my-call ()
- (let ((me ,class))
- (with-shorthand-accessor (my ,class me)
- ,@body))))
- (my-call)))
- )))))))
+ (if (equalp '(my-declare-fast-inline) (first declarations-and-body))
+ (values (cons *my-fast-inline-declaration* (rest declarations-and-body)) t)
+ (values declarations-and-body nil))
+ (multiple-value-bind (declarations body)
+ (separate-declarations declarations-and-body)
+ (multiple-value-bind
+ (def name lambda-list)
+ (my-make-def class func args)
+ `(progn
+ ,(when inline `(declaim (inline ,name)))
+ #+tpd2-debug (declaim (notinline ,name))
+ (,def ,name ,@(force-list combination-type) ,lambda-list
+ ,@declarations
+ (labels ((my-call ()
+ (let ((me ,class))
+ (with-shorthand-accessor (my ,class me)
+ ,@body))))
+ (my-call)))
+ )))))))
(defmacro my-call ()
"Inside a my-defun, #'my-call is the function call again"
diff --git a/src/lib/once-only.lisp b/src/lib/once-only.lisp
index 3b7bc57..a151cb7 100644
--- a/src/lib/once-only.lisp
+++ b/src/lib/once-only.lisp
@@ -12,21 +12,21 @@
;; for each invocation of once-only
(let* ((names (mapcar 'force-first names-and-decls))
- (declarations (mapcar 'force-rest names-and-decls))
- (symbols (loop for name in names collect (gensym (string name)))))
- `(let ,(loop for symbol in symbols
- for name in names
- collect `(,symbol (gensym ,(string name))))
+ (declarations (mapcar 'force-rest names-and-decls))
+ (symbols (loop for name in names collect (gensym (string name)))))
+ `(let ,(loop for symbol in symbols
+ for name in names
+ collect `(,symbol (gensym ,(string name))))
`(let ,(list ,@(loop for name in names
- for symbol in symbols
- collect `(list ,symbol ,name)))
- ,@(list
- ,@(loop for symbol in symbols for decl in declarations
- append
- (loop for d in decl
- collect ``(declare (,@,(if (listp d) d `(list `,',d)) ,,symbol)))))
- ,(let ,(loop for symbol in symbols
- for name in names
- collect `(,name ,symbol))
- ,@body)))))
+ for symbol in symbols
+ collect `(list ,symbol ,name)))
+ ,@(list
+ ,@(loop for symbol in symbols for decl in declarations
+ append
+ (loop for d in decl
+ collect ``(declare (,@,(if (listp d) d `(list `,',d)) ,,symbol)))))
+ ,(let ,(loop for symbol in symbols
+ for name in names
+ collect `(,name ,symbol))
+ ,@body)))))
diff --git a/src/lib/one-liners.lisp b/src/lib/one-liners.lisp
index f596011..7afa11d 100644
--- a/src/lib/one-liners.lisp
+++ b/src/lib/one-liners.lisp
@@ -1,7 +1,7 @@
(in-package #:tpd2.lib)
(defun unquote-quoted-symbol (func)
- (assert (eq (first func) 'quote))
+ (assert (eq (first func) 'quote))
(check-type (second func) symbol)
(second func))
@@ -28,16 +28,16 @@
(declaim (inline make-displaced-vector))
(defun make-displaced-vector (vector &key (start 0) (end (length vector)))
(multiple-value-bind
- (orig offset)
+ (orig offset)
(array-displacement vector)
(when orig
(setf vector orig)
(incf end offset)
(incf start offset))
(make-array (- end start)
- :element-type (array-element-type vector)
- :displaced-to vector
- :displaced-index-offset start)))
+ :element-type (array-element-type vector)
+ :displaced-to vector
+ :displaced-index-offset start)))
(defmacro without-call/cc (&body body)
`(locally ,@body))
@@ -45,8 +45,8 @@
(defun debug-assert-report (test-form place-values)
(format *error-output* "~&Debug assertion failed: ~S evaluated to nil.~%" test-form)
(loop for (place value) in place-values do
- (format *error-output* "~&~S = ~S of type ~A: ~A~&" place value (type-of value)
- (with-output-to-string (*standard-output*) (describe value)))))
+ (format *error-output* "~&~S = ~S of type ~A: ~A~&" place value (type-of value)
+ (with-output-to-string (*standard-output*) (describe value)))))
(defun query-new-value ()
(format *query-io* "~&Enter a new value:~%")
@@ -62,37 +62,37 @@
(with-unique-names (block val)
(let ((gensyms (loop for place in places collect (gensym (force-string place)))))
`(without-call/cc
- (unless ,test-form
- (loop do
- (locally
- (declare (optimize debug safety (speed 0)))
- (flet ((,block () ;; use flet to get better debug on SBCL
- (let ,(loop for p in places for g in gensyms collect `(,g ,p))
- (restart-case (error ,(or datum (format nil "The debug assertion ~S failed." test-form)) ,@arguments)
- (continue ()
- :report "Print a description of the debug assertion and continue."
- (debug-assert-report
- ',test-form
- (list
- ,@(loop for place in places
- for g in gensyms collect
- `(list ',place ,g))))
- (return 'debug-assert-skip))
- ,@(loop for place in places
- for g in gensyms collect
- `(store-value (,val)
- :interactive query-new-value
- :report (lambda (stream) (format stream "The current value of ~S is ~S; supply a new value for it." ',place ,g))
- (setf ,place ,val)))
- (debug-assert-retry ()
- :report "Retry the assertion."
- (return-from ,block))
- (debug-assert-skip ()
- :report "Accept that the assertion will fail this time and continue without printing anything."
- (return 'debug-assert-skip))))))
- (,block)))
- until ,test-form))
- (values)))))
+ (unless ,test-form
+ (loop do
+ (locally
+ (declare (optimize debug safety (speed 0)))
+ (flet ((,block () ;; use flet to get better debug on SBCL
+ (let ,(loop for p in places for g in gensyms collect `(,g ,p))
+ (restart-case (error ,(or datum (format nil "The debug assertion ~S failed." test-form)) ,@arguments)
+ (continue ()
+ :report "Print a description of the debug assertion and continue."
+ (debug-assert-report
+ ',test-form
+ (list
+ ,@(loop for place in places
+ for g in gensyms collect
+ `(list ',place ,g))))
+ (return 'debug-assert-skip))
+ ,@(loop for place in places
+ for g in gensyms collect
+ `(store-value (,val)
+ :interactive query-new-value
+ :report (lambda (stream) (format stream "The current value of ~S is ~S; supply a new value for it." ',place ,g))
+ (setf ,place ,val)))
+ (debug-assert-retry ()
+ :report "Retry the assertion."
+ (return-from ,block))
+ (debug-assert-skip ()
+ :report "Accept that the assertion will fail this time and continue without printing anything."
+ (return 'debug-assert-skip))))))
+ (,block)))
+ until ,test-form))
+ (values)))))
(defmacro debug-unreachable ()
`(debug-assert (not 'reached-here)))
diff --git a/src/lib/quick-queue.lisp b/src/lib/quick-queue.lisp
index 35bfa40..a6fe191 100644
--- a/src/lib/quick-queue.lisp
+++ b/src/lib/quick-queue.lisp
@@ -11,13 +11,13 @@
me)
(defstruct quick-queue
- (entries
+ (entries
(let ((len (* 16 1024)))
- (copy-seq (map '(vector quick-queue-entry) 'identity
- (loop for i below len collect
- (let ((entry (make-quick-queue-entry)))
- (quick-queue-entry-init entry)
- entry)))))
+ (copy-seq (map '(vector quick-queue-entry) 'identity
+ (loop for i below len collect
+ (let ((entry (make-quick-queue-entry)))
+ (quick-queue-entry-init entry)
+ entry)))))
:type (simple-array quick-queue-entry)))
@@ -43,4 +43,3 @@
(setf (quick-queue-entry-prev (my next)) (my prev))
(setf (my prev) me (my next) me))
-
\ No newline at end of file
diff --git a/src/lib/strcat.lisp b/src/lib/strcat.lisp
index 6524831..c224086 100644
--- a/src/lib/strcat.lisp
+++ b/src/lib/strcat.lisp
@@ -8,45 +8,45 @@
(define-compiler-macro strcat (&rest original-args &environment env)
(let ((args (merge-constant-arguments original-args :join 'strcat-go :process-one 'force-string :env env)))
(if (not (rest args))
- (first args)
- (with-unique-names (len result i)
- (let ((argnames (loop for i from 0 below (length args)
- collect (gensym (format nil "arg-~D-" i)))))
- `(let ,(loop for arg in args
- for argname in argnames
- collect `(,argname ,arg))
- (declare (optimize speed (safety 0)))
- (declare (type string ,@argnames))
- (let ((,len (the fixnum (+ ,@(loop for argname in argnames collect `(the fixnum (length ,argname)))))))
- (let ((,result (make-string ,len)) (,i 0))
- (declare (type fixnum ,i) (type string ,result))
- ,@(loop for argname in argnames
- collect `(replace ,result ,argname :start1 ,i)
- collect `(incf ,i (length ,argname)))
- (the string ,result)))))))))
+ (first args)
+ (with-unique-names (len result i)
+ (let ((argnames (loop for i from 0 below (length args)
+ collect (gensym (format nil "arg-~D-" i)))))
+ `(let ,(loop for arg in args
+ for argname in argnames
+ collect `(,argname ,arg))
+ (declare (optimize speed (safety 0)))
+ (declare (type string ,@argnames))
+ (let ((,len (the fixnum (+ ,@(loop for argname in argnames collect `(the fixnum (length ,argname)))))))
+ (let ((,result (make-string ,len)) (,i 0))
+ (declare (type fixnum ,i) (type string ,result))
+ ,@(loop for argname in argnames
+ collect `(replace ,result ,argname :start1 ,i)
+ collect `(incf ,i (length ,argname)))
+ (the string ,result)))))))))
;;; Maybe rewrite using replace; NO on SBCL it is slower (why !?)
;;; XXX are the fixnums at all necessary
(define-compiler-macro strcat (&rest original-args)
(let ((args (merge-constant-arguments original-args :join 'strcat-go :process-one 'force-string)))
(if (not (rest args))
- (first args)
- (with-unique-names (len result i c)
- (let ((argnames (loop for i from 0 below (length args)
- collect (gensym (format nil "arg-~D-" i)))))
- `(let ,(loop for arg in args
- for argname in argnames
- collect `(,argname ,arg))
- (declare (optimize speed (safety 0)))
- (declare (type simple-string ,@argnames))
- (let ((,len (the fixnum (+ ,@(loop for argname in argnames collect `(the fixnum (length ,argname)))))))
- (let ((,result (make-string ,len))
- (,i 0))
- ,@(loop for arg in argnames collect
- `(loop for ,c across ,arg do
- (setf (char ,result ,i) ,c)
- (incf ,i)))
- (the string ,result)))))))))
+ (first args)
+ (with-unique-names (len result i c)
+ (let ((argnames (loop for i from 0 below (length args)
+ collect (gensym (format nil "arg-~D-" i)))))
+ `(let ,(loop for arg in args
+ for argname in argnames
+ collect `(,argname ,arg))
+ (declare (optimize speed (safety 0)))
+ (declare (type simple-string ,@argnames))
+ (let ((,len (the fixnum (+ ,@(loop for argname in argnames collect `(the fixnum (length ,argname)))))))
+ (let ((,result (make-string ,len))
+ (,i 0))
+ ,@(loop for arg in argnames collect
+ `(loop for ,c across ,arg do
+ (setf (char ,result ,i) ,c)
+ (incf ,i)))
+ (the string ,result)))))))))
(declaim (ftype (function (&rest t) string) strcat))
(defun-speedy strcat (&rest args)
diff --git a/src/lib/superquote.lisp b/src/lib/superquote.lisp
index 6920cca..e7f7019 100644
--- a/src/lib/superquote.lisp
+++ b/src/lib/superquote.lisp
@@ -11,13 +11,13 @@
(defun superquote-function-go (form)
(typecase form
(list (case (first form)
- (unquote-splice (second form))
- (unquote (second form))
- (t `(append ,@(loop for f in form
- if (eq (first (force-list f)) 'unquote-splice)
- collect (second f)
- else
- collect `(list ,(superquote-function-go f)))))))
+ (unquote-splice (second form))
+ (unquote (second form))
+ (t `(append ,@(loop for f in form
+ if (eq (first (force-list f)) 'unquote-splice)
+ collect (second f)
+ else
+ collect `(list ,(superquote-function-go f)))))))
(t `',form)))
(defun superquote-function (form)
@@ -26,8 +26,8 @@
(defun superquote-form-constantp (form env)
(typecase form
(list (case (first form)
- ((unquote-splice unquote) (load-time-constantp (second form) env))
- (t (every (lambda(form) (superquote-form-constantp form env)) form))))
+ ((unquote-splice unquote) (load-time-constantp (second form) env))
+ (t (every (lambda(form) (superquote-form-constantp form env)) form))))
(t t)))
(defmacro superquote (form &environment env)
diff --git a/src/lib/timeout.lisp b/src/lib/timeout.lisp
index 26dd12a..3fa0694 100644
--- a/src/lib/timeout.lisp
+++ b/src/lib/timeout.lisp
@@ -23,7 +23,7 @@
(defun forget-timeouts ()
(setf *timeout-started* nil
- *timeouts* (make-quick-queue)))
+ *timeouts* (make-quick-queue)))
(my-defun timeout remaining ()
(max (- (my time) (get-timeout-time)) 0))
@@ -53,11 +53,11 @@
(my-defun timeout reset (delay)
(my-declare-fast-inline)
- (cond (delay
- (setf (my time) (time-for-delay delay))
- (my merge))
- (t
- (my cancel))))
+ (cond (delay
+ (setf (my time) (time-for-delay delay))
+ (my merge))
+ (t
+ (my cancel))))
(my-defun timeout set (delay &optional func)
(my-declare-fast-inline)
@@ -73,51 +73,51 @@
(defun describe-timeouts ()
(let ((start (or *timeout-started* (- (get-timeout-time) (/ (max-timeout-period) 2)))) (count 0) (earliest nil) (latest nil) (biggest-stack-count 0) biggest-stack-time)
(loop for x from start below (+ start (max-timeout-period))
- do
- (let ((base (quick-queue-get *timeouts* x)) (stack-count 0))
- (loop for cur = (quick-queue-entry-next base) then (quick-queue-entry-next cur)
- while (not (eq cur base))
- do (incf count)
- (incf stack-count)
- (debug-assert (= (timeout-time cur) x) (cur x (timeout-time cur) start))
- (unless earliest (setf earliest cur))
- (unless latest (setf latest cur))
- (when (> (timeout-time cur) (timeout-time latest))
- (setf latest cur))
- (when (< (timeout-time cur) (timeout-time earliest))
- (setf earliest cur)))
- (when (> stack-count biggest-stack-count)
- (setf biggest-stack-count stack-count
- biggest-stack-time x))))
+ do
+ (let ((base (quick-queue-get *timeouts* x)) (stack-count 0))
+ (loop for cur = (quick-queue-entry-next base) then (quick-queue-entry-next cur)
+ while (not (eq cur base))
+ do (incf count)
+ (incf stack-count)
+ (debug-assert (= (timeout-time cur) x) (cur x (timeout-time cur) start))
+ (unless earliest (setf earliest cur))
+ (unless latest (setf latest cur))
+ (when (> (timeout-time cur) (timeout-time latest))
+ (setf latest cur))
+ (when (< (timeout-time cur) (timeout-time earliest))
+ (setf earliest cur)))
+ (when (> stack-count biggest-stack-count)
+ (setf biggest-stack-count stack-count
+ biggest-stack-time x))))
(format t "~&Now ~Ds; ~D timeout~:P active.~%" (get-timeout-time) count)
(when biggest-stack-time
(format t "~&The largest concentration is of ~D timeout~:P in ~Ds.~&" biggest-stack-count (- biggest-stack-time (get-timeout-time)))
(format t "~&The next timeout is in ~Ds: ~A~&" (- (timeout-time earliest) (get-timeout-time)) earliest)
(describe earliest)
(unless (eq latest earliest)
- (format t "~&The last timeout is in ~Ds: ~A~&" (- (timeout-time latest) (get-timeout-time)) latest)
- (describe latest)))))
+ (format t "~&The last timeout is in ~Ds: ~A~&" (- (timeout-time latest) (get-timeout-time)) latest)
+ (describe latest)))))
(defun next-timeout (&optional (now (get-timeout-time)))
(loop for x from (or *timeout-started* (- now (/ (max-timeout-period) 2))) upto now do
- (let ((base (quick-queue-get *timeouts* x)))
- (loop for cur = (quick-queue-entry-next base)
- while (not (eq cur base))
- do
- (debug-assert (= (timeout-time cur) x) (cur x now (timeout-time cur) *timeout-started*))
- (timeout-run cur))))
+ (let ((base (quick-queue-get *timeouts* x)))
+ (loop for cur = (quick-queue-entry-next base)
+ while (not (eq cur base))
+ do
+ (debug-assert (= (timeout-time cur) x) (cur x now (timeout-time cur) *timeout-started*))
+ (timeout-run cur))))
(setf *timeout-started* nil)
; (describe-timeouts)
(loop for x from now below (+ now (max-timeout-period))
- thereis
- (let ((base (quick-queue-get *timeouts* x)))
- (let ((timeout (quick-queue-entry-next base)))
- (when (not (eq base timeout))
- (debug-assert (= (timeout-time timeout) x) (timeout x (timeout-time timeout) now))
- (setf *timeout-started* now)
- (- x now))))))
+ thereis
+ (let ((base (quick-queue-get *timeouts* x)))
+ (let ((timeout (quick-queue-entry-next base)))
+ (when (not (eq base timeout))
+ (debug-assert (= (timeout-time timeout) x) (timeout x (timeout-time timeout) now))
+ (setf *timeout-started* now)
+ (- x now))))))
(defmacro with-independent-timeouts (() &body body)
`(let (*timeout-started*
- (*timeouts* (make-quick-queue)))
+ (*timeouts* (make-quick-queue)))
,@body))
diff --git a/src/lib/utils.lisp b/src/lib/utils.lisp
index 2ce21f0..dc21c52 100644
--- a/src/lib/utils.lisp
+++ b/src/lib/utils.lisp
@@ -8,12 +8,12 @@
(let ((vecs (mapcar (lambda(x)(force-simple-byte-vector x)) args)))
(let ((len (reduce '+ (mapcar (lambda(x)(length (the simple-byte-vector x))) vecs))))
(let ((ret (make-byte-vector len)) (i 0))
- (loop for v in vecs do
- (locally
- (declare (type simple-byte-vector ret v) (type (integer 0 #. most-positive-fixnum) i))
- (replace ret v :start1 i)
- (incf i (length v))))
- ret))))
+ (loop for v in vecs do
+ (locally
+ (declare (type simple-byte-vector ret v) (type (integer 0 #. most-positive-fixnum) i))
+ (replace ret v :start1 i)
+ (incf i (length v))))
+ ret))))
#-ccl ; compacting gc makes this unreliable
(ignore-errors
@@ -22,8 +22,8 @@
(setf q p))
(with-pointer-to-vector-data (p0 v)
(with-pointer-to-vector-data (p1 v)
- (when (and (cffi:pointer-eq p0 p1) (cffi:pointer-eq p0 q))
- (pushnew :tpd2-byte-vectors-do-not-move-arbitrarily *features*))))))
+ (when (and (cffi:pointer-eq p0 p1) (cffi:pointer-eq p0 q))
+ (pushnew :tpd2-byte-vectors-do-not-move-arbitrarily *features*))))))
(defun max-nil-ok (&rest args)
(let (one)
@@ -35,11 +35,11 @@
(defun random-shuffle (sequence)
(loop while (plusp (length sequence))
- collect
- (let ((i (random (length sequence))))
- (prog1
- (elt sequence i)
- (setf sequence (remove-if (lambda(x) (declare (ignore x)) t) sequence :start i :count 1))))))
+ collect
+ (let ((i (random (length sequence))))
+ (prog1
+ (elt sequence i)
+ (setf sequence (remove-if (lambda(x) (declare (ignore x)) t) sequence :start i :count 1))))))
(declaim (inline random-elt))
(defun random-elt (sequence)
@@ -55,10 +55,10 @@
(with-input-from-string (*standard-input* (force-string string)) (read-safely)))
(defun report-error (err &key (stream *error-output*))
- (format stream "~&ERROR ~A, ~A:~%~A~&"
- (ignore-errors (princ-to-string err))
- (with-output-to-string (*standard-output*) (describe err))
- (trivial-backtrace:backtrace-string)))
+ (format stream "~&ERROR ~A, ~A:~%~A~&"
+ (ignore-errors (princ-to-string err))
+ (with-output-to-string (*standard-output*) (describe err))
+ (trivial-backtrace:backtrace-string)))
(defun backtrace-description (err)
(report-error err :stream nil))
@@ -67,35 +67,35 @@
(with-unique-names (safe func)
`(block ,safe
(flet ((,func (e)
- (,report-function e)
- (return-from ,safe (values nil e))))
- (declare (dynamic-extent #',func))
- (handler-bind
- ((error #',func))
- ,@body)))))
+ (,report-function e)
+ (return-from ,safe (values nil e))))
+ (declare (dynamic-extent #',func))
+ (handler-bind
+ ((error #',func))
+ ,@body)))))
(defun safely-load-system (&key (system 'teepeedee2))
(let* ((out (make-string-output-stream))
- (in (make-string-input-stream ""))
- (both (make-two-way-stream in out)))
+ (in (make-string-input-stream ""))
+ (both (make-two-way-stream in out)))
(let ((*standard-output* out)
- (*error-output* out)
- (*trace-output* out)
- (*standard-input* in)
- (*query-io* both)
- (*debug-io* both)
- (*terminal-io* both))
- (multiple-value-call #'values
- (ignore-errors
- (handler-bind
- ((error
- (lambda(c)
- (report-error c)
- (loop for restart in '(asdf:accept continue)
- for found = (find-restart restart)
- do (when found
- (format *error-output* "~&Using restart ~A~%" restart)
- (invoke-restart found))))))
- (values (asdf:oos 'asdf:load-op system) nil)))
- (get-output-stream-string out)))))
+ (*error-output* out)
+ (*trace-output* out)
+ (*standard-input* in)
+ (*query-io* both)
+ (*debug-io* both)
+ (*terminal-io* both))
+ (multiple-value-call #'values
+ (ignore-errors
+ (handler-bind
+ ((error
+ (lambda(c)
+ (report-error c)
+ (loop for restart in '(asdf:accept continue)
+ for found = (find-restart restart)
+ do (when found
+ (format *error-output* "~&Using restart ~A~%" restart)
+ (invoke-restart found))))))
+ (values (asdf:oos 'asdf:load-op system) nil)))
+ (get-output-stream-string out)))))
diff --git a/src/ml/css.lisp b/src/ml/css.lisp
index cf740c1..418f9c4 100644
--- a/src/ml/css.lisp
+++ b/src/ml/css.lisp
@@ -3,175 +3,175 @@
; From http://www.w3.org/TR/REC-CSS2/propidx.html
; if you want more just use "strings"
(defvar *css-properties* '(
- :azimuth
- :background
- :background-color
- :background-image
- :background-repeat
- :background-attachment
- :background-position
- :background-attachment
- :background-color
- :background-image
- :background-position
- :background-repeat
- :border
- :border-width
- :border-style
- :border-collapse
- :border-color
- :border-spacing
- :border-style
- :border-top
- :border-right
- :border-bottom
- :border-left
- :border-top-width
- :border-style
- :border-top-color
- :border-right-color
- :border-bottom-color
- :border-left-color
- :border-top-style
- :border-right-style
- :border-bottom-style
- :border-left-style
- :border-top-width
- :border-right-width
- :border-bottom-width
- :border-left-width
- :border-width
- :bottom
- :caption-side
- :clear
- :clip
- :color
- :content
- :counter-increment
- :counter-reset
- :cue
- :cue-before
- :cue-after
- :cursor
- :direction
- :display
- :elevation
- :empty-cells
- :float
- :font
- :font-style
- :font-variant
- :font-weight
- :font-size
- :font-family
- :font-family
- :font-size
- :font-size-adjust
- :font-stretch
- :font-style
- :font-variant
- :font-weight
- :height
- :left
- :letter-spacing
- :line-height
- :list-style
- :list-style-type
- :list-style-position
- :list-style-image
- :list-style-position
- :list-style-type
- :margin
- :margin-top
- :margin-right
- :margin-bottom
- :margin-left
- :marker-offset
- :marks
- :max-height
- :max-width
- :min-height
- :min-width
- :orphans
- :outline
- :outline-color
- :outline-style
- :outline-color
- :outline-style
- :outline-width
- :overflow
- :padding
- :padding-top
- :padding-right
- :padding-bottom
- :padding-left
- :page
- :page-break-after
- :page-break-before
- :page-break-inside
- :pause
- :pause-after
- :pause-before
- :pitch
- :pitch-range
- :play-during
- :position
- :quotes
- :richness
- :right
- :size
- :speak
- :speak-header
- :speak-numeral
- :speak-punctuation
- :speech-rate
- :stress
- :table-layout
- :text-align
- :text-decoration
- :text-indent
- :text-shadow
- :text-transform
- :top
- :unicode-bidi
- :vertical-align
- :visibility
- :voice-family
- :volume
- :white-space
- :widows
- :width
- :word-spacing
- :z-index
-
- :x-opacity
- :x-column-width
- :x-column-gap
- :x-border-radius))
+ :azimuth
+ :background
+ :background-color
+ :background-image
+ :background-repeat
+ :background-attachment
+ :background-position
+ :background-attachment
+ :background-color
+ :background-image
+ :background-position
+ :background-repeat
+ :border
+ :border-width
+ :border-style
+ :border-collapse
+ :border-color
+ :border-spacing
+ :border-style
+ :border-top
+ :border-right
+ :border-bottom
+ :border-left
+ :border-top-width
+ :border-style
+ :border-top-color
+ :border-right-color
+ :border-bottom-color
+ :border-left-color
+ :border-top-style
+ :border-right-style
+ :border-bottom-style
+ :border-left-style
+ :border-top-width
+ :border-right-width
+ :border-bottom-width
+ :border-left-width
+ :border-width
+ :bottom
+ :caption-side
+ :clear
+ :clip
+ :color
+ :content
+ :counter-increment
+ :counter-reset
+ :cue
+ :cue-before
+ :cue-after
+ :cursor
+ :direction
+ :display
+ :elevation
+ :empty-cells
+ :float
+ :font
+ :font-style
+ :font-variant
+ :font-weight
+ :font-size
+ :font-family
+ :font-family
+ :font-size
+ :font-size-adjust
+ :font-stretch
+ :font-style
+ :font-variant
+ :font-weight
+ :height
+ :left
+ :letter-spacing
+ :line-height
+ :list-style
+ :list-style-type
+ :list-style-position
+ :list-style-image
+ :list-style-position
+ :list-style-type
+ :margin
+ :margin-top
+ :margin-right
+ :margin-bottom
+ :margin-left
+ :marker-offset
+ :marks
+ :max-height
+ :max-width
+ :min-height
+ :min-width
+ :orphans
+ :outline
+ :outline-color
+ :outline-style
+ :outline-color
+ :outline-style
+ :outline-width
+ :overflow
+ :padding
+ :padding-top
+ :padding-right
+ :padding-bottom
+ :padding-left
+ :page
+ :page-break-after
+ :page-break-before
+ :page-break-inside
+ :pause
+ :pause-after
+ :pause-before
+ :pitch
+ :pitch-range
+ :play-during
+ :position
+ :quotes
+ :richness
+ :right
+ :size
+ :speak
+ :speak-header
+ :speak-numeral
+ :speak-punctuation
+ :speech-rate
+ :stress
+ :table-layout
+ :text-align
+ :text-decoration
+ :text-indent
+ :text-shadow
+ :text-transform
+ :top
+ :unicode-bidi
+ :vertical-align
+ :visibility
+ :voice-family
+ :volume
+ :white-space
+ :widows
+ :width
+ :word-spacing
+ :z-index
+
+ :x-opacity
+ :x-column-width
+ :x-column-gap
+ :x-border-radius))
;; Write CSS like this: (("p.asdfsaf" "p + p") :property "value" :property "value")
(defun validate-properties (properties)
(loop for (property) on properties by #'cddr
- when (keywordp property) do
- (assert (member property *css-properties*) (property))))
+ when (keywordp property) do
+ (assert (member property *css-properties*) (property))))
(defun css-output-properties (properties)
(append (list " {")
- (css-output-properties-form properties)
- (list "}" #\Newline)))
+ (css-output-properties-form properties)
+ (list "}" #\Newline)))
(defgeneric css-output-selector-form (selector properties))
(defmethod css-output-selector-form ((str string) properties)
(append (list str)
- (css-output-properties properties)))
+ (css-output-properties properties)))
(defun css-selector-form-to-string (form)
(cond ((symbolp form)
- (assert (and (eql #\< (char (symbol-name form) 0)) (fboundp form)) (form) "Misspelled? ~A" form)
- (subseq (symbol-name form) 1))
- (t form)))
+ (assert (and (eql #\< (char (symbol-name form) 0)) (fboundp form)) (form) "Misspelled? ~A" form)
+ (subseq (symbol-name form) 1))
+ (t form)))
(defmethod css-output-selector-form ((sym symbol) properties)
(css-output-selector-form (css-selector-form-to-string sym) properties))
@@ -184,13 +184,13 @@
(css-output-properties properties)))
(:possibly-unsupported-selectors
(loop for form in (rest l)
- append (css-output-selector-form form properties)))
+ append (css-output-selector-form form properties)))
(t
(append
(loop for once = t then nil
- for form in l
- unless once collect ","
- collect (css-selector-form-to-string form))
+ for form in l
+ unless once collect ","
+ collect (css-selector-form-to-string form))
(css-output-properties properties)))))
(defgeneric css-output-property-form (property value))
@@ -199,18 +199,18 @@
(loop for v in (force-list value) for once = t then nil unless once collect " " collect v))
(defmethod css-output-property-form (property value)
- (list* (if (keywordp property)
- (string-downcase (symbol-name property))
- property)
- ": "
- (css-output-property-value-form value)))
+ (list* (if (keywordp property)
+ (string-downcase (symbol-name property))
+ property)
+ ": "
+ (css-output-property-value-form value)))
(defun css-output-property-under-different-names (names value)
- (loop for p in names
- for once = nil then t
- append
- (css-output-property-form p value)
- unless once collect ";"))
+ (loop for p in names
+ for once = nil then t
+ append
+ (css-output-property-form p value)
+ unless once collect ";"))
(defmethod css-output-property-form ((property (eql :x-opacity)) value)
(check-type value (real 0 1))
@@ -235,20 +235,20 @@
(defmacro css-html-style (&body selector-properties)
(flet ((validate (selector properties)
- (declare (ignore selector))
- (validate-properties properties)))
+ (declare (ignore selector))
+ (validate-properties properties)))
`(tpd2.ml.html: