From 9b41e003151333453abd0a4a4ff1f499297eaad1 Mon Sep 17 00:00:00 2001 From: William Halliburton Date: Wed, 16 Feb 2011 07:54:40 -0500 Subject: [PATCH] Remove tabs and trailing whitespace. Try these in your .emacs: (setq whitespace-style '(tabs trailing)) (add-hook 'lisp-mode-hook 'whitespace-mode) (defun untabify-buffer () (untabify (point-min) (point-max))) (add-hook 'write-file-hooks 'untabify-buffer) (add-hook 'write-file-hooks 'delete-trailing-whitespace) --- src/blog/blog.lisp | 260 +- src/blog/entry.lisp | 170 +- src/blog/feed.lisp | 62 +- src/datastore/datastore.lisp | 216 +- src/game/card.lisp | 22 +- src/game/coins.lisp | 42 +- src/game/controllers.lisp | 8 +- src/game/framework.lisp | 132 +- src/game/generic.lisp | 4 +- src/game/unassigned-controller.lisp | 26 +- src/game/web-messages.lisp | 92 +- src/game/web.lisp | 364 +-- src/http/dispatcher.lisp | 118 +- src/http/encoding.lisp | 16 +- src/http/headers.lisp | 30 +- src/http/request.lisp | 210 +- src/http/serve.lisp | 256 +- src/http/servestate.lisp | 38 +- src/io/con.lisp | 142 +- src/io/epoll.lisp | 72 +- src/io/mux.lisp | 22 +- src/io/openssl.lisp | 2 +- src/io/posix-socket.lisp | 112 +- src/io/protocol.lisp | 84 +- src/io/recvbuf.lisp | 62 +- src/io/repeater.lisp | 20 +- src/io/sendbuf.lisp | 140 +- src/io/ssl.lisp | 54 +- src/io/syscalls.lisp | 250 +- src/lib/byte-vector.lisp | 134 +- src/lib/callcc.lisp | 36 +- src/lib/macros.lisp | 136 +- src/lib/my.lisp | 170 +- src/lib/once-only.lisp | 32 +- src/lib/one-liners.lisp | 76 +- src/lib/quick-queue.lisp | 13 +- src/lib/strcat.lisp | 66 +- src/lib/superquote.lisp | 18 +- src/lib/timeout.lisp | 76 +- src/lib/utils.lisp | 88 +- src/ml/css.lisp | 356 +-- src/ml/define-dtd.lisp | 122 +- src/ml/js.lisp | 16 +- src/ml/output.lisp | 40 +- src/ml/rss.lisp | 2 +- src/packages.lisp | 86 +- src/small-games/nash-bargain.lisp | 50 +- src/small-games/prisoners-dilemma.lisp | 63 +- src/small-games/roshambo.lisp | 34 +- src/small-games/ultimatum.lisp | 26 +- src/survey/survey.lisp | 60 +- src/truc/robots.lisp | 84 +- src/truc/truc.lisp | 128 +- src/truc/web.lisp | 58 +- src/webapp/actions.lisp | 166 +- src/webapp/channel.lisp | 112 +- src/webapp/frame.lisp | 2 +- src/webapp/js-library.lisp | 292 +- src/webapp/list-channel.lisp | 4 +- src/webapp/message-channel.lisp | 20 +- src/webapp/names.lisp | 3960 ++++++++++++------------ src/webapp/page.lisp | 100 +- src/webapp/simple-channel.lisp | 10 +- src/webapp/site.lisp | 72 +- src/webapp/webapp.lisp | 98 +- t/http.lisp | 110 +- t/io.lisp | 94 +- t/regex.lisp | 72 +- 68 files changed, 5053 insertions(+), 5055 deletions(-) diff --git a/src/blog/blog.lisp b/src/blog/blog.lisp index 7c3ab3b..492698e 100644 --- a/src/blog/blog.lisp +++ b/src/blog/blog.lisp @@ -27,35 +27,35 @@ (my-defun blog read-in () (with-site ((my site)) (let ((old-entries (or (my entries-table) (make-hash-table :test 'equalp)))) - (setf + (setf (my entries-table) (make-hash-table :test 'equalp) - (my entries) + (my entries) (sort - (iter:iter (iter:for path in (cl-fad:list-directory (my dir))) - (let ((filename (force-string path))) - (unless (or (find #\# filename) (find #\~ filename)) - (let ((entry (read-in-entry me (file-namestring filename)))) - (iter:collect entry))))) - #'> :key #'entry-time)) + (iter:iter (iter:for path in (cl-fad:list-directory (my dir))) + (let ((filename (force-string path))) + (unless (or (find #\# filename) (find #\~ filename)) + (let ((entry (read-in-entry me (file-namestring filename)))) + (iter:collect entry))))) + #'> :key #'entry-time)) (loop for entry in (my entries) - for old = (gethash (entry-index-name entry) old-entries) - do - (if old - (setf (entry-score entry) (entry-score old) - (entry-score-update-time entry) (entry-score-update-time old)) - (entry-set-score entry)) - (setf (gethash (entry-index-name entry) (my entries-table)) entry)) + for old = (gethash (entry-index-name entry) old-entries) + do + (if old + (setf (entry-score entry) (entry-score old) + (entry-score-update-time entry) (entry-score-update-time old)) + (entry-set-score entry)) + (setf (gethash (entry-index-name entry) (my entries-table)) entry)) (my set-page))) me) (defun split-into-list-by-comma (str) (match-split (progn (* (space)) "," (* (space))) - str)) + str)) (my-defun blog ready-entries (&key (age (get-universal-time)) tags) (loop for e in (my entries) - when (and (entry-front-page-p e tags) (<= (entry-time e) age)) - collect e)) + when (and (entry-front-page-p e tags) (<= (entry-time e) age)) + collect e)) (my-defun blog url (name) (byte-vector-cat (my link-base) name)) @@ -78,97 +78,97 @@ (with-ml-output ( :key #'comment-time) - do (
:key #'comment-time) + do (
:key #'entry-score))) - (
= now (my time)) - (or (not (my expiry-time)) (>= (my expiry-time) now)) - - (or (not tags) - (intersection (my tags) tags :test #'equalp))))) + (or (not (my expiry-time)) (>= (my expiry-time) now)) + + (or (not tags) + (intersection (my tags) tags :test #'equalp))))) (my-defun entry url-path () (byte-vector-cat (its link-base (my blog)) (my name))) @@ -102,63 +102,63 @@ (my-defun entry story-ml () (
") (tpd2.ml.atom:") (tpd2.ml.rss:= i max-returned)) - do (incf i (length v)) - append v))) - - (defmethod datastore-record-constructor-form ((object ,name)) - (list ',(guarded-constructor) - ,@(loop for slot-def in slot-defs - for slot-name = (slot-name slot-def) - unless (eq 'datastore-id slot-name) - collect (intern (symbol-name slot-name) :keyword) - and - collect `(datastore-save-form (,(real-slot-accessor slot-name) object))))) - - - ,@(loop for slot-def in indexed-slots collect - `(defmethod datastore-retrieve-indexed ((class (eql ',name)) (index (eql ',(slot-name slot-def))) value) - (datastore-index-get ,(slot-index slot-def) value))) - - ',name))))) + `(progn + (defstruct (,name + (:constructor ,(real-constructor)) + (:conc-name ,(concat-sym-from-sym-package name 'unlogged- name '-))) + ,@defstruct-slot-defs) + + ;;; Constructor + + (defun ,(guarded-constructor) + (&key ,@(loop for slot-def in slot-defs + collect `(,(slot-name slot-def) ,(slot-prop slot-def :initform)))) + (let ((,constructed-object (,(real-constructor)))) + (datastore-id-register datastore-id) + ,(when persistent? + `(datastore-log `(,',(guarded-constructor) :datastore-id ,datastore-id))) + ,@(loop for slot-def in slot-defs + for slot-name = (slot-name slot-def) + collect `(setf (,(guarded-slot-accessor slot-name) ,constructed-object) ,slot-name)) + + ,constructed-object)) + + ,@(loop for slot-def in indexed-slots + collect `(unless ,(slot-index slot-def) + (setf ,(slot-index slot-def) (make-datastore-index :slot-name ',(slot-name slot-def))))) + + ;;; Guarded accessors + + ,@(loop for slot-def in slot-defs + for slot-name = (slot-name slot-def) + collect + `(defun ,(guarded-slot-accessor slot-name) (,name) + (,(real-slot-accessor slot-name) ,name)) + collect + `(defun (setf ,(guarded-slot-accessor slot-name)) (new-value ,name) + ,(when (slot-indexed slot-def) + `(datastore-index-del ,(slot-index slot-def) ,name)) + (multiple-value-prog1 + (setf (,(real-slot-accessor slot-name) ,name) new-value) + ,(when (slot-indexed slot-def) + `(datastore-index-add ,(slot-index slot-def) ,name)) + ,(when (slot-persistent slot-def) + `(datastore-log + `(setf (,',(guarded-slot-accessor slot-name) ,(datastore-ref-form ,name)) ,(datastore-save-form new-value))))))) + + (defmethod datastore-delete ((object ,name)) + ,(when persistent? + `(when (slot-value object 'datastore-id) + (datastore-log `(datastore-delete ,(datastore-ref-form object))))) + ,@(loop for slot-def in indexed-slots collect + `(datastore-index-del ,(slot-index slot-def) object)) + (setf (slot-value object 'datastore-id) nil)) + (defmethod datastore-retrieve-all ((class (eql ',name)) &optional max-returned) + (let ((i 0)) + (loop for v being the hash-values of (datastore-index-table ,(slot-index 'datastore-id)) + until (and max-returned (>= i max-returned)) + do (incf i (length v)) + append v))) + + (defmethod datastore-record-constructor-form ((object ,name)) + (list ',(guarded-constructor) + ,@(loop for slot-def in slot-defs + for slot-name = (slot-name slot-def) + unless (eq 'datastore-id slot-name) + collect (intern (symbol-name slot-name) :keyword) + and + collect `(datastore-save-form (,(real-slot-accessor slot-name) object))))) + + + ,@(loop for slot-def in indexed-slots collect + `(defmethod datastore-retrieve-indexed ((class (eql ',name)) (index (eql ',(slot-name slot-def))) value) + (datastore-index-get ,(slot-index slot-def) value))) + + ',name))))) diff --git a/src/game/card.lisp b/src/game/card.lisp index df40d35..3059549 100644 --- a/src/game/card.lisp +++ b/src/game/card.lisp @@ -4,7 +4,7 @@ (define-constant +suits+ '(:clubs :hearts :spades :diamonds) :test 'equal) (defconstant +cards-per-suit+ 13)) -(defstruct card +(defstruct card (suit :clubs :type #.`(member ,@+suits+)) (value 0 :type (integer 0 #.+cards-per-suit+))) @@ -18,15 +18,15 @@ (my-defun card name () (format nil "~A of ~A" - (my value-string) - (string-capitalize (symbol-name (my suit))))) + (my value-string) + (string-capitalize (symbol-name (my suit))))) (my-defun card number () (+ (* (position (my suit) +suits+) +cards-per-suit+) (my value))) (defun make-card-from-number (number) (multiple-value-bind - (s-n v) + (s-n v) (floor number +cards-per-suit+) (make-card :suit (elt +suits+ s-n) :value v))) @@ -34,10 +34,10 @@ ( ." tpd2.webapp:+html-class-scroll-to-bottom+) - :overflow "auto" + ('(strcat ".messages-and-talk > ." tpd2.webapp:+html-class-scroll-to-bottom+) + :overflow "auto" :padding-right "0.5em" :height "20em" ) (".play-game-description,.about" @@ -286,7 +286,7 @@ (".game-header" :float "left") (".close-game:before" :content "\"+ \"") - (".players" + (".players" :float "right" :margin-top "2em" ) @@ -301,23 +301,23 @@ (

ul > li" :padding-bottom "1em") (".webapp-section > ul > li a.-replace-link-" :font-size "2em") - (".separate" + (".separate" :height "4em" :border-right "2px solid black") (".talk input[type=\"text\"]" :width "60%") - (("input[type=submit]" ") ", 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: