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

v4 progress

Browse Source 
svn: r7804
This commit is contained in:
Jay McCarthy 2007-11-21 19:59:31 +00:00
parent 2204f32678
commit da32b77d55
13 changed files with 205 additions and 263 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -10,7 +10,7 @@
(for-syntax "lang/defun.ss")
"lang/lang-api.ss")
(provide (rename-out [lang-module-begin #%plain-module-begin])
(provide (rename-out [lang-module-begin #%module-begin])
(all-from-out "lang/lang-api.ss"))
(define-syntax lang-module-begin

7
collects/web-server/lang/abort-resume.ss
View File

@ -8,6 +8,7 @@
;; AUXILLIARIES
abort
abort/cc
resume
the-cont-key
the-save-cm-key
@ -36,7 +37,7 @@
(reverse
(list* (cons key val)
(let-values ([(current)
(continuation-mark-set->list (current-continuation-marks) the-save-cm-key)])
(continuation-mark-set->list (current-continuation-marks web-prompt) the-save-cm-key)])
(if (empty? current)
empty
(first current))))))
@ -44,7 +45,7 @@
;; current-continuation-as-list: -> (listof value)
;; check the safety marks and return the list of marks representing the continuation
(define (activation-record-list)
(let* ([cm (current-continuation-marks)]
(let* ([cm (current-continuation-marks web-prompt)]
[sl (reverse (continuation-mark-set->list cm safe-call?))])
(if (andmap (lambda (x)
(if (pair? x)
@ -161,4 +162,4 @@
[(decode-continuation req)
=> (lambda (k) (k req))]
[else
(error "no continuation associated with the provided request")]))))
(error 'dispatch "no continuation associated with the provided request: ~S" req)]))))

36
collects/web-server/lang/anormal.ss
View File

@ -1,5 +1,6 @@
#lang scheme/base
(require (lib "kerncase.ss" "syntax")
(require (for-template scheme/base)
(lib "kerncase.ss" "syntax")
(lib "list.ss")
(lib "plt-match.ss")
"util.ss")
@ -58,14 +59,6 @@
(#%plain-lambda #,save
(begin be ...
(#%plain-app apply values #,ref-to-save)))))))]
[(define-values (v ...) ve)
(with-syntax ([ve (anormal-term #'ve)])
(syntax/loc stx
(define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve)
stx]
[(define-values-for-syntax (v ...) ve)
stx]
[(set! v ve)
(anormal
(compose ctxt
@ -121,11 +114,6 @@
(ctxt stx)]
[(quote-syntax datum)
(ctxt stx)]
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(anormal ctxt
(elim-letrec-term stx))]
[(with-continuation-mark ke me be)
(anormal
(compose ctxt
@ -136,13 +124,7 @@
(with-continuation-mark #,kev #,mev
#,(anormal-term #'be))))
#'me)))
#'ke)]
[(#%expression d)
(anormal
(compose ctxt
(lambda (d)
(quasisyntax/loc stx (#%expression #,d))))
#'d)]
#'ke)]
[(#%plain-app fe e ...)
(anormal
(lambda (val0)
@ -159,6 +141,18 @@
(ctxt stx)]
[id (identifier? #'id)
(ctxt #'id)]
; XXX Shouldn't be here
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(anormal ctxt
(elim-letrec-term stx))]
[(#%expression d)
(anormal
(compose ctxt
(lambda (d)
(quasisyntax/loc stx (#%expression #,d))))
#'d)]
[_
(raise-syntax-error 'anormal "Dropped through:" stx)])))

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

@ -1,5 +1,6 @@
#lang scheme/base
(require (lib "kerncase.ss" "syntax")
(require (for-template scheme/base)
(lib "kerncase.ss" "syntax")
(lib "list.ss")
(lib "plt-match.ss")
"util.ss"
@ -27,16 +28,6 @@
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
(values (quasisyntax/loc stx (begin0 #,@nbes))
defs))]
[(define-values (v ...) ve)
(let-values ([(nve defs) (defun #'ve)])
(values (quasisyntax/loc stx (define-values (v ...) #,nve))
defs))]
[(define-syntaxes (v ...) ve)
(values stx
empty)]
[(define-values-for-syntax (v ...) ve)
(values stx
empty)]
[(set! v ve)
(let-values ([(nve defs) (defun #'ve)])
(values (quasisyntax/loc stx (set! v #,nve))
@ -91,6 +82,24 @@
[(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)]
; XXX Shouldn't
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
@ -105,27 +114,10 @@
([(vv ...) nve] ...)
nbe ...))
(append se-defs ve-defs be-defs))))]
[(with-continuation-mark ke me be)
(let-values ([(es defs) (defun* (list #'ke #'me #'be))])
(values (quasisyntax/loc stx (with-continuation-mark #,@es))
defs))]
[(#%expression d)
(let-values ([(nd d-defs) (defun #'d)])
(values (quasisyntax/loc stx (#%expression #,nd))
d-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)]
[_
(raise-syntax-error 'defun "Dropped through:" stx)]))))

49
collects/web-server/lang/elim-callcc.ss
View File

@ -1,6 +1,8 @@
#lang scheme/base
(require (lib "kerncase.ss" "syntax")
(for-syntax "../lang/abort-resume.ss")
(require (for-template scheme/base)
(lib "kerncase.ss" "syntax")
"../lang/abort-resume.ss"
(for-template "../lang/abort-resume.ss")
"util.ss")
(provide elim-callcc)
@ -15,8 +17,8 @@
[(#%plain-lambda formals be ...)
(syntax/loc w
(#%plain-lambda formals
(with-continuation-mark safe-call? '(#t (lambda formals))
be ...)))]
(with-continuation-mark safe-call? '(#t (lambda formals))
be ...)))]
[(case-lambda [formals be ...] ...)
(syntax/loc w
(case-lambda [formals
@ -36,14 +38,6 @@
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
[(begin0 be ...)
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
[(define-values (v ...) ve)
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
(syntax/loc stx
(define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve)
stx]
[(define-values-for-syntax (v ...) ve)
stx]
[(set! v ve)
(with-syntax ([ve (elim-callcc #'ve)])
(syntax/loc stx (set! v ve)))]
@ -52,13 +46,15 @@
[(letrec-values ([(v ...) ve] ...) be ...)
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
[(#%plain-lambda formals be)
(with-syntax ([be (elim-callcc #'be)])
(syntax/loc stx
(#%plain-lambda formals be)))]
(mark-lambda-as-safe
(with-syntax ([be (elim-callcc #'be)])
(syntax/loc stx
(#%plain-lambda formals be))))]
[(case-lambda [formals be] ...)
(with-syntax ([(be ...) (map elim-callcc (syntax->list #'(be ...)))])
(syntax/loc stx
(case-lambda [formals be] ...)))]
(mark-lambda-as-safe
(with-syntax ([(be ...) (map elim-callcc (syntax->list #'(be ...)))])
(syntax/loc stx
(case-lambda [formals be] ...))))]
[(if te ce ae)
(with-syntax ([te (elim-callcc #'te)]
[ce (elim-callcc #'ce)]
@ -67,11 +63,7 @@
[(quote datum)
stx]
[(quote-syntax datum)
stx]
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
stx]
[(with-continuation-mark ke me be)
(let* ([ke-prime (elim-callcc #'ke)]
[me-prime (elim-callcc #'me)]
@ -83,9 +75,7 @@
(with-continuation-mark
the-save-cm-key
(#%plain-app current-saved-continuation-marks-and #,ke-prime #,me-prime)
#,be-prime)))))]
[(#%expression d)
(markit (quasisyntax/loc stx (#%expression #,(elim-callcc #'d))))]
#,be-prime)))))]
[(#%plain-app call/cc w)
(let-values ([(cm ref-to-cm) (generate-formal 'current-marks)]
[(x ref-to-x) (generate-formal 'x)])
@ -166,5 +156,12 @@
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)]
[(#%expression d)
(markit (quasisyntax/loc stx (#%expression #,(elim-callcc #'d))))]
[_
(raise-syntax-error 'elim-callcc "Dropped through:" stx)])))

52
collects/web-server/lang/elim-letrec.ss
View File

@ -1,8 +1,9 @@
#lang scheme/base
(require (lib "kerncase.ss" "syntax")
(require (for-template scheme/base)
(lib "kerncase.ss" "syntax")
(lib "etc.ss")
(lib "list.ss")
(for-syntax "../lang/abort-resume.ss")
(for-template "../lang/abort-resume.ss")
"util.ss")
(provide (all-defined-out))
@ -22,14 +23,6 @@
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
(syntax/loc stx
(begin0 be ...)))]
[(define-values (v ...) ve)
(with-syntax ([ve ((elim-letrec ids) #'ve)])
(syntax/loc stx
(define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve)
stx]
[(define-values-for-syntax (v ...) ve)
stx]
[(set! v ve)
(with-syntax ([ve ((elim-letrec ids) #'ve)])
(if (bound-identifier-member? #'id ids)
@ -76,7 +69,26 @@
[(quote datum)
stx]
[(quote-syntax datum)
stx]
[(with-continuation-mark ke me be)
(with-syntax ([ke ((elim-letrec ids) #'ke)]
[me ((elim-letrec ids) #'me)]
[be ((elim-letrec ids) #'be)])
(syntax/loc stx
(with-continuation-mark ke me be)))]
[(#%plain-app e ...)
(with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))])
(syntax/loc stx
(#%plain-app e ...)))]
[(#%top . v)
stx]
[(#%variable-reference . v)
stx]
[id (identifier? #'id)
(if (bound-identifier-member? #'id ids)
(syntax/loc stx (#%plain-app unbox id))
#'id)]
; XXX These two cases shouldn't be here.
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
@ -101,27 +113,9 @@
(#%plain-lambda (nvv ...)
(#%plain-app set-box! vv nvv) ...))
...
be ...))))))]
[(with-continuation-mark ke me be)
(with-syntax ([ke ((elim-letrec ids) #'ke)]
[me ((elim-letrec ids) #'me)]
[be ((elim-letrec ids) #'be)])
(syntax/loc stx
(with-continuation-mark ke me be)))]
be ...))))))]
[(#%expression d)
(quasisyntax/loc stx (#%expression #,((elim-letrec ids) #'d)))]
[(#%plain-app e ...)
(with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))])
(syntax/loc stx
(#%plain-app e ...)))]
[(#%top . v)
stx]
[(#%variable-reference . v)
stx]
[id (identifier? #'id)
(if (bound-identifier-member? #'id ids)
(syntax/loc stx (#%plain-app unbox id))
#'id)]
[_
(raise-syntax-error 'elim-letrec "Dropped through:" stx)])))

72
collects/web-server/lang/freevars.ss
View File

@ -1,5 +1,6 @@
#lang scheme/base
(require (lib "kerncase.ss" "syntax")
(require (for-template scheme/base)
(lib "kerncase.ss" "syntax")
(lib "list.ss")
(lib "toplevel.ss" "syntax")
(lib "plt-match.ss")
@ -16,17 +17,6 @@
(free-vars* (syntax->list #'(be ...)))]
[(begin0 be ...)
(free-vars* (syntax->list #'(be ...)))]
[(define-values (v ...) ve)
(set-diff (free-vars #'ve)
(syntax->list #'(v ...)))]
[(define-syntaxes (v ...) ve)
(parameterize ([transformer? #t])
(set-diff (free-vars #'ve)
(syntax->list #'(v ...))))]
[(define-values-for-syntax (v ...) ve)
(parameterize ([transformer? #t])
(set-diff (free-vars #'ve)
(syntax->list #'(v ...))))]
[(set! v ve)
(union (free-vars #'v)
(free-vars #'ve))]
@ -54,6 +44,35 @@
empty]
[(quote-syntax datum)
empty]
[(with-continuation-mark ke me be)
(free-vars* (syntax->list #'(ke me be)))]
[(#%plain-app e ...)
(free-vars* (syntax->list #'(e ...)))]
[(#%top . v)
#;(printf "Not including top ~S in freevars~n" (syntax->datum #'v))
empty]
[(#%variable-reference . id)
(let ([i-bdg (identifier-binding #'id)])
(cond
[(eqv? 'lexical i-bdg)
(list #'id)]
[(not i-bdg)
(list #'id)]
[else
#;(printf "Not including var-reference ~S with binding ~S in freevars~n" (syntax->datum #'id) i-bdg)
empty]))]
[id (identifier? #'id)
(let ([i-bdg (identifier-binding #'id)])
#;(printf "ID ~S with binding ~S in freevars~n" (syntax->datum #'id) i-bdg)
(cond
[(eqv? 'lexical i-bdg)
(list #'id)]
[(not i-bdg)
(list #'id)]
[else
#;(printf "Not including id ~S with binding ~S in freevars~n" (syntax->datum #'id) i-bdg)
empty]))]
; XXX Shouldn't be here
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
@ -62,33 +81,8 @@
(free-vars* (syntax->list #'(be ...))))
(append (apply append (map syntax->list (syntax->list #'((sv ...) ...))))
(apply append (map syntax->list (syntax->list #'((vv ...) ...))))))]
[(with-continuation-mark ke me be)
(free-vars* (syntax->list #'(ke me be)))]
[(#%expression d)
(free-vars #'d)]
[(#%plain-app e ...)
(free-vars* (syntax->list #'(e ...)))]
[(#%top . v)
#;(printf "Not including top ~S in freevars~n" (syntax-object->datum #'v))
empty]
[(#%variable-reference . id)
(let ([i-bdg (identifier-binding #'id)])
(cond
[(eqv? 'lexical (identifier-binding #'id))
(list #'id)]
[else
#;(printf "Not including var-reference ~S with binding ~S in freevars~n" (syntax-object->datum #'id) i-bdg)
empty]))]
[id (identifier? #'id)
(let ([i-bdg (identifier-binding #'id)])
(cond
[(eqv? 'lexical i-bdg)
(list #'id)]
[(not i-bdg)
(list #'id)]
[else
#;(printf "Not including id ~S with binding ~S in freevars~n" (syntax-object->datum #'id) i-bdg)
empty]))]
[_
(raise-syntax-error 'freevars "Dropped through:" stx)]))
@ -118,7 +112,7 @@
(raise-syntax-error 'insert "Not identifier" sym))
(cond
[(null? into) (list sym)]
[(bound-identifier=? sym (car into)) into]
[(free-identifier=? sym (car into)) into]
[else (cons (car into) (insert sym (cdr into)))]))
;; set-diff: (listof identifier) (listof identifier) -> (listof identifier)
@ -135,7 +129,7 @@
(raise-syntax-error 'sans "Not identifier" elt))
(cond
[(null? s) empty]
[(bound-identifier=? (car s) elt)
[(free-identifier=? (car s) elt)
(cdr s)] ;; if we maintain the no-dupe invariant then we don't need to recur
[else (cons (car s)
(sans (cdr s) elt))]))

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

@ -9,7 +9,7 @@
"web-param.ss"
"file-box.ss"
"web-extras.ss")
(provide (except-out (all-from-out scheme/base) #%plain-module-begin)
(provide (except-out (all-from-out scheme/base) #%module-begin)
(all-from-out (lib "url.ss" "net"))
(all-from-out "../private/request-structs.ss")
(all-from-out "../private/response-structs.ss")

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

@ -1,5 +1,7 @@
#lang scheme/base
(require (lib "kerncase.ss" "syntax")
(require (for-template scheme/base)
(lib "kerncase.ss" "syntax")
(lib "pretty.ss")
(lib "list.ss"))
(provide (except-out (all-defined-out) template))
@ -42,74 +44,63 @@
[(v ... . rv)
(list* #'rv (syntax->list #'(v ...)))]))
(define ((make-define-case inner) stx)
(recertify
(define ((make-define-case/new-defs inner) stx)
(recertify*
stx
(syntax-case stx (define-values define-syntaxes define-values-for-syntax)
[(define-values (v ...) ve)
(with-syntax ([ve (inner #'ve)])
(syntax/loc stx
(define-values (v ...) ve)))]
(let-values ([(nve defs) (inner #'ve)])
(append
defs
(list (quasisyntax/loc stx
(define-values (v ...) #,nve)))))]
[(define-syntaxes (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve (inner #'ve)])
(syntax/loc stx
(define-syntaxes (v ...) ve))))]
(let-values ([(nve defs) (inner #'ve)])
(append
defs
(list (quasisyntax/loc stx
(define-syntaxes (v ...) #,nve))))))]
[(define-values-for-syntax (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve (inner #'ve)])
(syntax/loc stx
(define-values-for-syntax (v ...) ve))))]
[_
(raise-syntax-error 'define-case "Dropped through:" stx)])))
(define ((make-define-case/new-defs inner) stx)
(let-values ([(nstx defs) (inner stx)])
(append defs (list nstx))))
(let-values ([(nve defs) (inner #'ve)])
(append
defs
(list (quasisyntax/loc stx
(define-values-for-syntax (v ...) #,nve))))))]
[(#%require spec ...)
(list stx)]
[expr
(let-values ([(nexpr defs) (inner #'expr)])
(append defs (list nexpr)))])))
(define ((make-module-case/new-defs inner) stx)
(recertify*
stx
(syntax-case* stx (#%require #%provide) free-identifier=?
[(#%require spec ...)
(list stx)]
(syntax-case* stx (#%provide) free-identifier=?
[(#%provide spec ...)
(list stx)]
[_
(inner stx)])))
(define ((make-module-case inner) stx)
(recertify
stx
(syntax-case* stx (#%require #%provide) free-identifier=?
[(#%require spec ...)
stx]
[(#%provide spec ...)
stx]
[_
(inner stx)])))
(define ((make-lang-module-begin make-labeling transform) stx)
(recertify
stx
(syntax-case stx ()
((mb forms ...)
(with-syntax ([(pmb rfs0 body ...)
(syntax-case stx ()
[(mb forms ...)
(with-syntax ([(pmb body ...)
(local-expand (quasisyntax/loc stx
(#%plain-module-begin
#,(syntax-local-introduce
#'(require (for-syntax scheme/base)))
forms ...))
(#%module-begin forms ...))
'module-begin
empty)])
(let ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax->datum stx))))])
(define base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax->datum stx)))))
(define new-defs
(parameterize ([current-code-labeling
(lambda (stx)
(datum->syntax stx (base-labeling)))])
(let ([new-defs (apply append (map transform (syntax->list #'(body ...))))])
(quasisyntax/loc stx
(pmb rfs0
#,@new-defs))))))))))
(lambda (stx) (datum->syntax stx (base-labeling)))])
(apply append (map transform (syntax->list #'(body ...))))))
#;(pretty-print (syntax->datum #`(pmb #,@new-defs)))
(quasisyntax/loc stx
(pmb #,@new-defs)))])))
(define (bound-identifier-member? id ids)
(ormap
@ -131,20 +122,6 @@
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
(syntax/loc stx
(begin0 be ...)))]
[(define-values (v ...) ve)
(with-syntax ([ve (template #'ve)])
(syntax/loc stx
(define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve (template #'ve)])
(syntax/loc stx
(define-syntaxes (v ...) ve))))]
[(define-values-for-syntax (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve (template #'ve)])
(syntax/loc stx
(define-values-for-syntax (v ...) ve))))]
[(set! v ve)
(with-syntax ([ve (template #'ve)])
(syntax/loc stx
@ -176,25 +153,13 @@
[(quote datum)
stx]
[(quote-syntax datum)
stx]
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(with-syntax ([(se ...) (map template (syntax->list #'(se ...)))]
[(ve ...) (map template (syntax->list #'(ve ...)))]
[(be ...) (map template (syntax->list #'(be ...)))])
(syntax/loc stx
(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)))]
stx]
[(with-continuation-mark ke me be)
(with-syntax ([ke (template #'ke)]
[me (template #'me)]
[be (template #'be)])
(syntax/loc stx
(with-continuation-mark ke me be)))]
[(#%expression . d)
stx]
[(#%plain-app e ...)
(with-syntax ([(e ...) (map template (syntax->list #'(e ...)))])
(syntax/loc stx

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

@ -7,7 +7,7 @@
closure->deserialize-name)
(define (closure->deserialize-name proc)
(cdr (first (second (serialize proc)))))
(cdr (first (third (serialize proc)))))
(define (make-closure-definition-syntax tag fvars proc)
(define (make-id str)
@ -54,7 +54,7 @@
(syntax/loc proc void)
(syntax/loc proc
(#%plain-lambda (clsr)
(#%plain-app set-CLOSURE-env! new-closure (#%plain-app CLOSURE-env clsr)))))))))))
(#%plain-app set-CLOSURE-env! new-closure (#%plain-app CLOSURE-env clsr)))))))))))
(quasisyntax/loc proc
(provide CLOSURE:deserialize-info))
@ -68,9 +68,9 @@
(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))))
(#%plain-app call-with-values
(#%plain-lambda () (#%plain-app (#%plain-app CLOSURE-env clsr)))
vector))))
;; The serializer id: --------------------
;(syntax deserialize-info:CLOSURE)
@ -94,33 +94,34 @@
#,@(if (null? fvars)
(syntax/loc proc ())
(syntax/loc proc (CLOSURE-env set-CLOSURE-env!))))
(let ([struct-apply
#,(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)))))])
(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 struct-apply))
#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))))))))))))))
(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)))))))))))))

7
collects/web-server/tests/lang-test.ss
View File

@ -239,7 +239,8 @@
(table-01-eval '(require 'm06))
(let* ([first-key (table-01-eval '(dispatch-start start 'foo))]
[second-key (table-01-eval `(dispatch lookup-k '(,first-key 1)))]
[third-key (table-01-eval `(dispatch lookup-k '(,first-key -7)))])
[third-key (table-01-eval `(dispatch lookup-k '(,first-key -7)))])
(printf "~S~n" (list first-key second-key third-key))
(check = 3 (table-01-eval `(dispatch lookup-k '(,second-key 2))))
(check = 4 (table-01-eval `(dispatch lookup-k '(,second-key 3))))
(check-true (zero? (table-01-eval `(dispatch lookup-k '(,second-key -1)))))
@ -267,7 +268,7 @@
(let* ([first-key (test-m06.1 '(dispatch-start start 'foo))]
[second-key (test-m06.1 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))]
[third-key (test-m06.1 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) -7)))])
(check = 3 (test-m06.1 `(dispatch ,the-dispatch (list ,second-key 2))))
(check = 3 (test-m06.1 `(abort/cc (lambda () (dispatch ,the-dispatch (list ,second-key 2))))))
(check = 4 (test-m06.1 `(dispatch ,the-dispatch (list ,second-key 3))))
(check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,second-key -1)))))
(check = -7 (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 0))))
@ -523,7 +524,7 @@
(module data (lib "lang.ss" "web-server")
(require (lib "contract.ss"))
(define-struct posn (x y))
(define-struct posn (x y) #:mutable)
(provide/contract
[struct posn ([x integer?] [y integer?])]))))))

8
collects/web-server/tests/lang/anormal-test.ss
View File

@ -276,7 +276,7 @@
(test-suite
"Miscellaneous tests"
(test-case
#;(test-case
"empty begin"
(check alpha= (normalize-term (expand-syntax (syntax (begin))))
(expand-syntax (syntax (void)))))
@ -313,12 +313,14 @@
(* (car l) (cdr l))])))))
#t)))
(test-not-exn "define-struct"
; XXX Anormal only works on expressions
#;(test-not-exn "define-struct"
(lambda () (normalize-term (expand-syntax (syntax (define-struct posn (x y)))))))
(test-not-exn "quote-syntax: #f"
(lambda () (parameterize ([transformer? #f])
(normalize-term (expand-syntax (syntax #'provide/contract-id-set-a-date-day!))))))
(test-not-exn "quote-syntax: #t"
; XXX I don't know if this SHOULD work
#;(test-not-exn "quote-syntax: #t"
(lambda () (parameterize ([transformer? #t])
(normalize-term (expand-syntax (syntax #'provide/contract-id-set-a-date-day!))))))
)))

3
collects/web-server/tests/lang/defun-test.ss
View File

@ -15,7 +15,8 @@
(test-suite
"Defunctionalization"
(test-not-exn "define-struct" (lambda () (vwrap (defun (expand (syntax (define-struct posn (x y))))))))
; XXX Doesn't work for non-exp values
#;(test-not-exn "define-struct" (lambda () (vwrap (defun (expand (syntax (define-struct posn (x y))))))))
(test-not-exn "quote-syntax" (lambda () (vwrap (defun (expand (syntax #'provide/contract-id-set-a-date-day!))))))
#;(test-not-exn "provide/contract" (lambda () (vwrap (defun (expand (syntax (module t mzscheme
(require (lib "contract.ss"))