Skip to content

Commit

Permalink
working on sbcl again
Browse files Browse the repository at this point in the history
  • Loading branch information
@vii
vii committed Oct 13, 2008
1 parent 90026a5 commit 7c1074b
Show file tree
Hide file tree
Showing 14 changed files with 79 additions and 197 deletions.
6 changes: 3 additions & 3 deletions src/game/web.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))

Expand All @@ -346,5 +346,5 @@
(tpd2.io:event-loop)))
:name "MOPOKO-EVENT-LOOP")))

(defpage "/test" ()
(<p "hello"))
(defpage "/test" (name)
(<p "hello " (<b name)))
2 changes: 1 addition & 1 deletion src/http/dispatcher.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
11 changes: 11 additions & 0 deletions src/http/headers.lisp
View file
Original file line number Diff line number Diff line change
@@ -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)
Expand Down
37 changes: 19 additions & 18 deletions src/http/request.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
28 changes: 13 additions & 15 deletions src/http/serve.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))))
Expand Down
16 changes: 0 additions & 16 deletions src/lib/byte-vector.lisp
View file
Original file line number Diff line number Diff line change
@@ -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)
Expand Down Expand Up @@ -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))
Expand Down
17 changes: 9 additions & 8 deletions src/lib/callcc.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
17 changes: 9 additions & 8 deletions src/lib/macros.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down
16 changes: 10 additions & 6 deletions src/lib/utf8.lisp
View file
Original file line number Diff line number Diff line change
@@ -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)))
Expand Down
61 changes: 0 additions & 61 deletions src/lib/utils.lisp
View file
Original file line number Diff line number Diff line change
@@ -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))
Expand Down
2 changes: 1 addition & 1 deletion src/ml/output.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 "&lt;"))
(#\> (f "&gt;"))
Expand Down
2 changes: 1 addition & 1 deletion src/packages.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
55 changes: 0 additions & 55 deletions t/utf8.lisp
View file

This file was deleted.

Loading

0 comments on commit 7c1074b

Please sign in to comment.