+ feature: return-addresses; lets servlets give more than one possible

address for the next step
+ plain-html: leaves given text untouched, like quote in scheme
              don't call it quote, because it is too similar to the
	      HTML's tag <q> (that stands for 'quote')
This commit is contained in:
interp 2002-10-02 20:28:39 +00:00
parent 61896c1238
commit 20ff8816a9
2 changed files with 39 additions and 3 deletions

View File

@ -158,6 +158,9 @@
make-image-button
input-field-value
input-field-binding
make-address
returned-via?
make-callback))
(define-structure servlets servlets-interface

View File

@ -149,12 +149,18 @@
maybe-text
URI)"</a>"))))
(define plain-html-rule
`(plain-html
*preorder*
. ,(lambda (tag . text) text)))
(define default-rules
`(,attribute-rule
(*default*
. ,(lambda (tag . elems) (apply (entag tag) elems)))
,text-rule
,URL-rule))
,URL-rule
,plain-html-rule))
(define (make-callback function)
(call-with-current-continuation
@ -214,11 +220,12 @@
(input-field-name input-field))))
;; FIXME: consider creating small names
(define generate-input-field-name
(define generate-unique-name
(let ((id 0))
(lambda (type-string)
(set! id (+ 1 id))
(string-append type-string (number->string id)))))
(define generate-input-field-name generate-unique-name)
(define identity (lambda (a) a))
@ -486,4 +493,30 @@
(assoc (input-field-name input-field) bindings))
(define (input-field-binding input-field bindings)
(real-input-field-binding (cadr input-field) bindings))
(real-input-field-binding (cadr input-field) bindings))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; return address
;; generates an unique return-addres
;; may be used like
;; (let ((address (make-address)))
;; (send-html/suspend
;; (lambda (new-url)
;; ...
;; (URL (address new-url) "Click here to get more")...)
(define (make-address)
(let ((name (generate-unique-name "return")))
(lambda (message)
(cond
((string? message)
(string-append message "?" name "="))
((eq? message 'name)
name)
(else ;maybe we want more later...
(error "unknown message" message name))))))
(define (returned-via? return-address bindings)
(assoc (return-address 'name) bindings))