From 5880441b02218ca7ee65f33f2a81ce194d6558b8 Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Fri, 10 Jan 2003 09:57:41 +0000
Subject: [PATCH] Add implementation of NAME->STATUS-CODE. Tag export of
 STATUS-CODE as :SYNTAX.

---
 scheme/httpd/response.scm | 12 ++++++++++++
 scheme/packages.scm       |  4 +++-
 2 files changed, 15 insertions(+), 1 deletion(-)

diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm
index 88d622f..8519d5a 100644
--- a/scheme/httpd/response.scm
+++ b/scheme/httpd/response.scm
@@ -77,6 +77,18 @@
    (gateway-timeout	504 "Gateway Timeout")
   
    (redirect             -301 "Internal redirect")))
+
+(define (name->status-code name)
+  (if (not (symbol? name))
+      (call-error name->status-code (list name))
+      (let loop ((i 0))
+	(cond ((= i (vector-length status-codes))
+	       #f)
+	      ((eq? name
+		    (status-code-name (vector-ref status-codes i)))
+	       (vector-ref status-codes i))
+	      (else
+	       (loop (+ i 1)))))))
 	
 ;;; (make-error-response status-code req [message . extras])
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/scheme/packages.scm b/scheme/packages.scm
index 0daf7cc..062d862 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -281,7 +281,8 @@
 	  status-code?
 	  status-code-number
 	  status-code-message
-	  status-code
+	  (status-code :syntax)
+	  name->status-code
 
 	  make-error-response
 	  make-redirect-response
@@ -618,6 +619,7 @@
 	define-record-types
 	finite-types
 	formats
+	(subset signals (call-error))
 	httpd-requests
 	httpd-read-options)
   (files (httpd response)))