Improving contracts on web lang

svn: r12322

collects/tests/web-server/lang/abort-resume-test.ss

@@ -74,21 +74,21 @@
      (check-equal? (abort/cc
                     (lambda () 
                       (let/ec esc
-                        ('f1 (with-continuation-mark the-cont-key 'f1
+                        ('f1 (with-continuation-mark the-cont-key +
                                (esc (activation-record-list)))))))
-                   (list (vector 'f1 #f))))
+                   (list (vector + #f))))
     
     (test-case
      "Double"
      (check-equal? (abort/cc
                     (lambda () 
                       (let/ec esc
-                        ('f1 (with-continuation-mark the-cont-key 'f1
-                               ('f2 (with-continuation-mark the-cont-key 'f2
+                        ('f1 (with-continuation-mark the-cont-key +
+                               ('f2 (with-continuation-mark the-cont-key -
                                       (esc (activation-record-list)))))))))
                    ; Opposite the order of c-c-m
-                   (list (vector 'f1 #f)
-                         (vector 'f2 #f))))
+                   (list (vector + #f)
+                         (vector - #f))))
     
     (test-case
      "Unsafe"

collects/web-server/lang/abort-resume.ss

@@ -1,30 +1,7 @@
-#lang scheme/base
-(require mzlib/list
-         mzlib/plt-match
-         mzlib/serialize
+#lang scheme
+(require scheme/serialize
          "../private/define-closure.ss"
          "../lang/web-cells.ss")
-; XXX contract
-(provide
- 
- ;; AUXILLIARIES
- abort
- abort/cc
- resume
- the-cont-key
- the-save-cm-key
- safe-call?
- the-undef
- activation-record-list
- current-saved-continuation-marks-and
- kont-append-fun
- 
- ;; "SERVLET" INTERFACE
- send/suspend
- 
- ;; "CLIENT" INTERFACE
- dispatch-start
- dispatch)
 
 ;; **********************************************************************
 ;; **********************************************************************
@@ -33,7 +10,7 @@
 (define the-cont-key (make-mark-key))
 (define the-save-cm-key (make-mark-key))
 (define safe-call? (make-mark-key))
-(define web-prompt (make-continuation-prompt-tag 'web)) 
+(define web-prompt (make-continuation-prompt-tag 'web)) 
 
 (define (current-saved-continuation-marks-and key val)
   (define c
@@ -62,7 +39,7 @@
 ;; erase the stack and apply a thunk
 (define (abort thunk)
   #;(printf "abort ~S~n" thunk)
-  (abort-current-continuation web-prompt thunk))
+  (abort-current-continuation web-prompt thunk))
 
 ;; with-continuation-marks : (listof (cons any1 any2)) (-> any3) -> any3
 (define (with-continuation-marks cms thnk)
@@ -172,3 +149,43 @@
         => (lambda (k) (k req))]
        [else
         (error 'dispatch "no continuation associated with the provided request: ~S" req)]))))
+
+;; **********************************************************************
+;; **********************************************************************
+
+; These should really be from web-server/private, but it interferes with testing
+(define request? any/c)
+(define response? any/c)
+
+(define cms? (and/c hash? immutable?))
+
+(define saved-context?
+  (listof (vector/c (or/c false/c procedure?)
+                    (or/c false/c cms?))))
+
+(provide/contract
+ ;; AUXILLIARIES
+ [abort ((-> any) . -> . any)]
+ [abort/cc ((-> any) . -> . any)]
+ [resume (saved-context? any/c . -> . any)]
+ [the-cont-key mark-key?]
+ [the-save-cm-key mark-key?]
+ [safe-call? mark-key?]
+ [the-undef undef?]
+ [activation-record-list (-> saved-context?)]
+ [current-saved-continuation-marks-and (any/c any/c . -> . cms?)]
+ [kont-append-fun (kont? procedure? . -> . kont?)]
+
+ ;; "CLIENT" INTERFACE
+ [dispatch ((request? . -> . (request? . -> . response?))
+            request?
+            . -> .
+            response?)]
+ [dispatch-start ((request? . -> . response?)
+                  request?
+                  . -> .
+                  response?)])
+(provide
+ ;; "SERVLET" INTERFACE
+ ; A contract would interfere with the safe-call? key
+ send/suspend)

collects/web-server/lang/defun.ss

@@ -100,22 +100,7 @@
                 empty)]
        [id (identifier? #'id)
            (values stx
-                   empty)]
-       ; XXX Shouldn't
-       [(letrec-syntaxes+values ([(sv ...) se] ...)
-          ([(vv ...) ve] ...)
-          be ...)
-        (let-values ([(nses se-defs) (defun* (syntax->list #'(se ...)))]
-                     [(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
-                     [(nbes be-defs) (defun* (syntax->list #'(be ...)))])
-          (with-syntax ([(nse ...) nses]
-                        [(nve ...) nves]
-                        [(nbe ...) nbes])
-            (values (syntax/loc stx 
-                      (letrec-syntaxes+values ([(sv ...) nse] ...)
-                        ([(vv ...) nve] ...)
-                        nbe ...))
-                    (append se-defs ve-defs be-defs))))]
+                   empty)]       
        [(#%expression d)
         (let-values ([(nd d-defs) (defun #'d)])
           (values (quasisyntax/loc stx (#%expression #,nd))

collects/web-server/lang/elim-callcc.ss

@@ -163,12 +163,7 @@
     [(#%variable-reference . v)
      stx]       
     [id (identifier? #'id)
-        stx]
-    ; XXX Shouldn't
-    [(letrec-syntaxes+values ([(sv ...) se] ...)
-       ([(vv ...) ve] ...)
-       be ...)
-     (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
+        stx]    
     [(#%expression d)
      (markit (quasisyntax/loc stx (#%expression #,(elim-callcc #'d))))]
     [_