|
103 | 103 | (push value (,(concat-sym 'servestate- f '*))))))))) |
104 | 104 | (declare (dynamic-extent #'handle-header)) |
105 | 105 | (let ((pos 0)) |
106 | | - (declare (type (integer 0 100000) pos) |
| 106 | + (declare (type fixnum pos) |
107 | 107 | (type simple-byte-vector headers)) |
108 | | - (macrolet ( |
109 | | - (e (&optional (d 0)) |
110 | | - `(locally (declare (optimize (safety 0))) (aref headers (+ pos ,d)))) |
111 | | - (u (&rest chars) |
112 | | - (with-unique-names (s) |
113 | | - `(let ((,s pos)) |
114 | | - (loop until (m ,@chars) do (incf pos)) |
115 | | - (subseq headers ,s pos)))) |
116 | | - (m (&rest chars) |
117 | | - `(let ((e (e))) (declare (type (unsigned-byte 8) e)) (or ,@(loop for c in chars collect `(= e ,(char-code c)))))) |
118 | | - (w (&rest chars) |
119 | | - `(loop while (m ,@chars) do (incf pos))) |
120 | | - (s (string) |
121 | | - `(progn |
122 | | - ,@(loop for c across string |
123 | | - for i from 0 collect |
124 | | - `(assert (= (e ,i) ,(char-code c)))) |
125 | | - (incf pos ,(length string)))) |
126 | | - (i () ;; XXX hack |
127 | | - `(multiple-value-prog1 |
128 | | - (- (e) (char-code #\0)) |
129 | | - (incf pos))) |
130 | | - (ulws () |
131 | | - `(multiple-value-prog1 (u #\Space #\Tab) (lws))) |
132 | | - |
133 | | - (lws () `(w #\Space #\Tab)) |
134 | | - (assert-eol () |
135 | | - `(progn (incf pos) (assert (= ,(char-code #\Newline) (e))) (incf pos))) |
136 | | - (line () |
137 | | - `(multiple-value-prog1 (u #\Return) (assert-eol)))) |
138 | | - |
139 | | - (let ((version-major 0) (version-minor 9)) |
140 | | - (setf (servestate-method*) (ulws)) |
141 | | - |
142 | | - (match-request-url (ulws)) |
143 | | - |
144 | | - (cond ((= (e) (char-code #\Return))) |
145 | | - (t |
146 | | - (s "HTTP/") |
147 | | - (setf version-major (i)) |
148 | | - (s ".") |
149 | | - (setf version-minor (i)) |
150 | | - (lws) |
151 | | - (assert-eol))) |
152 | | - (setf (servestate-connection-close*) |
153 | | - (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor))))) |
154 | | - (loop until (= (e) (char-code #\Return)) |
155 | | - do (cond ((m #\Space #\Tab)) |
156 | | - (t |
157 | | - (let ((header-name (u #\:))) |
158 | | - (incf pos) |
159 | | - (lws) |
160 | | - (handle-header header-name (line)))))) |
161 | | - (assert-eol) |
162 | | - |
163 | | - (http-serve-process-body con done *servestate*))))))) |
| 108 | + (labels ((incf-pos () |
| 109 | + (assert (< pos most-positive-fixnum)) |
| 110 | + (incf pos) |
| 111 | + (assert (< pos (length headers))) |
| 112 | + )) |
| 113 | + (macrolet ( |
| 114 | + (e (&optional (d 0)) |
| 115 | + `(locally (declare (optimize (safety 0))) (aref headers (+ pos ,d)))) |
| 116 | + (u (&rest chars) |
| 117 | + (with-unique-names (s) |
| 118 | + `(let ((,s pos)) |
| 119 | + (loop until (m ,@chars) do (incf-pos)) |
| 120 | + (subseq headers ,s pos)))) |
| 121 | + (m (&rest chars) |
| 122 | + `(let ((e (e))) (declare (type (unsigned-byte 8) e)) (or ,@(loop for c in chars collect `(= e ,(char-code c)))))) |
| 123 | + (w (&rest chars) |
| 124 | + `(loop while (m ,@chars) do (incf-pos))) |
| 125 | + (s (string) |
| 126 | + `(progn |
| 127 | + ,@(loop for c across string |
| 128 | + for i from 0 collect |
| 129 | + `(assert (= (e ,i) ,(char-code c)))) |
| 130 | + (incf pos ,(length string)))) |
| 131 | + (i () ;; XXX hack |
| 132 | + `(multiple-value-prog1 |
| 133 | + (- (e) (char-code #\0)) |
| 134 | + (incf pos))) |
| 135 | + (ulws () |
| 136 | + `(multiple-value-prog1 (u #\Space #\Tab) (lws))) |
| 137 | + |
| 138 | + (lws () `(w #\Space #\Tab)) |
| 139 | + (assert-eol () |
| 140 | + `(progn (incf pos) (assert (= ,(char-code #\Newline) (e))) (incf pos))) |
| 141 | + (line () |
| 142 | + `(multiple-value-prog1 (u #\Return) (assert-eol)))) |
| 143 | + |
| 144 | + (let ((version-major 0) (version-minor 9)) |
| 145 | + (setf (servestate-method*) (ulws)) |
| 146 | + |
| 147 | + (match-request-url (ulws)) |
| 148 | + |
| 149 | + (cond ((= (e) (char-code #\Return))) |
| 150 | + (t |
| 151 | + (s "HTTP/") |
| 152 | + (setf version-major (i)) |
| 153 | + (s ".") |
| 154 | + (setf version-minor (i)) |
| 155 | + (lws) |
| 156 | + (assert-eol))) |
| 157 | + (setf (servestate-connection-close*) |
| 158 | + (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor))))) |
| 159 | + (loop until (= (e) (char-code #\Return)) |
| 160 | + do (cond ((m #\Space #\Tab)) |
| 161 | + (t |
| 162 | + (let ((header-name (u #\:))) |
| 163 | + (incf pos) |
| 164 | + (lws) |
| 165 | + (handle-header header-name (line)))))) |
| 166 | + (assert-eol) |
| 167 | + |
| 168 | + (http-serve-process-body con done *servestate*)))))))) |
164 | 169 |
|
165 | 170 | (defprotocol http-serve-process-body (con servestate) |
166 | 171 | (unless (zerop (servestate-content-length servestate)) |
|
0 commit comments