suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adding serial-lambda and changing how defun works

Browse Source 
svn: r15243
This commit is contained in:
Jay McCarthy 2009-06-23 16:09:22 +00:00
parent cc32f3eea2
commit 22384487e8
10 changed files with 281 additions and 315 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/web-server/lang.ss
View File

@ -18,10 +18,10 @@
(define-syntax lang-module-begin
(make-lang-module-begin
make-labeling
(make-module-case/new-defs
(make-define-case/new-defs
(make-module-case
(make-define-case
(lambda (stx)
(define anf-stx (anormalize stx))
(define no-callcc-stx (elim-callcc anf-stx))
(define-values (defun-stx new-defs) (defun no-callcc-stx))
(values defun-stx new-defs))))))
(define defun-stx (defun no-callcc-stx))
defun-stx)))))

118
collects/web-server/lang/closure.ss Normal file
View File

@ -0,0 +1,118 @@
#lang scheme
(require syntax/free-vars
(for-template
scheme/base
scheme/serialize))
(define (define-closure! label fvars stx)
; Boxes
(define make-CLOSURE-box
(syntax-local-lift-expression
(quasisyntax/loc stx
(box (lambda (env) (error 'make-CLOSURE "Closure<~e> not initialized" '#,label))))))
(define CLOSURE-set-env!-box
(syntax-local-lift-expression
(quasisyntax/loc stx
(box (lambda (clsr new-env) (error 'CLOSURE-set-env! "Closure<~e> not initialized" '#,label))))))
(define CLOSURE-env-box
(syntax-local-lift-expression
(quasisyntax/loc stx
(box (lambda (clsr) (error 'CLOSURE-env "Closure<~e> not initialized" '#,label))))))
; Define the deserializer (req closure struct values under lambdas)
(define CLOSURE:deserialize-info-id
(syntax-local-lift-expression
(quasisyntax/loc stx
(make-deserialize-info
;; make-proc: value ... -> CLOSURE
(lambda args
(apply (#%plain-lambda #,fvars
((unbox #,make-CLOSURE-box) (#%plain-lambda () (values #,@fvars))))
args))
;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void))
(lambda ()
(let ([new-closure
((unbox #,make-CLOSURE-box)
(#%plain-lambda () (error 'deserialize "closure not initialized")))])
(values
new-closure
(#%plain-lambda (clsr)
((unbox #,CLOSURE-set-env!-box) new-closure ((unbox #,CLOSURE-env-box) clsr))))))))))
; Define the serializer (req closure struct values + deserializer identifier)
(define CLOSURE:serialize-info-id
(syntax-local-lift-expression
(quasisyntax/loc stx
(make-serialize-info
;; to-vector: CLOSURE -> vector
(#%plain-lambda (clsr)
(#%plain-app call-with-values
(#%plain-lambda () (((unbox #,CLOSURE-env-box) clsr)))
vector))
;; The serializer id: --------------------
(quote-syntax #,CLOSURE:deserialize-info-id)
;; can-cycle?
#t
;; Directory for last-ditch resolution --------------------
(or (current-load-relative-directory) (current-directory))))))
; Define the closure struct (req serialize info value)
(define-values
(make-CLOSURE-id CLOSURE?-id CLOSURE-env-id CLOSURE-set-env!-id)
(apply
values
(syntax-local-lift-values-expression
4
(quasisyntax/loc stx
(letrec-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!)
(make-struct-type
'#,label ;; the tag goes here
#f ; no super type
1
0 ; number of auto-fields
#f ; auto-v
; prop-vals:
(list (cons prop:serializable #,CLOSURE:serialize-info-id)
(cons prop:procedure
(#%plain-lambda (clsr . args)
(let-values ([#,fvars ((CLOSURE-ref clsr 0))])
(apply #,stx args)))))
#f ; inspector
;; the struct apply proc:
#f)]
[(CLOSURE-env)
(#%plain-lambda (clsr) (CLOSURE-ref clsr 0))]
[(CLOSURE-set-env!)
(#%plain-lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env))])
(set-box! #,CLOSURE-env-box CLOSURE-env)
(set-box! #,CLOSURE-set-env!-box CLOSURE-set-env!)
(set-box! #,make-CLOSURE-box make-CLOSURE)
(values make-CLOSURE CLOSURE? CLOSURE-env CLOSURE-set-env!))))))
; Provide the deserializer (req deserializer identifier)
(syntax-local-lift-provide
(quasisyntax/loc stx
#,CLOSURE:deserialize-info-id))
(values make-CLOSURE-id CLOSURE?-id CLOSURE-env-id))
(define (make-closure stx)
(syntax-case stx ()
[(_ label lambda-stx)
(let*-values
([(lambda-fe-stx) (local-expand #'lambda-stx 'expression empty)]
[(fvars) (free-vars lambda-fe-stx)]
; Define the closure struct (req serialize info value)
[(make-CLOSURE-id CLOSURE?-id CLOSURE-env-id)
(define-closure! #'label fvars lambda-fe-stx)])
; Instantiate the closure
(quasisyntax/loc stx
(#,make-CLOSURE-id (#%plain-lambda () (values #,@fvars)))))]))
(provide
make-closure
define-closure!)

180
collects/web-server/lang/defun.ss
View File

@ -1,14 +1,12 @@
#lang scheme/base
(require (for-template scheme/base)
syntax/kerncase
syntax/free-vars
scheme/contract
mzlib/list
mzlib/plt-match
"util.ss"
"../private/closure.ss")
web-server/lang/closure
(for-template web-server/lang/serial-lambda)
"util.ss")
(provide/contract
[defun (syntax? . -> . (values syntax? (listof syntax?)))])
[defun (syntax? . -> . syntax?)])
; make-new-clouse-label : (syntax -> syntax) syntax -> syntax
(define (make-new-closure-label labeling stx)
@ -17,111 +15,79 @@
; defun : syntax[1] -> (values syntax?[2] (listof syntax?)[3])
; defunctionalizes the first syntax, returning the second and the lifted lambdas [3]
(define (defun stx)
(recertify/new-defs
(recertify
stx
(lambda ()
(kernel-syntax-case
stx (transformer?)
[(begin be ...)
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
(values (quasisyntax/loc stx (begin #,@nbes))
defs))]
[(begin0 be ...)
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
(values (quasisyntax/loc stx (begin0 #,@nbes))
defs))]
[(set! v ve)
(let-values ([(nve defs) (defun #'ve)])
(values (quasisyntax/loc stx (set! v #,nve))
defs))]
[(let-values ([(v ...) ve] ...) be ...)
(let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
(with-syntax ([(nve ...) nves]
[(nbe ...) nbes])
(values (syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...))
(append ve-defs be-defs))))]
[(letrec-values ([(v ...) ve] ...) be ...)
(let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
(with-syntax ([(nve ...) nves]
[(nbe ...) nbes])
(values (syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...))
(append ve-defs be-defs))))]
[(#%plain-lambda formals be ...)
(let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))])
(with-syntax ([(nbe ...) nbes])
(let ([fvars (free-vars stx)])
(let-values ([(make-CLOSURE new-defs)
(make-closure-definition-syntax
(make-new-closure-label (current-code-labeling) stx)
fvars
(syntax/loc stx (#%plain-lambda formals nbe ...)))])
(values (if (empty? fvars)
(quasisyntax/loc stx (#,make-CLOSURE))
(quasisyntax/loc stx (#,make-CLOSURE (#%plain-lambda () (values #,@fvars)))))
(append be-defs new-defs))))))]
[(case-lambda [formals be ...] ...)
(let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))])
(with-syntax ([((nbe ...) ...) nbes])
(let ([fvars (free-vars stx)])
(let-values ([(make-CLOSURE new-defs)
(make-closure-definition-syntax
(make-new-closure-label (current-code-labeling) stx)
fvars
(syntax/loc stx (case-lambda [formals nbe ...] ...)))])
(values (if (empty? fvars)
(quasisyntax/loc stx (#,make-CLOSURE))
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
(append be-defs new-defs))))))]
[(if te ce ae)
(let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))])
(values (quasisyntax/loc stx (if #,@es))
defs))]
[(quote datum)
(values stx
empty)]
[(quote-syntax datum)
(values stx
empty)]
[(with-continuation-mark ke me be)
(let-values ([(es defs) (defun* (list #'ke #'me #'be))])
(values (quasisyntax/loc stx (with-continuation-mark #,@es))
defs))]
[(#%plain-app e ...)
(let-values ([(es defs) (defun* (syntax->list #'(e ...)))])
(values (quasisyntax/loc stx (#%plain-app #,@es))
defs))]
[(#%top . v)
(values stx
empty)]
[(#%variable-reference . v)
(values stx
empty)]
[id (identifier? #'id)
(values stx
empty)]
[(#%expression d)
(let-values ([(nd d-defs) (defun #'d)])
(values (quasisyntax/loc stx (#%expression #,nd))
d-defs))]
[_
(raise-syntax-error 'defun "Dropped through:" stx)]))))
(kernel-syntax-case
stx (transformer?)
[(begin be ...)
(let-values ([(nbes) (defun* (syntax->list #'(be ...)))])
(quasisyntax/loc stx (begin #,@nbes)))]
[(begin0 be ...)
(let-values ([(nbes) (defun* (syntax->list #'(be ...)))])
(quasisyntax/loc stx (begin0 #,@nbes)))]
[(set! v ve)
(let-values ([(nve) (defun #'ve)])
(quasisyntax/loc stx (set! v #,nve)))]
[(let-values ([(v ...) ve] ...) be ...)
(let-values ([(nves) (defun* (syntax->list #'(ve ...)))]
[(nbes) (defun* (syntax->list #'(be ...)))])
(with-syntax ([(nve ...) nves]
[(nbe ...) nbes])
(syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...))))]
[(letrec-values ([(v ...) ve] ...) be ...)
(let-values ([(nves) (defun* (syntax->list #'(ve ...)))]
[(nbes) (defun* (syntax->list #'(be ...)))])
(with-syntax ([(nve ...) nves]
[(nbe ...) nbes])
(syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...))))]
[(#%plain-lambda formals be ...)
(let-values ([(nbes) (defun* (syntax->list #'(be ...)))])
(with-syntax ([(nbe ...) nbes])
(syntax/loc stx
(serial-lambda formals nbe ...))
#;
(make-closure
(quasisyntax/loc stx
(_ #,(make-new-closure-label (current-code-labeling) stx) (#%plain-lambda formals nbe ...))))))]
[(case-lambda [formals be ...] ...)
(let-values ([(nbes) (defun** (syntax->list #'((be ...) ...)))])
(with-syntax ([((nbe ...) ...) nbes])
(syntax/loc stx
(serial-case-lambda
[formals nbe ...]
...))
#;
(make-closure
(quasisyntax/loc stx
(_ #,(make-new-closure-label (current-code-labeling) stx) (case-lambda [formals nbe ...] ...))))))]
[(if te ce ae)
(let-values ([(es) (defun* (syntax->list #'(te ce ae)))])
(quasisyntax/loc stx (if #,@es)))]
[(quote datum)
stx]
[(quote-syntax datum)
stx]
[(with-continuation-mark ke me be)
(let-values ([(es) (defun* (list #'ke #'me #'be))])
(quasisyntax/loc stx (with-continuation-mark #,@es)))]
[(#%plain-app e ...)
(let-values ([(es) (defun* (syntax->list #'(e ...)))])
(quasisyntax/loc stx (#%plain-app #,@es)))]
[(#%top . v)
stx]
[(#%variable-reference . v)
stx]
[id (identifier? #'id)
stx]
[(#%expression d)
(let-values ([(nd) (defun #'d)])
(quasisyntax/loc stx (#%expression #,nd)))]
[_
(raise-syntax-error 'defun "Dropped through:" stx)])))
; lift defun to list of syntaxes
(define (lift-defun defun)
(lambda (stxs)
(match
(foldl (lambda (stx acc)
(let-values ([(nstx stx-defs) (defun stx)])
(match acc
[(list-rest nstxs defs)
(cons (list* nstx nstxs)
(append stx-defs defs))])))
(cons empty empty)
stxs)
[(list-rest nstxs defs)
(values (reverse nstxs)
defs)])))
(map defun stxs)))
(define defun* (lift-defun defun))
(define defun** (lift-defun (lambda (stx) (defun* (syntax->list stx)))))

29
collects/web-server/lang/serial-lambda.ss Normal file
View File

@ -0,0 +1,29 @@
#lang scheme
(require scheme/serialize
(for-syntax scheme
web-server/lang/closure
web-server/lang/labels))
(define-syntax (serial-lambda stx)
(syntax-case stx ()
[(_ . lmbda-stx)
(let ([labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax->datum stx))))])
(make-closure
(quasisyntax/loc stx
(_ #,(labeling) (lambda . lmbda-stx)))))]))
(define-syntax (serial-case-lambda stx)
(syntax-case stx ()
[(_ . lmbda-stx)
(let ([labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax->datum stx))))])
(make-closure
(quasisyntax/loc stx
(_ #,(labeling) (case-lambda . lmbda-stx)))))]))
(provide serial-lambda
serial-case-lambda)
(provide/contract
[closure->deserialize-name (serializable? . -> . symbol?)])
(define (closure->deserialize-name proc)
(string->symbol (cdr (first (third (serialize proc))))))

54
collects/web-server/lang/util.ss
View File

@ -1,20 +1,16 @@
#lang scheme/base
(require (for-template scheme/base)
scheme/pretty
scheme/list
scheme/contract
syntax/kerncase)
scheme/contract)
(provide/contract
[transformer? (parameter/c boolean?)]
[recertify (syntax? syntax? . -> . syntax?)]
[recertify* (syntax? (listof syntax?) . -> . (listof syntax?))]
[recertify/new-defs (syntax? (-> (values syntax? (listof syntax?))) . -> . (values syntax? (listof syntax?)))]
[current-code-labeling (parameter/c (syntax? . -> . syntax?))]
[generate-formal ((symbol?) ((or/c false/c syntax?)) . ->* . (values syntax? syntax?))]
[formals-list (syntax? . -> . (listof syntax?))]
[make-define-case/new-defs ((syntax? . -> . (values syntax? (listof syntax?))) . -> . (syntax? . -> . (listof syntax?)))]
[make-module-case/new-defs ((syntax? . -> . (listof syntax?)) . -> . (syntax? . -> . (listof syntax?)))]
[make-lang-module-begin ((bytes? . -> . (-> symbol?)) (syntax? . -> . (listof syntax?)) . -> . (syntax? . -> . syntax?))]
[make-define-case ((syntax? . -> . syntax?) . -> . (syntax? . -> . syntax?))]
[make-module-case ((syntax? . -> . syntax?) . -> . (syntax? . -> . syntax?))]
[make-lang-module-begin ((bytes? . -> . (-> symbol?)) (syntax? . -> . syntax?) . -> . (syntax? . -> . syntax?))]
[bound-identifier-member? (syntax? (listof syntax?) . -> . boolean?)])
(define transformer? (make-parameter #f))
@ -22,18 +18,6 @@
(define (recertify old-expr expr)
(syntax-recertify expr old-expr (current-code-inspector) #f))
(define (recertify* old-expr exprs)
(map (lambda (expr)
(syntax-recertify expr old-expr (current-code-inspector) #f))
exprs))
(define (recertify/new-defs old-expr thunk)
(call-with-values
thunk
(lambda (expr new-defs)
(values (recertify old-expr expr)
(recertify* old-expr new-defs)))))
(define current-code-labeling
(make-parameter
(lambda (stx)
@ -56,32 +40,29 @@
[(v ... . rv)
(list* #'rv (syntax->list #'(v ...)))]))
(define ((make-define-case/new-defs inner) stx)
(recertify*
(define ((make-define-case inner) stx)
(recertify
stx
(syntax-case stx (define-values define-syntaxes define-values-for-syntax)
[(define-values (v ...) ve)
(let-values ([(nve defs) (inner #'ve)])
(append
defs
(list (quasisyntax/loc stx
(define-values (v ...) #,nve)))))]
(let-values ([(nve) (inner #'ve)])
(quasisyntax/loc stx
(define-values (v ...) #,nve)))]
[(define-syntaxes (v ...) ve)
(list stx)]
stx]
[(define-values-for-syntax (v ...) ve)
(list stx)]
stx]
[(#%require spec ...)
(list stx)]
stx]
[expr
(let-values ([(nexpr defs) (inner #'expr)])
(append defs (list nexpr)))])))
(inner #'expr)])))
(define ((make-module-case/new-defs inner) stx)
(recertify*
(define ((make-module-case inner) stx)
(recertify
stx
(syntax-case* stx (#%provide) free-identifier=?
[(#%provide spec ...)
(list stx)]
stx]
[_
(inner stx)])))
@ -99,8 +80,7 @@
(define new-defs
(parameterize ([current-code-labeling
(lambda (stx) (datum->syntax stx (base-labeling)))])
(apply append (map transform (syntax->list #'(body ...))))))
#;(pretty-print (syntax->datum #`(pmb #,@new-defs)))
(map transform (syntax->list #'(body ...)))))
(quasisyntax/loc stx
(pmb #,@new-defs)))])))

2
collects/web-server/lang/web-cells.ss
View File

@ -1,6 +1,6 @@
#lang scheme
(require scheme/serialize
"../private/closure.ss")
web-server/lang/serial-lambda)
;; Implementation: Have a distinguished frame variable that is read and captured by send/suspend,
;; installed on invocations of continuations by the server (and NOT from other continuation invocations)

6
collects/web-server/lang/web-param.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base)
scheme/contract
"../private/closure.ss"
web-server/lang/serial-lambda
mzlib/list)
(provide/contract
@ -11,8 +11,8 @@
(define (web-parameter? any)
(and (procedure? any)
(procedure-arity-includes? any 0)
(procedure-arity-includes? any 2)))
(procedure-arity-includes? any 0)
(procedure-arity-includes? any 2)))
(define next-web-parameter-id
(let ([i (box 0)])

129
collects/web-server/private/closure.ss
View File

@ -1,129 +0,0 @@
#lang scheme/base
(require (for-template scheme/base)
(for-template mzlib/serialize)
mzlib/list
scheme/contract
mzlib/serialize)
(provide/contract
[closure->deserialize-name (serializable? . -> . symbol?)])
(provide make-closure-definition-syntax)
(define (closure->deserialize-name proc)
(cdr (first (third (serialize proc)))))
(define (make-closure-definition-syntax tag fvars proc)
(define (make-id str)
(datum->syntax tag (string->symbol (format str (syntax->datum tag)))))
(with-syntax ([CLOSURE:deserialize-info (make-id "~a:deserialize-info")]
[CLOSURE:serialize-info (make-id "~a:serialize-info")]
[make-CLOSURE (make-id "make-~a")]
[CLOSURE? (make-id "~a?")]
[CLOSURE-ref (make-id "~a-ref")]
[CLOSURE-set! (make-id "~a-set!")]
[CLOSURE-env (make-id "~a-env")]
[set-CLOSURE-env! (make-id "set-~a-env!")]
[struct:CLOSURE (make-id "struct:~a")])
(values
(syntax/loc proc make-CLOSURE)
(list
(quasisyntax/loc proc
(define CLOSURE:deserialize-info
(make-deserialize-info
;; make-proc: value ... -> CLOSURE
(lambda args
(apply #,(if (null? fvars)
(syntax/loc proc
(#%plain-lambda () (#%plain-app make-CLOSURE)))
(quasisyntax/loc proc
(#%plain-lambda #,fvars
(#%plain-app make-CLOSURE
(#%plain-lambda ()
(#%plain-app values #,@fvars))))))
args))
;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void))
(lambda ()
(let ([new-closure
#,(if (null? fvars)
(syntax/loc proc (#%plain-app make-CLOSURE))
(syntax/loc proc
(#%plain-app make-CLOSURE
(#%plain-lambda () (#%plain-app error "closure not initialized")))))])
(values
new-closure
#,(if (null? fvars)
(syntax/loc proc void)
(syntax/loc proc
(#%plain-lambda (clsr)
(#%plain-app set-CLOSURE-env! new-closure (#%plain-app CLOSURE-env clsr)))))))))))
(quasisyntax/loc proc
(provide CLOSURE:deserialize-info))
(quasisyntax/loc proc
(define CLOSURE:serialize-info
(make-serialize-info
;; to-vector: CLOSURE -> vector
#,(if (null? fvars)
(syntax/loc proc (#%plain-lambda (clsr) (#%plain-app vector)))
(syntax/loc proc
(#%plain-lambda (clsr)
(#%plain-app call-with-values
(#%plain-lambda () (#%plain-app (#%plain-app CLOSURE-env clsr)))
vector))))
;; The serializer id: --------------------
;(syntax deserialize-info:CLOSURE)
;; I still don't know what to put here.
;; oh well.
;(quote-syntax #,(syntax deserialize-info:CLOSURE))
(let ([b (identifier-binding (quote-syntax CLOSURE:deserialize-info))])
(if (list? b)
(cons 'CLOSURE:deserialize-info (caddr b))
'CLOSURE:deserialize-info))
;; can-cycle?
#t
;; Directory for last-ditch resolution --------------------
(or (current-load-relative-directory) (current-directory))
)))
(quasisyntax/loc proc
(define-values (struct:CLOSURE make-CLOSURE CLOSURE?
#,@(if (null? fvars)
(syntax/loc proc ())
(syntax/loc proc (CLOSURE-env set-CLOSURE-env!))))
(let-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!)
(make-struct-type
'#,tag ;; the tag goes here
#f ; no super type
#,(if (null? fvars) 0 1)
0 ; number of auto-fields
#f ; auto-v
; prop-vals:
(list (cons prop:serializable CLOSURE:serialize-info)
(cons prop:procedure
#,(if (null? fvars)
(quasisyntax/loc proc
(#%plain-lambda (clsr . args)
(#%plain-app apply #,proc args)))
(quasisyntax/loc proc
(#%plain-lambda (clsr . args)
(let-values ([#,fvars (#%plain-app
(#%plain-app CLOSURE-env clsr))])
(#%plain-app apply #,proc args)))))))
#f ; inspector
;; the struct apply proc:
#f)])
(values struct:CLOSURE make-CLOSURE CLOSURE?
#,@(if (null? fvars)
(syntax/loc proc ())
(syntax/loc proc
((#%plain-lambda (clsr) (#%plain-app CLOSURE-ref clsr 0))
(#%plain-lambda (clsr new-env) (#%plain-app CLOSURE-set! clsr 0 new-env)))))))))))))

26
collects/web-server/private/define-closure.ss
View File

@ -1,15 +1,23 @@
#lang scheme/base
(require (for-syntax "closure.ss")
(for-syntax scheme/base)
(for-template scheme/base))
(require (for-syntax scheme
web-server/lang/closure))
(provide define-closure)
(define-syntax (define-closure stx)
(syntax-case stx ()
[(_ tag formals (free-vars ...) body)
(let-values ([(make-CLOSURE closure-definitions)
(make-closure-definition-syntax
#'tag
(syntax->list #'(free-vars ...))
#`(lambda formals body))])
#`(begin #,@closure-definitions))]))
(local
[(define-values (make-CLOSURE-id CLOSURE?-id CLOSURE-env-id)
(define-closure! #'tag #'(free-vars ...) (syntax/loc stx (lambda formals body))))
(define make-tag
(datum->syntax stx (string->symbol (format "make-~a" (syntax->datum #'tag))) stx))
(define tag-env
(datum->syntax stx (string->symbol (format "~a-env" (syntax->datum #'tag))) stx))
(define tag?
(datum->syntax stx (string->symbol (format "~a?" (syntax->datum #'tag))) stx))]
(quasisyntax/loc stx
(begin
(define #,make-tag #,make-CLOSURE-id)
(define #,tag? #,CLOSURE?-id)
(define #,tag-env #,CLOSURE-env-id))))]))

44
collects/web-server/scribblings/closure.scrbl
View File

@ -2,40 +2,34 @@
@(require "web-server.ss")
@title[#:tag "closure.ss"]{Serializable Closures}
@(require (for-label web-server/private/closure
@(require (for-label scheme/serialize
web-server/lang/closure
web-server/lang/serial-lambda
web-server/private/define-closure))
@defmodule[web-server/private/closure]{
The defunctionalization process of the Web Language (see @secref["stateless" #:doc '(lib "web-server/scribblings/web-server.scrbl")])
requires an explicit representation of closures that is serializable. This module provides that representation.
requires an explicit representation of closures that is serializable.
@defproc[(make-closure-definition-syntax [tag syntax?]
[fvars (listof identifier?)]
[proc syntax?])
syntax?]{
Outputs a syntax object that defines a serializable structure,
with @scheme[tag] as the tag, that represents a closure over
@scheme[fvars], that acts a procedure and when invoked calls
@scheme[proc], which is assumed to be syntax of @scheme[lambda]
or @scheme[case-lambda].
@defmodule[web-server/lang/serial-lambda]{
@defform[(serial-lambda formals body ...)]{
Returns @scheme[(lambda formals body ...)], except it is serializable.
}
@defform[(serial-case-lambda [formals body ...] ...)]{
Returns @scheme[(case-lambda [formals body ...] ...)], except it is serializable.
}
}
@defproc[(closure->deserialize-name [c closure?])
symbol?]{
Extracts the unique tag of a closure @scheme[c].
}
}
These are difficult to use directly, so we provide a helper syntactic form:
@section[#:style 'hidden]{Definition Syntax}
@section[#:style 'hidden]{Define Closure}
@defmodule[web-server/private/define-closure]{
@defform[(define-closure tag formals (free-vars ...) body)]{
Defines a closure, constructed with @scheme[make-tag] that accepts closure that returns
@scheme[freevars ...], that when invoked with @scheme[formals]
@defform[(define-closure tag formals (free-var ...) body)]{
Defines a closure, constructed with @scheme[make-tag] that accepts a closure that returns
@scheme[freevar ...], that when invoked with @scheme[formals]
executes @scheme[body].
}