@@ -333,7 +333,7 @@
(push :tpd2-has-swank *features*)
nil)
-#+start-tpd2 (progn
+(progn
(let ((socket (tpd2.io:make-con-listen :port 8888)))
(tpd2.io:launch-io 'tpd2.io:accept-forever socket 'tpd2.http::http-serve))
@@ -346,5 +346,5 @@
(tpd2.io:event-loop)))
:name "MOPOKO-EVENT-LOOP")))
-(defpage "/test" ()
- (<p "hello"))
\ No newline at end of file
+(defpage "/test" (name)
+ (<p "hello " (<b name)))
\ No newline at end of file
src/game/web.lisp
@@ -30,7 +30,7 @@
(f
(funcall f me con done path params))
(t
- (format *error-output* "LOST ~A~&" (strcat (my canonical-name) "/" path))
+ ;(format *error-output* "LOST ~A~&" (strcat (my canonical-name) "/" path))
(respond-http con done :code 404 :banner "Not found"
:body (funcall (my error-responder) me path params))))
(error (e)
src/http/dispatcher.lisp
@@ -1,5 +1,16 @@
(in-package #:tpd2.http)
+(defun match-int (value)
+ (match-bind ((len (integer))) value
+ len))
+(defun match-each-word (value func)
+ (match-bind ( (+ word (or (+ (space)) (last))
+ '(funcall func word)))
+ value))
+
+(declaim (inline match-int))
+(declaim (inline match-each-word))
+
(defprotocol process-headers (con process-header-func)
(let ((last-header-name))
(loop for line = (io 'recvline con)
src/http/headers.lisp
@@ -29,27 +29,28 @@
(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 (lambda(name value)
- (when (length value)
- (case-match-fold-ascii-case name
- ("content-length"
- (match-bind ((len (integer))) value
- (setf content-length len)))
- ("connection"
- (match-bind ( (+ word (or (+ (space)) (last))
- '(case-match-fold-ascii-case word
- ("close" (setf connection-close t))
- ("keep-alive" (setf connection-close nil))) ))
- value))
- ("transfer-encoding"
- (match-bind ( (+ word (or (+ (space)) (last))
- '(case-match-fold-ascii-case word
- ("chunked" (setf chunked t))
- ("gzip" (setf gzip t)))))
- value))))))
+ (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
src/http/request.lisp
@@ -15,21 +15,19 @@
(let ((request-content-length 0)
host
(connection-close (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor))))))
- (flet ((process-header (name value)
- (when (length value)
- (case-match-fold-ascii-case name
- ("content-length"
- (match-bind ((len (integer))) value
- (setf request-content-length len)))
- ("host"
- (setf host value))
- ("connection"
- (match-bind ( (+ word (or (+ (space)) (last))
- '(case-match-fold-ascii-case word
- ("close" (setf connection-close t))
- ("keep-alive" (setf connection-close nil))) ))
- value))))))
- (io 'process-headers con #'process-header))
+ (io 'process-headers con (without-call/cc (lambda(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-each-word value
+ (lambda(word)
+ (case-match-fold-ascii-case word
+ ("close" (setf connection-close t))
+ ("keep-alive" (setf connection-close nil))) ))))))))
(let ((request-body
(unless (zerop request-content-length)
(io 'recv con request-content-length))))
src/http/serve.lisp
@@ -1,20 +1,5 @@
(in-package #:tpd2.lib)
-(eval-always
- (defun make-byte-vector (len)
- (declare (optimize speed))
- (declare (type (unsigned-byte *) len))
- (make-array len :element-type '(unsigned-byte 8))))
-
-(declaim (inline make-byte-vector))
-
-(deftype byte-vector (&optional (len '*))
- `(vector (unsigned-byte 8) ,len))
-(deftype simple-byte-vector (&optional (len '*))
- `(simple-array (unsigned-byte 8) (,len)))
-
-(declaim (ftype (function ((unsigned-byte *)) simple-byte-vector) make-byte-vector))
-
(defmacro with-pointer-to-vector-data ((ptr lisp-vector) &body body)
(check-symbols ptr)
(once-only (lisp-vector)
@@ -68,7 +53,6 @@
(declaim (ftype (function ( (unsigned-byte 8)) (integer -1 36)) byte-to-digit-consistent-internal))
-
(defun byte-vector-parse-integer (string &optional (base 10))
(declare (optimize speed))
(declare (type byte-vector string))
src/lib/byte-vector.lisp
@@ -19,14 +19,15 @@
,@(loop for n in names collect
`(cl-cont-pass-through-one-construct ,n))))
-
-(cl-cont-pass-through-constructs
- handler-case
- handler-bind
- restart-case
- restart-bind
-
- cl-irregsexp::with-match)
+(eval-always
+ (cl-cont-pass-through-constructs
+ handler-case
+ handler-bind
+ restart-case
+ restart-bind
+
+ without-call/cc
+ cl-irregsexp::with-match))
#+extra-bugs-please
(defmacro cl-cont:call/cc (cc)
src/lib/callcc.lisp
@@ -71,16 +71,17 @@
,result-form))
(defun generate-case-key (keyform &key test (transform 'identity) clauses)
- (once-only (keyform)
+ (with-unique-names (xkeyform)
(flet ((apply-transform (form)
`(,transform ,form)))
- `(cond ,@(mapcar
- (lambda(clause)
- (list* (typecase (first clause)
- ((member t otherwise) t)
- (list `(member ,keyform (list ,(mapcar #'apply-transform (first clause))) :test (function ,test)))
- (t `(funcall (function ,test) ,keyform ,(apply-transform (first clause)))))
- (rest clause))) clauses)))))
+ `(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 `(funcall (function ,test) ,xkeyform ,(apply-transform (first clause)))))
+ (rest clause))) clauses))))))
(defmacro case-func (keyform func &rest clauses)
(generate-case-key keyform :test func :clauses clauses))
src/lib/macros.lisp
@@ -1,19 +1,23 @@
(in-package #:tpd2.lib)
-(defun utf8-char-length (code)
- (cond ((> #x80 code) 1)
- ((> #x800 code) 2)
- ((> #x10000 code) 3)
- (t 4)))
+(defun utf8-char-length (char)
+ (declare (type character char))
+ (let ((code (char-code char)))
+ (cond ((> #x80 code) 1)
+ ((> #x800 code) 2)
+ ((> #x10000 code) 3)
+ (t 4))))
(declaim (inline utf8-char-length))
+(declaim (ftype (function (character) (integer 1 4)) utf8-char-length))
(defun utf8-encode-really (string)
(declare (optimize speed))
(declare (type simple-string string))
(let ((dest-len
- (loop for c across string summing (utf8-char-length (char-code c)))) )
+ (loop for c across string summing (utf8-char-length c))))
(let ((vec (make-byte-vector dest-len)))
(let ((i 0))
+ (declare (type fixnum i))
(flet ((out (val)
(setf (aref vec i) val)
(incf i)))
src/lib/utf8.lisp
@@ -1,66 +1,5 @@
(in-package #:tpd2.lib)
-(def-if-unbound defun-consistent utf8-decode (vec)
- (map 'string 'code-char vec))
-
-(def-if-unbound defun-consistent utf8-encode (string)
- (map 'byte-vector 'char-code string))
-
-(defun-consistent byte-vector-to-simple-byte-vector (val)
- (declare (optimize speed (safety 0)))
- (declare (type (and byte-vector (not simple-byte-vector)) val))
- (let ((ret (make-byte-vector (length val))))
- (replace ret val)
- ret))
-
-(declaim (ftype (function ((and byte-vector (not simple-byte-vector))) simple-byte-vector) byte-vector-to-simple-byte-vector-consistent-internal))
-
-(defun-consistent force-string (val)
- (declare (optimize speed (safety 0)))
- (let ((str
- (the string
- (typecase val
- (null "")
- (symbol (symbol-name val))
- (string val)
- (simple-byte-vector (utf8-decode val))
- (byte-vector (utf8-decode (byte-vector-to-simple-byte-vector val)))
- (t (let ((*print-pretty* nil)) (princ-to-string val)))))))
- (etypecase str
- (simple-string str)
- (string
- (locally
- (declare (type (and string (not simple-string)) str))
- (replace (make-string (length str)) str))))))
-
-(declaim (ftype (function (t) simple-string) force-string-consistent-internal))
-
-
-(defun-consistent force-byte-vector (val)
- (declare (optimize speed (safety 0)))
- (typecase val
- (null #.(make-byte-vector 0))
- (simple-string (utf8-encode val))
- (string (utf8-encode val))
- (character (utf8-encode (string val)))
- (byte-vector val)
- (sequence (map 'byte-vector 'identity val))
- (t (utf8-encode (force-string val)))))
-
-(declaim (ftype (function (t) byte-vector) force-byte-vector-consistent-internal))
-
-(defun-consistent force-simple-byte-vector (val)
- (declare (optimize speed (safety 0)))
- (let ((val (force-byte-vector val)))
- (etypecase val
- (simple-byte-vector val)
- (byte-vector
- (byte-vector-to-simple-byte-vector val)))))
-
-(declaim (ftype (function (t) simple-byte-vector) force-simple-byte-vector-consistent-internal))
-
-(defun-consistent byte-vector-to-string (vec)
- (utf8-decode (force-simple-byte-vector vec)))
(defun byte-vector-cat (&rest args)
(declare (optimize speed))
src/lib/utils.lisp
@@ -7,7 +7,7 @@
(raw-ml-sendbuf
value)
(t
- (macrolet ((f (x) `(force-byte-vector ,x)))
+ (macrolet ((f (x) `(force-simple-byte-vector ,x)))
(match-replace-all (f value)
(#\< (f "<"))
(#\> (f ">"))
src/ml/output.lisp
@@ -4,7 +4,7 @@
(defpackage #:teepeedee2.lib
(:nicknames #:tpd2.lib)
- (:use #:common-lisp #:iter)
+ (:use #:common-lisp #:iter #:cl-irregsexp-bytestrings)
(:import-from #:cl-utilities #:with-unique-names)
(:import-from #:trivial-garbage #:finalize #:cancel-finalization)
(:import-from #:cl-cont #:call/cc #:with-call/cc)
src/packages.lisp
@@ -38,13 +38,12 @@
(:file "macros" :depends-on ("once-only" "one-liners"))
(:file "once-only")
(:file "one-liners")
- (:file "utils" :depends-on ("utf8"))
- (:file "utf8" :depends-on ("macros" "byte-vector"))
+ (:file "utils" :depends-on ("macros" "byte-vector"))
(:file "superquote" :depends-on ("utils"))
(:file "strcat" :depends-on ("macros" "utils"))
(:file "my" :depends-on ("macros" "once-only" "strcat" "one-liners"))
(:file "byte-vector" :depends-on ("macros"))
- (:file "callcc")
+ (:file "callcc" :depends-on ("macros"))
(:file "quick-queue" :depends-on ("utils" "my"))
(:file "timeout" :depends-on ("quick-queue"))))
@@ -114,7 +113,6 @@
:components (
(:file "suite")
(:file "io" :depends-on ("suite"))
- (:file "utf8" :depends-on ("suite"))
(:file "http" :depends-on ("suite"))
)))
:depends-on (
teepeedee2.asd
t/utf8.lisp
90026a5f1407824303c3aeacabb9b3314fa7aa87
John Fremlin
john@fremlin.org
http://github.com/vii/teepeedee2/commit/7c1074b767425f45efebcda02cd027bbb0b649de
7c1074b767425f45efebcda02cd027bbb0b649de
2008-10-12T23:18:27-07:00
2008-10-12T23:18:27-07:00
working on sbcl again
c2cd3ffb3aa7419c0a03bc235f451ef73c1ea97b
John Fremlin
john@fremlin.org