From 3212d1171217a93eb2865a602092d5b5d842ff40 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 14 Nov 2008 16:48:17 +0000 Subject: [PATCH 001/193] Add all changes from branches/with-contract (which this branch will replace eventually), plus a couple of fixes in contract-test.ss. svn: r12451 --- collects/mzlib/contract.ss | 11 +- collects/mzlib/scribblings/contract.scrbl | 42 +- collects/scheme/private/contract-arrow.ss | 43 +- collects/scheme/private/contract-guts.ss | 52 ++- collects/scheme/private/contract.ss | 371 +++++++++++++----- .../tests/mzscheme/contract-mzlib-test.ss | 20 +- collects/tests/mzscheme/contract-test.ss | 261 +++++++++++- 7 files changed, 652 insertions(+), 148 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index bf96a1caf5..a19188176a 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -15,6 +15,13 @@ (require "private/contract-object.ss") (provide (all-from-out "private/contract-object.ss")) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; old-style define/contract +;; + +(require "private/contract-define.ss") +(provide (all-from-out "private/contract-define.ss")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -22,7 +29,9 @@ ;; except the arrow contracts ;; -(require scheme/private/contract +(require (except-in scheme/private/contract + define/contract + with-contract) scheme/private/contract-guts scheme/private/contract-ds scheme/private/contract-opt diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl index 65dbd92e98..3478296362 100644 --- a/collects/mzlib/scribblings/contract.scrbl +++ b/collects/mzlib/scribblings/contract.scrbl @@ -1,5 +1,7 @@ #lang scribble/doc @(require "common.ss" + scheme/sandbox + scribble/eval scribble/struct (for-label mzlib/contract)) @@ -56,7 +58,6 @@ from @schememodname[scheme/contract]: contract-violation->string contract? define-contract-struct - define/contract false/c flat-contract flat-contract-predicate @@ -91,3 +92,42 @@ from @schememodname[scheme/contract]: vector/c vectorof] +It also provides the old version of @scheme[define/contract]: + +@defform[(define/contract id contract-expr init-value-expr)]{ + +Attaches the contract @scheme[contract-expr] to +@scheme[init-value-expr] and binds that to @scheme[id]. + +The @scheme[define/contract] form treats individual definitions as +units of blame. The definition itself is responsible for positive +(co-variant) positions of the contract and each reference to +@scheme[id] (including those in the initial value expression) must +meet the negative positions of the contract. + +Error messages with @scheme[define/contract] are not as clear as those +provided by @scheme[provide/contract], because +@scheme[define/contract] cannot detect the name of the definition +where the reference to the defined variable occurs. Instead, it uses +the source location of the reference to the variable as the name of +that definition. + +@examples[#:eval (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-eval-limits #f]) + (make-evaluator 'mzscheme)) + (require mzlib/contract) + (define/contract f + (-> number? number?) + (lambda (x) (+ x 1))) + (define/contract g + (-> number? number?) + (lambda (x) (f #t))) + (define/contract i + (-> number? number?) + (lambda (x) + (if (number? x) (i #t) 0))) + (f 4) + (f #t) + (g 4) + (i 3)]} diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 0fcf37a5df..525a24ce19 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -102,10 +102,9 @@ v4 todo: #:omit-define-syntaxes #:property proj-prop (λ (ctc) - (let* ([doms-proj (map (λ (x) ((proj-get x) x)) - (if (->-dom-rest/c ctc) - (append (->-doms/c ctc) (list (->-dom-rest/c ctc))) - (->-doms/c ctc)))] + (let* ([doms-proj (map (λ (x) ((proj-get x) x)) (->-doms/c ctc))] + [rest-proj (and (->-dom-rest/c ctc) + ((λ (x) ((proj-get x) x)) (->-dom-rest/c ctc)))] [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))] [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))] [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))] @@ -117,22 +116,36 @@ v4 todo: [optionals-length (length (->-optional-doms/c ctc))] [has-rest? (and (->-dom-rest/c ctc) #t)]) (λ (pos-blame neg-blame src-info orig-str) - (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) - doms-proj)] - [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) - doms-optional-proj)] - [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) - rngs-proj)] - [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) - mandatory-kwds-proj)] - [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) - optional-kwds-proj)]) + (let ([partial-doms (for/list ([dom (in-list doms-proj)] + [n (in-naturals 1)]) + (dom neg-blame pos-blame src-info + (cons (format "required argument ~a" n) orig-str)))] + [partial-rest (if rest-proj + (list (rest-proj neg-blame pos-blame src-info + (cons "rest argument" orig-str))) + null)] + [partial-optional-doms (for/list ([dom (in-list doms-optional-proj)] + [n (in-naturals 1)]) + (dom neg-blame pos-blame src-info + (cons (format "optional argument ~a" n) orig-str)))] + [partial-ranges (for/list ([rng (in-list rngs-proj)] + [n (in-naturals 1)]) + (rng pos-blame neg-blame src-info + (cons (format "result ~a" n) orig-str)))] + [partial-mandatory-kwds (for/list ([kwd (in-list mandatory-kwds-proj)] + [kwd-lit (in-list mandatory-keywords)]) + (kwd neg-blame pos-blame src-info + (cons (format "keyword argument ~a" kwd-lit) orig-str)))] + [partial-optional-kwds (for/list ([kwd (in-list optional-kwds-proj)] + [kwd-lit (in-list optional-keywords)]) + (kwd neg-blame pos-blame src-info + (cons (format "keyword argument ~a" kwd-lit) orig-str)))]) (apply func (λ (val mtd?) (if has-rest? (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) - (append partial-doms partial-optional-doms + (append partial-doms partial-rest partial-optional-doms partial-mandatory-kwds partial-optional-kwds partial-ranges)))))) diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 6627e2dee7..185e87eac7 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -1,7 +1,8 @@ #lang scheme/base (require "contract-helpers.ss" - scheme/pretty) + scheme/pretty + (only-in scheme/list add-between)) (require (for-syntax scheme/base "contract-helpers.ss")) @@ -175,23 +176,35 @@ (lambda (x) (get x 0)) (lambda (x) (get x 1))))) -(define (default-contract-violation->string val src-info to-blame contract-sexp msg) +(define (default-contract-violation->string val src-info to-blame contract-sexp+extra msg) + (define (add-modifiers-to-contract modifiers contract-str) + (if (null? modifiers) + contract-str + (string-append "for " + (apply string-append (add-between modifiers " of ")) + " in " contract-str))) (let ([blame-src (src-info-as-string src-info)] [formatted-contract-sexp - (let ([one-line - (let ([sp (open-output-string)]) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 'infinity]) - (pretty-print contract-sexp sp) - (get-output-string sp)))]) - (if (< (string-length one-line) 30) - one-line - (let ([sp (open-output-string)]) - (newline sp) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 50]) - (pretty-print contract-sexp sp)) - (get-output-string sp))))] + (let-values ([(modifiers contract-sexp) + (let loop ([dlist contract-sexp+extra] + [modifiers null]) + (if (and (pair? dlist) + (string? (car dlist))) + (loop (cdr dlist) (cons (car dlist) modifiers)) + (values (reverse modifiers) dlist)))]) + (let ([one-line + (let ([sp (open-output-string)]) + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print contract-sexp sp) + (get-output-string sp)))]) + (if (< (string-length one-line) 30) + (add-modifiers-to-contract modifiers one-line) + (let ([sp (open-output-string)]) + (newline sp) + (parameterize ([pretty-print-print-line print-contract-liner] + [pretty-print-columns 50]) + (pretty-print contract-sexp sp)) + (add-modifiers-to-contract modifiers (get-output-string sp))))))] [specific-blame (cond [(syntax? src-info) @@ -210,8 +223,9 @@ (pair? (cdr to-blame)) (null? (cddr to-blame)) (equal? 'quote (car to-blame))) - (format "'~s" (cadr to-blame))] - [else (format "~s" to-blame)]) + (format "module '~s" (cadr to-blame))] + [(string? to-blame) to-blame] + [else (format "module ~s" to-blame)]) formatted-contract-sexp specific-blame) msg))) @@ -516,4 +530,4 @@ #:property name-prop (λ (ctc) (predicate-contract-name ctc)) #:property flat-prop (λ (ctc) (predicate-contract-pred ctc))) -(define (build-flat-contract name pred) (make-predicate-contract name pred)) \ No newline at end of file +(define (build-flat-contract name pred) (make-predicate-contract name pred)) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index c8d3d878b8..cee8b900cf 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -12,13 +12,19 @@ improve method arity mismatch contract violation error messages? (provide (rename-out [-contract contract]) recursive-contract provide/contract - define/contract) + define/contract + with-contract + current-contract-region) (require (for-syntax scheme/base) (for-syntax "contract-opt-guts.ss") (for-syntax scheme/struct-info) (for-syntax scheme/list) - scheme/promise) + (for-syntax syntax/define) + (for-syntax syntax/kerncase) + scheme/promise + scheme/stxparam + mzlib/etc) (require "contract-arrow.ss" "contract-guts.ss" @@ -28,6 +34,24 @@ improve method arity mismatch contract violation error messages? (for-syntax (prefix-in a: "contract-helpers.ss"))) +;; These are useful for all below. + +(define-syntax (verify-contract stx) + (syntax-case stx () + [(_ name x) (a:known-good-contract? #'x) #'x] + [(_ name x) #'(coerce-contract name x)])) + +;; id->contract-src-info : identifier -> syntax +;; constructs the last argument to the -contract, given an identifier +(define-for-syntax (id->contract-src-info id) + #`(list (make-srcloc #,id + #,(syntax-line id) + #,(syntax-column id) + #,(syntax-position id) + #,(syntax-span id)) + #,(format "~s" (syntax->datum id)))) + + ; ; @@ -46,6 +70,255 @@ improve method arity mismatch contract violation error messages? ; ; ; +;; (define/contract id contract expr) +;; defines `id' with `contract'; initially binding +;; it to the result of `expr'. These variables may not be set!'d. +(define-syntax (define/contract define-stx) + (when (eq? (syntax-local-context) 'expression) + (raise-syntax-error 'define/contract + "used in expression context" + define-stx)) + (syntax-case define-stx () + [(_ name) + (raise-syntax-error 'define/contract + "no contract or body" + define-stx)] + [(_ name contract-expr) + (raise-syntax-error 'define/contract + "no body after contract" + define-stx)] + [(_ name contract-expr expr) + (identifier? #'name) + (let ([contract (if (a:known-good-contract? #'contract-expr) + #'contract-expr + #'(verify-contract 'define/contract contract-expr))]) + (quasisyntax/loc define-stx + (with-contract #:type definition name + ([name #,contract]) + (define name expr))))] + [(_ name contract-expr expr0 expr ...) + (identifier? #'name) + (raise-syntax-error 'define/contract + "multiple expressions after identifier and contract" + define-stx)] + [(_ name+arg-list contract body0 body ...) + (let-values ([(name lam-expr) + (normalize-definition + (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list + #'body0 #'(body ...))) + #'lambda #t #t)]) + (with-syntax ([name name] + [lam-expr lam-expr]) + (syntax/loc define-stx + (with-contract #:type function name + ([name (verify-contract 'define/contract contract)]) + (define name lam-expr)))))])) + + + +; +; +; ; ; +; ; ; ; ; +; ; ; ; ; +; ; ; ; ; ;;;; ; ;;; ;;; ;;; ; ;;; ;;;; ; ;; ;;;; ;;; ;;;; +; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; +; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; +; ; ; ; ;;; ; ; ;;; ;;; ; ; ;;; ; ;;;; ; ;;; ;;; +; +; +; + +(define-syntax-parameter current-contract-region #f) + +(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) + (make-set!-transformer + (lambda (stx) + (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) + #'(#%variable-reference))] + [pos-blame-id pos-blame-id] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'with-contract + "cannot set! a with-contract variable" + stx + (syntax id))] + [(f arg ...) + (syntax/loc stx + ((-contract contract-id + id + pos-blame-id + neg-blame-id + #'f) + arg ...))] + [ident + (identifier? (syntax ident)) + (syntax/loc stx + (-contract contract-id + id + pos-blame-id + neg-blame-id + #'ident))]))))) + +(define-for-syntax (head-expand-all body-stxs) + (for/list ([stx body-stxs]) + (local-expand stx + (syntax-local-context) + (kernel-form-identifier-list)))) + +(define-for-syntax (check-exports ids body-stxs) + (let ([defd-ids (for/fold ([id-list null]) + ([stx body-stxs]) + (kernel-syntax-case stx #f + [(define-values ids expr) + (append (syntax->list #'ids) + id-list)] + [_ id-list]))]) + (for ([id (in-list ids)]) + (unless (findf (lambda (s) + (bound-identifier=? s id)) + defd-ids) + (raise-syntax-error 'with-contract + "identifier not defined in body" + id))))) + +(define-for-syntax (check-and-split-with-contract-args args) + (let loop ([args args] + [unprotected null] + [protected null] + [protections null]) + (cond + [(null? args) + (values unprotected protected protections)] + [(identifier? (car args)) + (loop (cdr args) + (cons (car args) unprotected) + protected + protections)] + [(let ([lst (syntax->list (car args))]) + (and (list? lst) + (= (length lst) 2) + (identifier? (first lst)) + lst)) + => + (lambda (l) + (loop (cdr args) + unprotected + (cons (first l) protected) + (cons (second l) protections)))] + [else + (raise-syntax-error 'with-contract + "expected an identifier or (identifier contract)" + (car args))]))) + +(define-syntax (with-contract stx) + (when (eq? (syntax-local-context) 'expression) + (raise-syntax-error 'with-contract + "used in expression context" + stx)) + (syntax-case stx () + [(_ #:type type blame (arg ...) body0 body ...) + (and (identifier? #'blame) + (identifier? #'type)) + (let*-values ([(unprotected protected protections) + (check-and-split-with-contract-args (syntax->list #'(arg ...)))] + [(expanded-bodies) (head-expand-all (cons #'body0 + (syntax->list #'(body ...))))] + [(protected-ids ids contracts contract-defs) + (for/lists (protected-ids ids contracts contract-defs) + ([n protected] + [c protections]) + (let ([new-id (a:mangle-id stx "with-contract-id" n)]) + (if (a:known-good-contract? c) + (values n new-id c #f) + (let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)]) + (values n new-id contract-id + (quasisyntax/loc stx + (define-values (#,contract-id) + (verify-contract 'with-contract #,c))))))))]) + (begin + (let* ([all-ids (append unprotected protected)] + [dupd-id (check-duplicate-identifier all-ids)]) + (when dupd-id + (raise-syntax-error 'with-contract + "identifier appears twice in exports" + dupd-id)) + (check-exports (append unprotected protected) expanded-bodies)) + (with-syntax ([((protected-id id contract) ...) + (map list protected-ids ids contracts)] + [(contract-def ...) (filter values contract-defs)] + [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] + [(unprotected-id ...) unprotected]) + (quasisyntax/loc stx + (begin + (define-values (unprotected-id ... id ...) + (syntax-parameterize ([current-contract-region blame-str]) + (begin-with-definitions + #,@expanded-bodies + (values unprotected-id ... protected-id ...)))) + contract-def ... + (define-syntax protected-id + (make-with-contract-transformer + (quote-syntax contract) + (quote-syntax id) + blame-str)) ...)))))] + [(_ #:type type blame (arg ...) body0 body ...) + (raise-syntax-error 'with-contract + "expected identifier for blame" + #'blame)] + [(_ #:type type blame (arg ...)) + (identifier? #'blame) + (raise-syntax-error 'with-contract + "empty body" + stx)] + [(_ #:type type blame bad-args etc ...) + (identifier? #'blame) + (raise-syntax-error 'with-contract + "expected list of identifier and/or (identifier contract)" + #'bad-args)] + [(_ #:type type args etc ...) + (not (identifier? #'args)) + (raise-syntax-error 'with-contract + "expected identifier for blame" + #'args)] + [(_ #:type type etc ...) + (not (identifier? #'type)) + (raise-syntax-error 'with-contract + "expected identifier for type" + #'type)] + [(_ #:type type blame) + (raise-syntax-error 'with-contract + "only blame" + stx)] + [(_ etc ...) + (syntax/loc stx + (with-contract #:type region etc ...))])) + +; +; +; +; ; ; ; +; ; ; +; ; ; ; ; +; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; +; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; +; ; ; +; ; ; +; ; + + ;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) (define-for-syntax (lookup-struct-info stx provide-stx) (let ([id (syntax-case stx () @@ -59,46 +332,6 @@ improve method arity mismatch contract violation error messages? provide-stx id))))) -(define-for-syntax (make-define/contract-transformer contract-id id) - (make-set!-transformer - (λ (stx) - (with-syntax ([neg-blame-str (a:build-src-loc-string stx)] - [contract-id contract-id] - [id id]) - (syntax-case stx (set!) - [(set! id arg) - (raise-syntax-error 'define/contract - "cannot set! a define/contract variable" - stx - (syntax id))] - [(f arg ...) - (syntax/loc stx - ((-contract contract-id - id - (syntax->datum (quote-syntax f)) - neg-blame-str - (quote-syntax f)) - arg - ...))] - [ident - (identifier? (syntax ident)) - (syntax/loc stx - (-contract contract-id - id - (syntax->datum (quote-syntax ident)) - neg-blame-str - (quote-syntax ident)))]))))) - -;; id->contract-src-info : identifier -> syntax -;; constructs the last argument to the -contract, given an identifier -(define-for-syntax (id->contract-src-info id) - #`(list (make-srcloc #,id - #,(syntax-line id) - #,(syntax-column id) - #,(syntax-position id) - #,(syntax-span id)) - #,(format "~s" (syntax->datum id)))) - (define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) (make-set!-transformer (let ([saved-id-table (make-hasheq)]) @@ -140,51 +373,6 @@ improve method arity mismatch contract violation error messages? ;; delay expansion until it's a good time to lift expressions: (quasisyntax/loc stx (#%expression #,stx))))))) -;; (define/contract id contract expr) -;; defines `id' with `contract'; initially binding -;; it to the result of `expr'. These variables may not be set!'d. -(define-syntax (define/contract define-stx) - (syntax-case define-stx () - [(_ name contract-expr expr) - (identifier? (syntax name)) - (with-syntax ([contract-id - (a:mangle-id define-stx - "define/contract-contract-id" - (syntax name))] - [id (a:mangle-id define-stx - "define/contract-id" - (syntax name))]) - (syntax/loc define-stx - (begin - (define contract-id contract-expr) - (define-syntax name - (make-define/contract-transformer (quote-syntax contract-id) - (quote-syntax id))) - (define id (let ([name expr]) name)) ;; let for procedure naming - )))] - [(_ name contract-expr expr) - (raise-syntax-error 'define/contract "expected identifier in first position" - define-stx - (syntax name))])) - - -; -; -; -; ; ; ; -; ; ; -; ; ; ; ; -; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; -; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; -; ; ; -; ; ; -; ; - ;; (provide/contract p/c-ele ...) ;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...) @@ -483,7 +671,7 @@ improve method arity mismatch contract violation error messages? #f (with-syntax ([field-contract-id field-contract-id] [field-contract field-contract]) - #'(define field-contract-id (verify-contract field-contract))))) + #'(define field-contract-id (verify-contract 'provide/contract field-contract))))) field-contract-ids field-contracts))] [(field-contracts ...) field-contracts] @@ -671,7 +859,7 @@ improve method arity mismatch contract violation error messages? #,@(if no-need-to-check-ctrct? (list) - (list #'(define contract-id (verify-contract ctrct)))) + (list #'(define contract-id (verify-contract 'provide/contract ctrct)))) (define-syntax id-rename (make-provide/contract-transformer (quote-syntax contract-id) (quote-syntax id) @@ -691,11 +879,6 @@ improve method arity mismatch contract violation error messages? (begin bodies ...))))])) -(define-syntax (verify-contract stx) - (syntax-case stx () - [(_ x) (a:known-good-contract? #'x) #'x] - [(_ x) #'(coerce-contract 'provide/contract x)])) - (define (make-pc-struct-type struct-name struct:struct-name . ctcs) (let-values ([(struct:struct-name _make _pred _get _set) (make-struct-type struct-name diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 4d0b8c923d..47e25f73d8 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -81,7 +81,7 @@ of the contract library does not change over time. (equal? blame (cond - [(regexp-match #rx"(^| )([^ ]*) broke" msg) + [(regexp-match #rx"(^| )(.*) broke" msg) => (λ (x) (caddr x))] [else (format "no blame in error message: \"~a\"" msg)]))) @@ -103,8 +103,8 @@ of the contract library does not change over time. (and (exn? exn) (,has-proper-blame? (exn-message exn)))))))))) - (define (test/pos-blame name expression) (test/spec-failed name expression "pos")) - (define (test/neg-blame name expression) (test/spec-failed name expression "neg")) + (define (test/pos-blame name expression) (test/spec-failed name expression "module pos")) + (define (test/neg-blame name expression) (test/spec-failed name expression "module neg")) (define (test/well-formed stx) (contract-eval @@ -126,7 +126,7 @@ of the contract library does not change over time. (contract-eval `(,test #t flat-contract? ,contract)) (test/spec-failed (format "~a fail" name) `(contract ,contract ',fail 'pos 'neg) - "pos") + "module pos") (test/spec-passed/result (format "~a pass" name) `(contract ,contract ',pass 'pos 'neg) @@ -1577,14 +1577,14 @@ of the contract library does not change over time. '(let () (define/contract i integer? #t) i) - "i") + "definition i") (test/spec-failed 'define/contract3 '(let () (define/contract i (-> integer? integer?) (lambda (x) #t)) (i 1)) - "i") + "definition i") (test/spec-failed 'define/contract4 @@ -4643,7 +4643,7 @@ so that propagation occurs. (provide/contract (x integer?)))) (eval '(require 'contract-test-suite3)) (eval 'x)) - "'contract-test-suite3") + "module 'contract-test-suite3") (test/spec-passed 'provide/contract4 @@ -4820,7 +4820,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - 'n) + "module 'n") |# (test/spec-passed @@ -4888,7 +4888,7 @@ so that propagation occurs. (define i #f) (provide/contract [i integer?]))) (eval '(require 'pos))) - "'pos") + "module 'pos") ;; this is really a positive violation, but name the module `neg' just for an addl test (test/spec-failed @@ -4899,7 +4899,7 @@ so that propagation occurs. (define i #f) (provide/contract [i integer?]))) (eval '(require 'neg))) - "'neg") + "module 'neg") ;; this test doesn't pass yet ... waiting for support from define-struct diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index bdbba39713..4e52ee536b 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -1,3 +1,4 @@ + (load-relative "loadtest.ss") (Section 'contract) @@ -75,7 +76,7 @@ (equal? blame (cond - [(regexp-match #rx"(^| )([^ ]*) broke" msg) + [(regexp-match #rx"(^| )(.*) broke" msg) => (λ (x) (caddr x))] [else (format "no blame in error message: \"~a\"" msg)]))) @@ -97,8 +98,8 @@ (and (exn? exn) (,has-proper-blame? (exn-message exn)))))))))) - (define (test/pos-blame name expression) (test/spec-failed name expression "pos")) - (define (test/neg-blame name expression) (test/spec-failed name expression "neg")) + (define (test/pos-blame name expression) (test/spec-failed name expression "module pos")) + (define (test/neg-blame name expression) (test/spec-failed name expression "module neg")) (define (test/well-formed stx) (contract-eval @@ -120,7 +121,7 @@ (contract-eval `(,test #t flat-contract? ,contract)) (test/spec-failed (format "~a fail" name) `(contract ,contract ',fail 'pos 'neg) - "pos") + "module pos") (test/spec-passed/result (format "~a pass" name) `(contract ,contract ',pass 'pos 'neg) @@ -2160,6 +2161,250 @@ +; +; +; +; ; ;;;; ; +; ;; ; ; ; +; ; ; ; ; ; +; ; ; ; ; ; +; ;; ; ;;; ;;;; ; ; ;; ;;; ; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;; +; ; ;; ; ; ; ;; ;;; ; ; ; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ; +; ; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; +; ;; ; ;;; ;;;;;;;;;; ;;; ;;; ; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;; +; +; +; + + (test/spec-passed + 'define/contract1 + '(let () + (define/contract i integer? 1) + i)) + + (test/spec-failed + 'define/contract2 + '(let () + (define/contract i integer? #t) + i) + "definition i") + + (test/spec-failed + 'define/contract3 + '(let () + (define/contract i (-> integer? integer?) (lambda (x) #t)) + (i 1)) + "definition i") + + (test/spec-failed + 'define/contract4 + '(let () + (define/contract i (-> integer? integer?) (lambda (x) 1)) + (i #f)) + "module top-level") + + (test/spec-failed + 'define/contract5 + '(let () + (define/contract (i x) (-> integer? integer?) 1) + (i #f)) + "module top-level") + + (test/spec-passed + 'define/contract6 + '(let () + (define/contract (i x) (-> integer? integer?) + (cond + [(not (integer? x)) 1] + [else (i #f)])) + (i 1))) + + (test/spec-passed + 'define/contract7 + '(let () + (define/contract (contracted-func label t) + (string? string? . -> . string?) + t) + (contracted-func + "I'm a string constant with side effects" + "ans"))) + + (test/spec-passed + 'define/contract8 + '(let () + (eval '(module contract-test-suite-define1 scheme/base + (require scheme/contract) + (define/contract x string? "a") + x)) + (eval '(require 'contract-test-suite-define1)))) + + (test/spec-failed + 'define/contract9 + '(let () + (define/contract (a n) + (-> number? number?) + (define/contract (b m) + (-> number? number?) + (+ m 1)) + (b (zero? n))) + (a 5)) + "function a") + + (test/spec-failed + 'define/contract10 + '(let () + (define/contract (a n) + (-> number? number?) + (define/contract (b m) + (-> number? number?) + #t) + (b (add1 n))) + (a 5)) + "function b") + + (test/spec-passed + 'define/contract11 + '(let () + (define/contract (f n) + (-> number? number?) + (+ n 1)) + (define/contract (g b m) + (-> boolean? number? number?) + (if b (f m) (f #t))) + (g #t 3))) + + (test/spec-failed + 'define/contract12 + '(let () + (define/contract (f n) + (-> number? number?) + (+ n 1)) + (define/contract (g b m) + (-> boolean? number? number?) + (if b (f m) (f #t))) + (g #f 3)) + "function g") + + (test/spec-failed + 'define/contract13 + '(begin + (eval '(module foo-dc13 scheme/base + (require scheme/contract) + (define/contract (foo-dc13 n) + (-> number? number?) + (+ n 1)) + (foo-dc13 #t))) + (eval '(require 'foo-dc13))) + "module 'foo-dc13") + + (test/spec-failed + 'define/contract14 + '(begin + (eval '(module foo-dc14 scheme/base + (require scheme/contract) + (provide foo-dc14) + (define/contract (foo-dc14 n) + (-> number? number?) + (+ n 1)))) + (eval '(module bar-dc14 scheme/base + (require 'foo-dc14) + (foo-dc14 #t))) + (eval '(require 'bar-dc14))) + "module 'bar-dc14") + + (test/spec-failed + 'define/contract15 + '(begin + (eval '(module foo-dc15 scheme/base + (require scheme/contract) + (provide foo-dc15) + (define/contract (foo-dc15 n) + (-> number? number?) + (+ n 1)))) + (eval '(require 'foo-dc15)) + (eval '(foo-dc15 #t))) + "module top-level") + + +; +; +; +; ; ; +; ;; +; ; ; ; ; +; ; ; ; ; +; ;;; ;;; ;;; ; ;;;; ; ;; ;;; ;; ; ;; ;;;; ; ;; ;;; ;;; ;;;; +; ; ; ; ;; ; ;; ; ; ; ; ; ;;; ; ; ;;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; +; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; +; ; ; ;;; ;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;; +; +; +; + + (test/spec-passed + 'with-contract1 + '(let () + (with-contract odd-even + ([odd? (-> number? boolean?)] + [even? (-> number? boolean?)]) + (define (odd? n) + (if (zero? n) #f (even? (sub1 n)))) + (define (even? n) + (if (zero? n) #t (odd? (sub1 n))))) + (odd? 5))) + + (test/spec-failed + 'with-contract2 + '(let () + (with-contract odd-even + ([odd? (-> number? boolean?)] + [even? (-> number? boolean?)]) + (define (odd? n) + (if (zero? n) #f (even? (sub1 n)))) + (define (even? n) + (if (zero? n) #t (odd? (sub1 n))))) + (odd? #t)) + "module top-level") + + (test/spec-failed + 'with-contract3 + '(let () + (with-contract odd-even + ([odd? (-> number? boolean?)] + [even? (-> number? boolean?)]) + (define (odd? n) + (if (zero? n) n (even? (sub1 n)))) + (define (even? n) + (if (zero? n) #t (odd? (sub1 n))))) + (odd? 4)) + "region odd-even") + + ;; Functions within the same with-contract region can call + ;; each other however they want, so here we have even? + ;; call odd? with a boolean, even though its contract in + ;; the odd-even contract says it only takes numbers. + (test/spec-passed + 'with-contract4 + '(let () + (with-contract odd-even + ([odd? (-> number? boolean?)] + [even? (-> number? boolean?)]) + (define (odd? n) + (cond + [(not (number? n)) #f] + [(zero? n) #f] + [else (even? (sub1 n))])) + (define (even? n) + (if (zero? n) #t (odd? (zero? n))))) + (odd? 5))) + + ; ; ; @@ -5380,7 +5625,7 @@ so that propagation occurs. (provide/contract (x integer?)))) (eval '(require 'contract-test-suite3)) (eval 'x)) - "'contract-test-suite3") + "module 'contract-test-suite3") (test/spec-passed 'provide/contract4 @@ -5557,7 +5802,7 @@ so that propagation occurs. (make-s 1 2) [s-a #f]))) (eval '(require 'pc11b-n))) - 'n) + "module 'n") |# (test/spec-passed @@ -5625,7 +5870,7 @@ so that propagation occurs. (define i #f) (provide/contract [i integer?]))) (eval '(require 'pos))) - "'pos") + "module 'pos") ;; this is really a positive violation, but name the module `neg' just for an addl test (test/spec-failed @@ -5636,7 +5881,7 @@ so that propagation occurs. (define i #f) (provide/contract [i integer?]))) (eval '(require 'neg))) - "'neg") + "module 'neg") ;; this test doesn't pass yet ... waiting for support from define-struct From eca59f6b1d98b59301a68c56f902f571340a5a16 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 14 Nov 2008 16:49:10 +0000 Subject: [PATCH 002/193] Missed a file. svn: r12452 --- collects/mzlib/private/contract-define.ss | 70 +++++++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 collects/mzlib/private/contract-define.ss diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss new file mode 100644 index 0000000000..d1f3ea63ed --- /dev/null +++ b/collects/mzlib/private/contract-define.ss @@ -0,0 +1,70 @@ +#lang scheme/base + +(provide define/contract) + +(require (for-syntax scheme/base) + (only-in scheme/contract contract) + (for-syntax (prefix-in a: scheme/private/contract-helpers))) + +;; First, we have the old define/contract implementation, which +;; is still used in mzlib/contract. + +(define-for-syntax (make-define/contract-transformer contract-id id) + (make-set!-transformer + (λ (stx) + (with-syntax ([neg-blame-str (a:build-src-loc-string stx)] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'define/contract + "cannot set! a define/contract variable" + stx + (syntax id))] + [(f arg ...) + (syntax/loc stx + ((contract contract-id + id + (format "definition ~a" (syntax->datum (quote-syntax f))) + neg-blame-str + (quote-syntax f)) + arg + ...))] + [ident + (identifier? (syntax ident)) + (syntax/loc stx + (contract contract-id + id + (format "definition ~a" (syntax->datum (quote-syntax ident))) + neg-blame-str + (quote-syntax ident)))]))))) + +;; (define/contract id contract expr) +;; defines `id' with `contract'; initially binding +;; it to the result of `expr'. These variables may not be set!'d. +(define-syntax (define/contract define-stx) + (syntax-case define-stx () + [(_ name contract-expr expr) + (identifier? (syntax name)) + (with-syntax ([contract-id + (a:mangle-id define-stx + "define/contract-contract-id" + (syntax name))] + [id (a:mangle-id define-stx + "define/contract-id" + (syntax name))]) + (syntax/loc define-stx + (begin + (define contract-id contract-expr) + (define-syntax name + (make-define/contract-transformer (quote-syntax contract-id) + (quote-syntax id))) + (define id (let ([name expr]) name)) ;; let for procedure naming + )))] + [(_ name contract-expr expr) + (raise-syntax-error 'define/contract "expected identifier in first position" + define-stx + (syntax name))])) + + + From c73bb99cf688801d9e24eded21102ba2f60f40ea Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Nov 2008 02:49:54 +0000 Subject: [PATCH 003/193] fix struct type immutable-field handling and checking of prop:procedure values (PR 9914 and more) svn: r12454 --- .../scribblings/reference/procedures.scrbl | 8 ++- collects/tests/mzscheme/struct.ss | 50 +++++++++++++++ src/mzscheme/src/schpriv.h | 2 +- src/mzscheme/src/struct.c | 63 ++++++++++++------- 4 files changed, 99 insertions(+), 24 deletions(-) diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl index 51554a1fd6..75a4f93b97 100644 --- a/collects/scribblings/reference/procedures.scrbl +++ b/collects/scribblings/reference/procedures.scrbl @@ -240,7 +240,7 @@ instances can be applied as procedures. In particular, when an application expression, a procedure is extracted from the instance and used to complete the procedure call. -If the @scheme[prop:procedure] property value is an integer, it +If the @scheme[prop:procedure] property value is an exact non-negative integer, it designates a field within the structure that should contain a procedure. The integer must be between @scheme[0] (inclusive) and the number of non-automatic fields in the structure type (exclusive, not @@ -317,7 +317,11 @@ is disallowed). (fish-weight wanda) (for-each wanda '(1 2 3)) (fish-weight wanda) -]} +] + +If the value supplied for the @scheme[prop:procedure] property is not +an exact non-negative integer or a procedure, the +@exnraise[exn:fail:contract].} @defproc[(procedure-struct-type? [type struct-type?]) boolean?]{ diff --git a/collects/tests/mzscheme/struct.ss b/collects/tests/mzscheme/struct.ss index dd2b96d6a8..57154481e1 100644 --- a/collects/tests/mzscheme/struct.ss +++ b/collects/tests/mzscheme/struct.ss @@ -927,4 +927,54 @@ ;; ---------------------------------------- +(let () + (define-struct foo (a [b #:mutable]) #:transparent) + (define-struct (bar foo) (f g) + #:transparent + #:property + prop:procedure + (struct-field-index f)) + (test '(1) (make-bar 1 2 list 4) 1) + (test '(foo 2 0 (0)) call-with-values + (lambda () (struct-type-info struct:foo)) + (lambda (name cnt auto-cnt acc mut imm super skipped?) + (list name cnt auto-cnt imm))) + (test '(bar 2 0 (0 1)) call-with-values + (lambda () (struct-type-info struct:bar)) + (lambda (name cnt auto-cnt acc mut imm super skipped?) + (list name cnt auto-cnt imm)))) + +(let () + (define-struct foo (a [b #:mutable] [z #:auto]) #:transparent) + (define-struct (bar foo) (f g) + #:transparent + #:property + prop:procedure + (struct-field-index f)) + (test '#&1 (make-bar 1 2 box 4) 1) + (test '(foo 2 1 (0)) call-with-values + (lambda () (struct-type-info struct:foo)) + (lambda (name cnt auto-cnt acc mut imm super skipped?) + (list name cnt auto-cnt imm))) + (test '(bar 2 0 (0 1)) call-with-values + (lambda () (struct-type-info struct:bar)) + (lambda (name cnt auto-cnt acc mut imm super skipped?) + (list name cnt auto-cnt imm)))) + +(let () + (define-struct foo (a [b #:mutable] [z #:auto]) #:transparent) + (define (try v) + (define-struct (bar foo) ([f #:mutable] g [q #:auto]) + #:property + prop:procedure + v) + 10) + (err/rt-test (try 0)) + (err/rt-test (try 2)) + (err/rt-test (try -1)) + (err/rt-test (try 'x)) + (test 10 try 1)) + +;; ---------------------------------------- + (report-errs) diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 6e0dd3fb47..1846ad86b3 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -576,7 +576,7 @@ typedef struct Scheme_Struct_Type { int num_props; /* < 0 => props is really a hash table */ Scheme_Object *proc_attr; /* int (position) or proc, only for proc_struct */ - char *immutables; + char *immutables; /* for immediate slots, only (not parent) */ Scheme_Object *guard; diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index ab0d92ec59..6434106e2b 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -865,28 +865,46 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche if (SCHEME_INTP(v)) pos = SCHEME_INT_VAL(v); - else + else if (SCHEME_BIGPOS(v)) pos = t->num_slots; /* too big */ + else + pos = -1; /* negative bignum */ - if (pos >= t->num_islots) { - scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", v); - return NULL; - } - - if (t->name_pos > 0) { + if (pos >= 0) { Scheme_Struct_Type *parent_type; - parent_type = t->parent_types[t->name_pos - 1]; - pos += parent_type->num_slots; - v = scheme_make_integer(pos); - } + if (t->name_pos > 0) + parent_type = t->parent_types[t->name_pos - 1]; + else + parent_type = NULL; + + if (pos >= (t->num_islots - (parent_type ? parent_type->num_islots : 0))) { + scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", v); + return NULL; + } + + if (parent_type) { + /* proc_attr needs to be in terms of the whole field array */ + pos += parent_type->num_slots; + v = scheme_make_integer(pos); + } + } else + v = scheme_false; /* complain below */ + } + + if (SCHEME_INTP(v) || SCHEME_PROCP(v)) { + /* ok */ + } else { + scheme_arg_mismatch("make-struct-type", + "prop:procedure value is not a procedure or exact non-negative integer: ", + orig_v); } t->proc_attr = v; if (SCHEME_INTP(v)) { long pos; - pos = SCHEME_INT_VAL(v); + pos = SCHEME_INT_VAL(orig_v); if (!t->immutables || !t->immutables[pos]) { scheme_arg_mismatch("make-struct-type", "field is not specified as immutable for a prop:procedure index: ", @@ -1676,7 +1694,7 @@ static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object ims = scheme_null; if (stype->immutables) { int i; - for (i = stype->num_islots; i--; ) { + for (i = stype->num_islots - (parent ? parent->num_islots : 0); i--; ) { if (stype->immutables[i]) ims = scheme_make_pair(scheme_make_integer(i), ims); } @@ -2856,19 +2874,20 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base || (proc_attr && SCHEME_INTP(proc_attr))) { Scheme_Object *l, *a; char *ims; - int n, p; + int n, ni, p; n = struct_type->num_slots; - if (parent_type) + ni = struct_type->num_islots; + if (parent_type) { n -= parent_type->num_slots; + ni -= parent_type->num_islots; + } ims = (char *)scheme_malloc_atomic(n); memset(ims, 0, n); if (proc_attr && SCHEME_INTP(proc_attr)) { p = SCHEME_INT_VAL(proc_attr); - if (parent_type) - p += parent_type->num_slots; - if (p < struct_type->num_slots) + if (p < ni) ims[p] = 1; } @@ -2877,12 +2896,14 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base if (SCHEME_INTP(a)) p = SCHEME_INT_VAL(a); else - p = struct_type->num_slots; /* too big */ + p = n; /* too big */ - if (p >= struct_type->num_islots) { + if (p >= n) { scheme_raise_exn(MZEXN_FAIL_CONTRACT, "make-struct-type: index %V for immutable field >= initialized-field count %d in list: %V", - a, struct_type->num_islots, immutable_pos_list); + a, + ni, + immutable_pos_list); return NULL; } From 1d353330265cfa1c1e38b8c1b7fe77ef98b19606 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 15 Nov 2008 08:50:16 +0000 Subject: [PATCH 004/193] Welcome to a new PLT day. svn: r12455 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 37859d3cfd..908da5f1ba 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "14nov2008") +#lang scheme/base (provide stamp) (define stamp "15nov2008") From c0fb0086e9b85982eaa5045325514697a5f0f18c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Nov 2008 13:42:11 +0000 Subject: [PATCH 005/193] =?UTF-8?q?fix=20R6RS=20boolean=3D=3F=20and=20symb?= =?UTF-8?q?ol=3D=3F?= svn: r12456 --- collects/rnrs/base-6.ss | 20 ++++++++++++++++++-- collects/tests/r6rs/base.sls | 4 ++++ 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index 7868e58930..4084ec3a06 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -76,7 +76,7 @@ [r6rs:string->number string->number]) ;; 11.8 - not boolean? boolean=? + not boolean? (rename-out [r6rs:boolean=? boolean=?]) ;; 11.9 (rename-out [r5rs:pair? pair?] @@ -123,7 +123,7 @@ [r5rs:for-each for-each]) ;; 11.10 - symbol? symbol=? + symbol? (rename-out [r6rs:symbol=? symbol=?]) string->symbol symbol->string ;; 11.11 @@ -349,6 +349,22 @@ (and (regexp-match? rx:number s) (string->number (regexp-replace* #rx"[|][0-9]+" s ""))))) +(define r6rs:symbol=? + (case-lambda + [(a b) (symbol=? a b)] + [(a b . rest) (and (symbol=? a b) + (andmap (lambda (s) + (symbol=? a s)) + rest))])) + +(define r6rs:boolean=? + (case-lambda + [(a b) (boolean=? a b)] + [(a b . rest) (and (boolean=? a b) + (andmap (lambda (s) + (boolean=? a s)) + rest))])) + (define-syntax-rule (make-mapper what for for-each in-val val-length val->list list->result) (case-lambda [(proc val) (list->result diff --git a/collects/tests/r6rs/base.sls b/collects/tests/r6rs/base.sls index f5fbb6fcc1..d39521ad9e 100644 --- a/collects/tests/r6rs/base.sls +++ b/collects/tests/r6rs/base.sls @@ -1005,6 +1005,8 @@ (test (boolean=? #t #t) #t) (test (boolean=? #t #f) #f) (test (boolean=? #f #t) #f) + (test (boolean=? #t #t #f) #f) + (test (boolean=? #t #t #t #t) #t) ;; 11.9 (test (pair? '(a . b)) #t) @@ -1126,6 +1128,8 @@ (test (symbol=? 'a 'a) #t) (test (symbol=? 'a 'A) #f) (test (symbol=? 'a 'b) #f) + (test (symbol=? 'a 'a 'b) #f) + (test (symbol=? 'a 'a 'a 'a) #t) (test (symbol->string 'flying-fish) "flying-fish") From 015503bde3d5bfb125231f8ef096419a741672fb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Nov 2008 16:51:58 +0000 Subject: [PATCH 006/193] trigger GCs based on number of allocated bitmaps under Windows, not just their sizes svn: r12457 --- src/wxcommon/wxGC.cxx | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/src/wxcommon/wxGC.cxx b/src/wxcommon/wxGC.cxx index 31faa718c3..31f523775d 100644 --- a/src/wxcommon/wxGC.cxx +++ b/src/wxcommon/wxGC.cxx @@ -374,7 +374,11 @@ char *gc::gcGetName() { forces a GC more frequently than might otherwise happen as the total size of bitmaps grows. */ -static long total, accum = 1024 * 1024 * 5; +#define INIT_ACCUM_SIZE 1024 * 1024 * 5 +#define INIT_ACCUM_COUNT 1000 + +static long total, accum = INIT_ACCUM_SIZE; +static int total_count, accum_count = INIT_ACCUM_COUNT; void *GC_malloc_accounting_shadow(long a) { @@ -383,10 +387,24 @@ void *GC_malloc_accounting_shadow(long a) a = sizeof(long); total += a; accum -= a; + total_count += 1; + accum_count -= 1; if (accum <= 0) { GC_gcollect(); accum = total >> 1; + if (accum < INIT_ACCUM_SIZE) + accum = INIT_ACCUM_SIZE; } +#ifdef wx_msw + /* Under Windows, the number of bitmaps matters, even if + they're small. */ + if (accum_count <= 0) { + GC_gcollect(); + accum_count = total_count >> 1; + if (accum_count < INIT_ACCUM_COUNT) + accum_count = INIT_ACCUM_COUNT; + } +#endif p = (long *)GC_malloc_atomic(a); *p = a; return (void *)p; @@ -397,5 +415,7 @@ void GC_free_accounting_shadow(void *p) if (p) { total -= *(long *)p; accum += *(long *)p; + total_count -= 1; + accum_count += 1; } } From 69fdabf0a0cbb9c4e8ae72ce8788b5924da6ca88 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Nov 2008 18:54:30 +0000 Subject: [PATCH 007/193] fix {s,u}int-list->bytevector (PR 9916) svn: r12459 --- collects/rnrs/bytevectors-6.ss | 7 ++++--- collects/tests/r6rs/bytevectors.sls | 15 +++++++++++++++ 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/collects/rnrs/bytevectors-6.ss b/collects/rnrs/bytevectors-6.ss index dc26a0e069..d3944e9380 100644 --- a/collects/rnrs/bytevectors-6.ss +++ b/collects/rnrs/bytevectors-6.ss @@ -311,16 +311,17 @@ (bytevector->int-list 'bytevector->sint-list bytevector-sint-ref bv endianness size)) (define (int-list->bytevector who signed? set l endianness size) - (unless (list? l) + (unless (mlist? l) (raise-type-error who "list" l)) (check-endian endianness) (unless (exact-positive-integer? size) (raise-type-error who "exact positive integer" size)) - (let* ([len (length l)] + (let* ([l (mlist->list l)] + [len (length l)] [bv (make-bytes (* size len))]) (for ([v (in-list l)] [k (in-naturals)]) - (set l k v endianness size)) + (set bv (* k size) v endianness size)) bv)) (define (uint-list->bytevector l endianness size) diff --git a/collects/tests/r6rs/bytevectors.sls b/collects/tests/r6rs/bytevectors.sls index f2b00a75a9..87fc507a1b 100644 --- a/collects/tests/r6rs/bytevectors.sls +++ b/collects/tests/r6rs/bytevectors.sls @@ -277,6 +277,21 @@ (test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) (bytevector->uint-list b 'little 2)) '(513 65283 513 513)) + (test (bytevector->u8-list + (uint-list->bytevector '(513 65283 513 513) 'little 2)) + '(1 2 3 255 1 2 1 2)) + (test (bytevector->u8-list + (uint-list->bytevector '(513 65283 513 513) 'big 2)) + '(2 1 255 3 2 1 2 1)) + (test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (bytevector->sint-list b 'little 2)) + '(513 -253 513 513)) + (test (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1)))) + (bytevector->sint-list b 'big 2)) + '(513 -253 513 513)) + (test (bytevector->u8-list + (sint-list->bytevector '(513 -253 513 513) 'little 2)) + '(1 2 3 255 1 2 1 2)) (test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) (bytevector->sint-list b 'little 2)) '(513 -253 513 513)) From 1e5caacddeb4205868a99f9433a78ab3cf552303 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 16 Nov 2008 08:50:11 +0000 Subject: [PATCH 008/193] Welcome to a new PLT day. svn: r12460 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 908da5f1ba..a1bf00e010 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "15nov2008") +#lang scheme/base (provide stamp) (define stamp "16nov2008") From 4254ad8afa837c23055bfcfbfd3796573dbcab07 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 16 Nov 2008 17:27:41 +0000 Subject: [PATCH 009/193] add support for rotated cards in games/cards svn: r12461 --- collects/games/cards/card-class.ss | 134 +++++++++++++++++++++++------ collects/games/cards/cards.scrbl | 51 ++++++++--- collects/games/cards/classes.ss | 64 +++++++++----- collects/games/cards/make-cards.ss | 25 +----- 4 files changed, 196 insertions(+), 78 deletions(-) diff --git a/collects/games/cards/card-class.ss b/collects/games/cards/card-class.ss index 526642bd1f..1f9330efd1 100644 --- a/collects/games/cards/card-class.ss +++ b/collects/games/cards/card-class.ss @@ -2,9 +2,11 @@ (module card-class mzscheme (require mzlib/class mzlib/class100 + mzlib/shared (prefix mred: mred) "snipclass.ss" - "region.ss") + "region.ss" + (only scheme/base for in-range)) (provide card%) @@ -28,18 +30,43 @@ (thunk) (send dc set-clipping-region r)))) + (define (rotate-bm bm cw?) + (let ([w (send bm get-width)] + [h (send bm get-height)]) + (let ([bm2 (make-object mred:bitmap% h w)] + [s (make-bytes (* w h 4))] + [s2 (make-bytes (* h w 4))]) + (send bm get-argb-pixels 0 0 w h s) + (for ([i (in-range w)]) + (for ([j (in-range h)]) + (let ([src-pos (* (+ i (* j w)) 4)]) + (bytes-copy! s2 + (if cw? + (* (+ (- (- h j) 1) (* i h)) 4) + (* (+ j (* (- (- w i) 1) h)) 4)) + s src-pos (+ src-pos 4))))) + (let ([dc (make-object mred:bitmap-dc% bm2)]) + (send dc set-argb-pixels 0 0 h w s2) + (send dc set-bitmap #f)) + bm2))) + + (define orientations (shared ([o (list* 'n 'e 's 'w o)]) o)) + (define (find-head l s) + (if (eq? (car l) s) + l + (find-head (cdr l) s))) + (define card% - (class100 mred:snip% (-suit-id -value -width -height -front -back -semi-front -semi-back -mk-dim-front -mk-dim-back) + (class100 mred:snip% (-suit-id -value -width -height -front -back -mk-dim-front -mk-dim-back -rotated-bms) (inherit set-snipclass set-count get-admin) (private-field [suit-id -suit-id] [value -value] [width -width] [height -height] + [rotated 'n] [front -front] [back -back] - [semi-front -semi-front] - [semi-back -semi-back] [mk-dim-front -mk-dim-front] [mk-dim-back -mk-dim-back] [dim-front #f] @@ -51,13 +78,20 @@ [can-move? #t] [snap-back? #f] [stay-region #f] - [home-reg #f]) + [home-reg #f] + [rotated-bms -rotated-bms]) (private [refresh (lambda () (let ([a (get-admin)]) (when a (send a needs-update this 0 0 width height))))] + [refresh-size + (lambda () + (let ([a (get-admin)]) + (when a + (send a resized this #f))) + (refresh))] [check-dim (lambda () (when is-dim? @@ -65,7 +99,18 @@ (unless dim-back (set! dim-back (mk-dim-back))) (unless dim-front - (set! dim-front (mk-dim-front))))))]) + (set! dim-front (mk-dim-front))))))] + [get-rotated + (lambda (bm dir) + (if (eq? dir 'n) + bm + (or (hash-table-get rotated-bms (cons dir bm) #f) + (let ([rotated-bm (case dir + [(w) (rotate-bm bm #f)] + [(e) (rotate-bm bm #t)] + [(s) (rotate-bm (rotate-bm bm #t) #t)])]) + (hash-table-put! rotated-bms (cons dir bm) rotated-bm) + rotated-bm))))]) (public [face-down? (lambda () flipped?)] [flip @@ -84,6 +129,25 @@ (unless (eq? is-dim? (and v #t)) (set! is-dim? (and v #t)) (refresh))])] + [orientation (lambda () (case rotated + [(n) 0] + [(e) 270] + [(w) 90] + [(s) 180]))] + [rotate (lambda (mode) + (let ([delta (case mode + [(0 360) 0] + [(cw -90 270) 1] + [(ccw 90 -270) 3] + [(180 -180) 2] + [else (error 'rotate "bad mode: ~e" mode)])]) + (set! rotated (list-ref (find-head orientations rotated) delta)) + (if (odd? delta) + (let ([w width]) + (set! width height) + (set! height w) + (refresh-size)) + (refresh))))] [get-suit-id (lambda () suit-id)] [get-suit @@ -133,26 +197,44 @@ [draw (lambda (dc x y left top right bottom dx dy draw-caret) (check-dim) - (if semi-flipped? - (send dc draw-bitmap (if flipped? semi-back semi-front) (+ x (/ width 4)) y) - (with-card-region - dc x y width height - (lambda () - (send dc draw-bitmap - (if flipped? - (if is-dim? dim-back back) - (if is-dim? dim-front front)) - x y)))))] - [copy (lambda () (make-object card% suit-id value width height - front back semi-front semi-back - (lambda () - (unless dim-front - (set! dim-front (mk-dim-front))) - dim-front) - (lambda () - (unless dim-back - (set! dim-back (mk-dim-back))) - dim-back)))]) + (let ([do-draw + (lambda (x y) + (with-card-region + dc x y width height + (lambda () + (send dc draw-bitmap + (let ([bm (if flipped? + (if is-dim? dim-back back) + (if is-dim? dim-front front))]) + (get-rotated bm rotated)) + x y))))]) + (if semi-flipped? + (let-values ([(sx sy) (send dc get-scale)]) + (case rotated + [(n s) + (send dc set-scale (/ sx 2) sy) + (do-draw (+ (* 2 x) (/ width 2)) y) + (send dc set-scale sx sy)] + [(e w) + (send dc set-scale sx (/ sy 2)) + (do-draw x (+ (* 2 y) (/ height 2))) + (send dc set-scale sx sy)])) + (do-draw x y))))] + [copy (lambda () + (let ([rotated? (memq rotated '(e w))]) + (make-object card% suit-id value + (if rotated? height width) + (if rotated? width height ) + front back + (lambda () + (unless dim-front + (set! dim-front (mk-dim-front))) + dim-front) + (lambda () + (unless dim-back + (set! dim-back (mk-dim-back))) + dim-back) + rotated-bms)))]) (private-field [save-x (box 0)] [save-y (box 0)]) diff --git a/collects/games/cards/cards.scrbl b/collects/games/cards/cards.scrbl index 7eda556041..556a0a292f 100644 --- a/collects/games/cards/cards.scrbl +++ b/collects/games/cards/cards.scrbl @@ -17,8 +17,9 @@ module provides a toolbox for creating cards games.} table<%>]{ Returns a table. The table is named by @scheme[title], and it is -@scheme[w] cards wide and @scheme[h] cards high. The table is not -initially shown; @scheme[(send table show #t)] shows it.} +@scheme[w] cards wide and @scheme[h] cards high (assuming a standard +card of 71 by 96 pixels). The table is not initially shown; +@scheme[(send table show #t)] shows it.} @defproc[(make-deck) (listof card<%>)]{ @@ -37,7 +38,7 @@ Returns a single card given a bitmap for the front, an optional bitmap for the back, and arbitrary values for the card's suit and value (which are returned by the card's @method[card<%> get-value] and @method[card<%> get-suit-id] methods). All provided bitmaps should be -71 by 96 pixels.} +the same size.} @defproc[(shuffle-list [lst list?] [n exact-nonnegative-integer?]) list?]{ @@ -171,8 +172,9 @@ Create an instance with @scheme[make-table]. void?]{ Adds @scheme[cards] to fill the region @scheme[r], fanning them out - bottom-right to top-left. The region @scheme[r] does not have to be - added to the table.} + bottom-right to top-left, assuming that all cards in @scheme[cards] + have the same width and height. The region @scheme[r] does not have + to be added to the table.} @defmethod[(remove-card [card (is-a?/c card<%>)]) void?]{ @@ -227,6 +229,19 @@ Removes @scheme[card] from the table.} Like @method[table<%> flip-cards], but only for @scheme[card] or elements of @scheme[cards] that are currently face down/up.} +@defmethod*[([(rotate-card [card (is-a?/c card<%>)] + [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) + void?] + [(rotate-cards [cards (listof (is-a?/c card<%>))] + [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) + void?])]{ + + Rotates @scheme[card] or all @scheme[cards] (at once, currently + without animation, but animation may be added in the future). + The center of each card is kept in place, except that the card is + moved as necessary to keep it on the table. See @xmethod[card<%> + rotate] for information on @scheme[mode].} + @defmethod*[([(card-to-front [card (is-a?/c card<%>)]) void?] [(card-to-back [card (is-a?/c card<%>)]) void?])]{ @@ -384,13 +399,13 @@ Create instances with @scheme[make-deck] or @scheme[make-card]. @defmethod[(card-width) exact-nonnegative-integer?]{ - Returns the width of the card in pixels. All cards have the same - width.} + Returns the width of the card in pixels. If the card is rotated 90 or + 270 degrees, the result is the card's original height.} @defmethod[(card-height) exact-nonnegative-integer?]{ - Returns the height of the card in pixels. All cards have the same - height.} + Returns the height of the card in pixels. If the card is rotated 90 or + 270 degrees, the result is the card's original width.} @defmethod[(flip) void?]{ @@ -409,6 +424,22 @@ Create instances with @scheme[make-deck] or @scheme[make-card]. Returns @scheme[#t] if the card is currently face down.} +@defmethod[(rotate [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) void?]{ + + Rotates the card. Unlike using the @xmethod[table<%> rotate-card] method, + the card's top-left position is kept in place. + + If @scheme[mode] is @scheme['cw], the card is + rotated clockwise; if @scheme[mode] is @scheme['ccw], the card is + rotated counter-clockwise; if @scheme[mode] is one of the allowed + numbers, the card is rotated the corresponding amount in degrees + counter-clockwise.} + +@defmethod[(orientation) (or/c 0 90 180 270)]{ + + Returns the orientation of the card, where @scheme[0] corresponds to + its initial state, @scheme[90] is rotated 90 degrees counter-clockwise, and so on.} + @defmethod[(get-suit-id) any/c]{ Normally returns @scheme[1], @scheme[2], @scheme[3], or @scheme[4] @@ -476,7 +507,7 @@ Create instances with @scheme[make-deck] or @scheme[make-card]. @defmethod*[([(dim) boolean?] [(dim [can? any/c]) void?])]{ - Gets/sets a hilite on the card, whichis rendered by drawing it dimmer + Gets/sets a hilite on the card, which is rendered by drawing it dimmer than normal.} @defmethod[(copy) (is-a?/c card<%>)]{ diff --git a/collects/games/cards/classes.ss b/collects/games/cards/classes.ss index 7c8444d0e6..7016f4bd53 100644 --- a/collects/games/cards/classes.ss +++ b/collects/games/cards/classes.ss @@ -519,6 +519,27 @@ (flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))) (flip-step (lambda () (for-each (lambda (c) (send c flip)) cards))) (flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))))))] + [rotate-card + (lambda (card mode) (rotate-cards (list card) mode))] + [rotate-cards + (lambda (cards mode) + (begin-card-sequence) + (let ([tw (table-width)] + [th (table-height)]) + (map (lambda (c) + (let ([w (send c card-width)] + [h (send c card-height)]) + (send c rotate mode) + (let ([w2 (send c card-width)] + [h2 (send c card-height)] + [x (box 0)] + [y (box 0)]) + (send pb get-snip-location c x y) + (send pb move-to c + (min (max 0 (+ (unbox x) (/ (- w w2) 2))) (- tw w2)) + (min (max 0 (+ (unbox y) (/ (- h h2) 2))) (- th h2)))))) + cards) + (end-card-sequence)))] [card-face-up (lambda (card) (cards-face-up (list card)))] @@ -695,27 +716,28 @@ (send pb only-front-selected)))] [position-cards-in-region (lambda (cards r set) - (let-values ([(x y w h) (send pb get-region-box r)] - [(len) (sub1 (length cards))] - [(cw ch) (values (send back get-width) - (send back get-height))]) - (let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))] - [pw (pretty cw)] - [ph (pretty ch)]) - (let-values ([(x w) (if (> w pw) - (values (+ x (/ (- w pw) 2)) pw) - (values x w))] - [(y h) (if (> h ph) - (values (+ y (/ (- h ph) 2)) ph) - (values y h))]) - (position-cards cards x y - (lambda (p) - (if (zero? len) - (values (/ (- w cw) 2) - (/ (- h ch) 2)) - (values (* (- len p) (/ (- w cw) len)) - (* (- len p) (/ (- h ch) len))))) - set)))))]) + (unless (null? cards) + (let-values ([(x y w h) (send pb get-region-box r)] + [(len) (sub1 (length cards))] + [(cw ch) (values (send (car cards) get-width) + (send (car cards) get-height))]) + (let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))] + [pw (pretty cw)] + [ph (pretty ch)]) + (let-values ([(x w) (if (> w pw) + (values (+ x (/ (- w pw) 2)) pw) + (values x w))] + [(y h) (if (> h ph) + (values (+ y (/ (- h ph) 2)) ph) + (values y h))]) + (position-cards cards x y + (lambda (p) + (if (zero? len) + (values (/ (- w cw) 2) + (/ (- h ch) 2)) + (values (* (- len p) (/ (- w cw) len)) + (* (- len p) (/ (- h ch) len))))) + set))))))]) (super-new [label title] [style '(metal no-resize-border)]) (begin (define c (make-object mred:editor-canvas% this #f '(no-vscroll no-hscroll))) diff --git a/collects/games/cards/make-cards.ss b/collects/games/cards/make-cards.ss index 9317e79039..38da0dcbd4 100644 --- a/collects/games/cards/make-cards.ss +++ b/collects/games/cards/make-cards.ss @@ -9,15 +9,6 @@ (define (get-bitmap file) (make-object mred:bitmap% file)) - (define (make-semi bm-in w h) - (let* ([bm (make-object mred:bitmap% (floor (/ w 2)) h)] - [mdc (make-object mred:bitmap-dc%)]) - (send mdc set-bitmap bm) - (send mdc set-scale 0.5 1) - (send mdc draw-bitmap bm-in 0 0) - (send mdc set-bitmap #f) - bm)) - (define (make-dim bm-in) (let ([w (send bm-in get-width)] [h (send bm-in get-height)]) @@ -46,11 +37,6 @@ (define back (get-bitmap (here "card-back.png"))) - (define semi-back - (let ([w (send back get-width)] - [h (send back get-height)]) - (make-semi back w h))) - (define dim-back (make-dim back)) @@ -74,9 +60,9 @@ value w h front back - (make-semi front w h) semi-back (lambda () (make-dim front)) - (lambda () dim-back)) + (lambda () dim-back) + (make-hash-table 'equal)) (vloop (sub1 value)))))))))) (define (make-card front-bm back-bm suit-id value) @@ -87,12 +73,9 @@ value w h front-bm (or back-bm back) - (make-semi front-bm w h) - (if back-bm - (make-semi back-bm w h) - semi-back) (lambda () (make-dim front-bm)) (lambda () (if back-bm (make-dim back) - dim-back)))))) + dim-back)) + (make-hash-table 'equal))))) From 4e8d06087330681c32618799e6ab1e55b143dea2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 16 Nov 2008 19:37:47 +0000 Subject: [PATCH 010/193] update version numbers for the v4.1.3 release svn: r12463 --- src/mzscheme/src/schvers.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 4dab675642..809edc18dd 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.2.5" +#define MZSCHEME_VERSION "4.1.3.1" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 -#define MZSCHEME_VERSION_Z 2 -#define MZSCHEME_VERSION_W 5 +#define MZSCHEME_VERSION_Z 3 +#define MZSCHEME_VERSION_W 1 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) From dfd62c1e926d512f40c8b047130849a76905c99f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 17 Nov 2008 01:13:43 +0000 Subject: [PATCH 011/193] removed redundant double-quotes from error messages svn: r12465 --- collects/handin-server/checker.ss | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index b6acefa943..a80d3ff831 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -78,7 +78,7 @@ (let ([line (bytes->string/utf-8 line)]) (unless (or (< (string-length line) len) (< (string-width line) len)) - (error* "~a \"~a\" in \"~a\" is longer than ~a characters" + (error* "~a \"~a\" in ~a is longer than ~a characters" (if n (format "Line #~a" n) "The line") (regexp-replace #rx"^[ \t]*(.*?)[ \t]*$" line "\\1") (currently-processed-file-name) @@ -148,7 +148,8 @@ (define current-processed-file ; set when processing multi-file submissions (make-parameter #f)) (define (currently-processed-file-name) - (or (current-processed-file) "your code")) + (let ([c (current-processed-file)]) + (if c (format "\"~a\"" c) "your code"))) (define (input->process->output maxwidth textualize? untabify? bad-re) (let loop ([n 1]) @@ -164,7 +165,7 @@ [line (if (and untabify? (regexp-match? #rx"\t" line)) (untabify line) line)]) (when (and bad-re (regexp-match? bad-re line)) - (error* "You cannot use \"~a\" in \"~a\"!~a" + (error* "You cannot use \"~a\" in ~a!~a" (if (regexp? bad-re) (object-name bad-re) bad-re) (currently-processed-file-name) (if textualize? "" (format " (line ~a)" n)))) From b07b874e2eff8d9258249f21c08818cc57872b42 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 17 Nov 2008 01:25:46 +0000 Subject: [PATCH 012/193] scheme/load in guide svn: r12466 --- collects/scribblings/guide/guide.scrbl | 6 + collects/scribblings/guide/modules.scrbl | 9 +- collects/scribblings/guide/namespaces.scrbl | 132 ++++++++++++++++++++ collects/scribblings/guide/welcome.scrbl | 4 +- 4 files changed, 143 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/guide/guide.scrbl b/collects/scribblings/guide/guide.scrbl index 06f277bf85..8cb705429f 100644 --- a/collects/scribblings/guide/guide.scrbl +++ b/collects/scribblings/guide/guide.scrbl @@ -92,6 +92,12 @@ downloadable packages contributed by PLT Scheme users. #:date "2004" #:url "http://www.cs.utah.edu/plt/publications/oopsla04-gff.pdf") + (bib-entry #:key "Flatt02" + #:author "Matthew Flatt" + #:title "Composable and Compilable Macros: You Want it When?" + #:location "International Conference on Functional Programming" + #:date "2002") + (bib-entry #:key "Flatt06" #:author "Matthew Flatt, Robert Bruce Findler, and Matthias Felleisen" #:title "Scheme with Classes, Mixins, and Traits (invited tutorial)" diff --git a/collects/scribblings/guide/modules.scrbl b/collects/scribblings/guide/modules.scrbl index 7b3677d0d7..f5212c8893 100644 --- a/collects/scribblings/guide/modules.scrbl +++ b/collects/scribblings/guide/modules.scrbl @@ -5,12 +5,9 @@ @title[#:tag "modules" #:style 'toc]{Modules} -Scheme definitions and expressions are normally written inside of a -module. Although a @tech{REPL} evaluates definitions and expressions outside -of a module for exploration and debugging purposes, and although -@scheme[load] can evaluate definitions and expressions from a file as -if they appeared in a @tech{REPL} interaction, code that is meant to last for -more than a few seconds belongs in a module. + +Modules let you organize Scheme code into multiple files and reusable +libraries. @local-table-of-contents[] diff --git a/collects/scribblings/guide/namespaces.scrbl b/collects/scribblings/guide/namespaces.scrbl index a391966ecf..2e8e23c84a 100644 --- a/collects/scribblings/guide/namespaces.scrbl +++ b/collects/scribblings/guide/namespaces.scrbl @@ -385,3 +385,135 @@ example, since the enclosing module requires instance of @schememodname[scheme/class]. Moreover, that instance is the same as the one imported into the module, so the class datatype is shared. + +@; ---------------------------------------------------------------------- + +@section[#:tag "load"]{Scripting Evaluation and Using @scheme[load]} + +Historically, Scheme and Lisp systems did not offer module +systems. Instead, large programs were built by essentially scripting +the @tech{REPL} to evaluate program fragments in a particular order. +While @tech{REPL} scripting turns out to be a bad way to structure +programs and libraries, it is still sometimes a useful capability. + +@margin-note{Describing a program via @scheme[load] interacts +especially badly with macro-defined language extensions +@cite["Flatt02"].} + +The @scheme[load] function runs a @tech{REPL} script by +@scheme[read]ing S-expressions from a file, one by one, and passing +them to @scheme[eval]. If a file @filepath{place.scm} contains + +@schemeblock[ +(define city "Salt Lake City") +(define state "Utah") +(printf "~a, ~a\n" city state) +] + +then it can be loaded in a @tech{REPL}: + +@interaction[ +(eval:alts (load "place.scm") (begin (define city "Salt Lake City") + (printf "~a, Utah\n" city))) +city +] + +Since @scheme[load] uses @scheme[eval], however, a module like the +following generally will not work---for the same reasons described in +@secref["namespaces"]: + +@schememod[ +scheme + +(define there "Utopia") + +(load "here.scm") +] + +The current namespace for evaluating the content of +@filepath{here.scm} is likely to be empty; in any case, you cannot get +@scheme[there] from @filepath{here.scm}. Also, any definitions in +@filepath{here.scm} will not become visible for use within the module; +after all, the @scheme[load] happens dynamically, while references to +identifiers within the module are resolved lexically, and therefore +statically. + +Unlike @scheme[eval], @scheme[load] does not accept a namespace +argument. To supply a namespace to @scheme[load], set the +@scheme[current-namespace] parameter. The following example evaluates +the expressions in @filepath{here.scm} using the bindings of the +@schememodname[scheme/base] module: + +@schememod[ +scheme + +(parameterize ([current-namespace (make-base-namespace)]) + (load "here.scm")) +] + +You can even use @scheme[namespace-anchor->namespace] to make the +bindings of the enclosing module accessible for dynamic evaluation. In +the following example, when @filepath{here.scm} is @scheme[load]ed, it +can refer to @scheme[there] as well as the bindings of +@schememodname[scheme]: + +@schememod[ +scheme + +(define there "Utopia") + +(define-namespace-anchor a) +(parameterize ([current-namespace (namespace-anchor->namespace a)]) + (load "here.scm")) +] + +Still, if @filepath{here.scm} defines any identifiers, the definitions +cannot be directly (i.e., statically) referenced by in the enclosing +module. + +The @schememodname[scheme/load] module language is different from +@schememodname[scheme] or @schememodname[scheme/base]. A module using +@schememodname[scheme/load] treats all of its content as dynamic, +passing each form in the module body to @scheme[eval] (using a +namespace that is initialized with @schememodname[scheme]). As a +result, uses of @scheme[eval] and @scheme[load] in the module body see +the same dynamic namespace as immediate body forms. For example, if +@filepath{here.scm} contains + +@schemeblock[ +(define here "Morporkia") +(define (go!) (set! here there)) +] + +then running + +@schememod[ +scheme/load + +(define there "Utopia") + +(load "here.scm") + +(go!) +(printf "~a\n" here) +] + +prints ``Utopia''. + +Drawbacks of using @schememodname[scheme/load] include reduced +error checking, tool support, and performance. For example, with the +program + +@schememod[ +scheme/load + +(define good 5) +(printf "running\n") +good +bad +] + +DrScheme's @onscreen{Check Syntax} tool cannot tell that the second +@scheme[good] is a reference to the first, and the unbound reference +to @scheme[bad] is reported only at run time instead of rejected +syntactically. diff --git a/collects/scribblings/guide/welcome.scrbl b/collects/scribblings/guide/welcome.scrbl index dde5dfa79e..ca68a82a1c 100644 --- a/collects/scribblings/guide/welcome.scrbl +++ b/collects/scribblings/guide/welcome.scrbl @@ -198,11 +198,11 @@ tempted to put just (substring str 0 5)) ] -into @filepath{piece.ss} and run @exec{mzscheme} with +into @filepath{piece.scm} and run @exec{mzscheme} with @interaction[ #:eval piece-eval -(eval:alts (load "piece.ss") (void)) +(eval:alts (load "piece.scm") (void)) (piece "howdy universe") ] From e4da627da938cba9b4b0fe4503da47033ad6de8d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 17 Nov 2008 08:50:12 +0000 Subject: [PATCH 013/193] Welcome to a new PLT day. svn: r12468 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index a1bf00e010..62f0e8c300 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "16nov2008") +#lang scheme/base (provide stamp) (define stamp "17nov2008") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 360fadb38c..f26316da27 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Mon, 17 Nov 2008 14:32:15 +0000 Subject: [PATCH 014/193] change 'list' contract to (listof any) svn: r12469 --- collects/lang/private/beginner-funs.ss | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss index e82123d6c1..83562ce7e0 100644 --- a/collects/lang/private/beginner-funs.ss +++ b/collects/lang/private/beginner-funs.ss @@ -278,18 +278,18 @@ ((beginner-append append) ((listof any) (listof any) (listof any) ... -> (listof any)) "to create a single list from several, by juxtaposition of the items") - (length (list -> number) + (length ((listof any) -> number) "to compute the number of items on a list") - (memq (any list -> (union false list)) + (memq (any (listof any) -> (union false list)) "to determine whether some value is on some list" " (comparing values with eq?)") - (memv (any list -> (union false list)) + (memv (any (listof any) -> (union false list)) "to determine whether some value is on the list" " (comparing values with eqv?)") - ((beginner-member member) (any list -> boolean) + ((beginner-member member) (any (listof any)-> boolean) "to determine whether some value is on the list" " (comparing values with equal?)") - (reverse (list -> list) + (reverse ((listof any) -> list) "to create a reversed version of a list") (assq (X (listof (cons X Y)) -> (union false (cons X Y))) "to determine whether some item is the first item of a pair" From 28ff8eca7e081767eac7f1c11ac96612a21a5be1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 17 Nov 2008 17:05:49 +0000 Subject: [PATCH 015/193] fix game card-layout method to call correct method svn: r12473 --- collects/games/cards/classes.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/games/cards/classes.ss b/collects/games/cards/classes.ss index 7016f4bd53..ee828faf87 100644 --- a/collects/games/cards/classes.ss +++ b/collects/games/cards/classes.ss @@ -719,8 +719,8 @@ (unless (null? cards) (let-values ([(x y w h) (send pb get-region-box r)] [(len) (sub1 (length cards))] - [(cw ch) (values (send (car cards) get-width) - (send (car cards) get-height))]) + [(cw ch) (values (send (car cards) card-width) + (send (car cards) card-height))]) (let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))] [pw (pretty cw)] [ph (pretty ch)]) From 54429dc56b7d5283461cc1d16acc7e65b41feee7 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 17 Nov 2008 17:07:51 +0000 Subject: [PATCH 016/193] Response/basic bug svn: r12474 --- .../tests/web-server/private/response-test.ss | 38 ++++++++++++++++++- collects/web-server/http/response.ss | 10 +++++ 2 files changed, 47 insertions(+), 1 deletion(-) diff --git a/collects/tests/web-server/private/response-test.ss b/collects/tests/web-server/private/response-test.ss index 325124ec48..89b09e6892 100644 --- a/collects/tests/web-server/private/response-test.ss +++ b/collects/tests/web-server/private/response-test.ss @@ -28,6 +28,34 @@ (test-suite "output-response" + (test-suite + "response/basic" + (test-equal? "response/basic" + (output output-response + (make-response/basic 404 "404" (current-seconds) #"text/html" + (list))) + #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n") + (test-equal? "response/basic (header)" + (output output-response + (make-response/basic 404 "404" (current-seconds) #"text/html" + (list (make-header #"Header" #"Value")))) + #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\nHeader: Value\r\n\r\n") + (test-equal? "response/basic (body)" + (output output-response + (make-response/basic 404 "404" (current-seconds) #"text/html" + (list))) + #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n") + (test-equal? "response/basic (bytes body)" + (output output-response + (make-response/basic 404 "404" (current-seconds) #"text/html" + (list))) + #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n") + (test-equal? "response/basic (both)" + (output output-response + (make-response/basic 404 "404" (current-seconds) #"text/html" + (list (make-header #"Header" #"Value")))) + #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\nHeader: Value\r\n\r\n")) + (test-suite "response/full" (test-equal? "response/full" @@ -55,6 +83,7 @@ (make-response/full 404 "404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (list "Content!"))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\nHeader: Value\r\n\r\nContent!")) + (test-suite "response/incremental" (test-equal? "response/incremental" @@ -94,6 +123,7 @@ (write "Content!") (write "Content!")))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n8\r\nContent!\r\n8\r\nContent!\r\n0\r\n\r\n")) + (test-suite "Simple content" (test-equal? "empty" @@ -108,14 +138,17 @@ (output output-response (list #"text/html" #"Content")) #"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 7\r\n\r\nContent")) + (test-suite "xexpr" (test-equal? "any" (output output-response `(html (head (title "Hey!")) (body "Content"))) - #"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nContent-Length: 65\r\n\r\nHey!Content"))) + #"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nContent-Length: 65\r\n\r\nHey!Content")) + ) (test-suite "output-response/method" + (test-suite "response/full" (test-equal? "response/full" @@ -148,6 +181,7 @@ (list (make-header #"Header" #"Value")) (list "Content!")) 'head) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 8\r\nHeader: Value\r\n\r\n")) + (test-suite "response/incremental" (test-equal? "response/incremental" @@ -193,6 +227,7 @@ (write "Content!"))) 'head) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n")) + (test-suite "Simple content" (test-equal? "empty" @@ -210,6 +245,7 @@ (list #"text/html" #"Content") 'head) #"HTTP/1.1 200 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 7\r\n\r\n")) + (test-suite "xexpr" (test-equal? "any" diff --git a/collects/web-server/http/response.ss b/collects/web-server/http/response.ss index 53bda2d7e2..dfb26db3c0 100644 --- a/collects/web-server/http/response.ss +++ b/collects/web-server/http/response.ss @@ -86,6 +86,16 @@ (list* (make-header #"Transfer-Encoding" #"chunked") (response/basic-headers resp)) (response/incremental-generator resp)))] + [(response/basic? resp) + (response->response/basic + close? + (make-response/full + (response/basic-code resp) + (response/basic-message resp) + (response/basic-seconds resp) + (response/basic-mime resp) + (response/basic-headers resp) + empty))] [(and (pair? resp) (bytes? (car resp))) (response->response/basic close? From fd5163ea4608aa39d5f927ee8b307f267930d671 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 17 Nov 2008 17:10:55 +0000 Subject: [PATCH 017/193] Dont need that information anymore svn: r12476 --- collects/web-server/http/response.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/http/response.ss b/collects/web-server/http/response.ss index dfb26db3c0..14f7e50d8b 100644 --- a/collects/web-server/http/response.ss +++ b/collects/web-server/http/response.ss @@ -262,7 +262,7 @@ (with-handlers ([exn:fail? (lambda (exn) (fprintf (current-error-port) - (format "~a File a PLT bug report if this is on a live server!~n" (exn-message exn))) + (exn-message exn)) (output-headers+response/basic conn (make-416-response modified-seconds mime-type)))]) From 2cea4696f5c485e430bab544986be1a3fcfa38d0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 17 Nov 2008 17:36:35 +0000 Subject: [PATCH 018/193] slightly better duplicate-key error reporting from Scribble svn: r12478 --- collects/scribble/latex-render.ss | 1 + collects/scribble/struct.ss | 11 ++++++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 7f772ff48d..5c88ec23e5 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -374,6 +374,7 @@ (if (rendering-tt) (format "{\\hbox{\\texttt{~a}}}" c) c)] [(#\~) "$\\sim$"] [(#\{ #\} #\# #\% #\& #\$) (format "\\~a" c)] + [(#\uA0) "~"] [(#\uDF) "{\\ss}"] [(#\u039A) "K"] ; kappa [(#\u0391) "A"] ; alpha diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index 8dc620293b..f1cefbd1a7 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -14,11 +14,12 @@ (define (collect-put! ci key val) (let ([ht (collect-info-ht ci)]) - (when (hash-ref ht key #f) - (fprintf (current-error-port) - "WARNING: collected information for key multiple times: ~e\n" - key)) - (hash-set! ht key val))) + (let ([old-val (hash-ref ht key #f)]) + (when old-val + (fprintf (current-error-port) + "WARNING: collected information for key multiple times: ~e; values: ~e ~e\n" + key old-val val)) + (hash-set! ht key val)))) (define (resolve-get/where part ri key) (let ([key (tag-key key ri)]) From 1bb01c05cdf15b98b75e47d3bfbb08d9bde72cf3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 17 Nov 2008 18:03:22 +0000 Subject: [PATCH 019/193] Fixing scribble errors svn: r12479 --- collects/web-server/scribblings/lang.scrbl | 4 ++++ collects/web-server/scribblings/stateless-servlet.scrbl | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/web-server/scribblings/lang.scrbl b/collects/web-server/scribblings/lang.scrbl index b981b02179..255e8d6a1c 100644 --- a/collects/web-server/scribblings/lang.scrbl +++ b/collects/web-server/scribblings/lang.scrbl @@ -3,6 +3,8 @@ @title[#:tag "lang/web.ss"]{Stateless Web Interaction} +@section{Low Level} + @(require (for-label web-server/lang/abort-resume)) @defmodule[web-server/lang/abort-resume]{ @@ -13,6 +15,8 @@ } +@section{High Level} + @(require (for-label web-server/lang/web)) @defmodule[web-server/lang/web]{ diff --git a/collects/web-server/scribblings/stateless-servlet.scrbl b/collects/web-server/scribblings/stateless-servlet.scrbl index c900979363..cb1e4101f4 100644 --- a/collects/web-server/scribblings/stateless-servlet.scrbl +++ b/collects/web-server/scribblings/stateless-servlet.scrbl @@ -2,7 +2,6 @@ @(require "web-server.ss") @title[#:tag "stateless-servlets"]{Stateless Servlets} -@defmodulelang[web-server] @(require (for-label "dummy-stateless-servlet.ss")) @; to give a binding context @declare-exporting[#:use-sources (web-server/scribblings/dummy-stateless-servlet)] @@ -30,6 +29,8 @@ The @schememodname[web-server] language automatically provides the @schememodnam @; ------------------------------------------------------------ @section[#:tag "considerations"]{Usage Considerations} +@defmodulelang[web-server] + A servlet has the following process performed on it automatically: @itemize[ @item{All uses of @scheme[letrec] are removed and replaced with equivalent uses of From d1fca9c04aa767c140b82b5b27ba70eaed5420f8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 17 Nov 2008 23:58:05 +0000 Subject: [PATCH 020/193] Fix PR 9918. svn: r12480 --- collects/scheme/match/compiler.ss | 2 +- collects/tests/match/examples.ss | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/scheme/match/compiler.ss b/collects/scheme/match/compiler.ss index 8a5683484e..5c43ec57c6 100644 --- a/collects/scheme/match/compiler.ss +++ b/collects/scheme/match/compiler.ss @@ -431,7 +431,7 @@ (if (Row-unmatch (car blocks)) #`(let/ec k (let ([#,(Row-unmatch (car blocks)) - (lambda () (k (#,esc)))]) + (lambda () (call-with-values #,esc k))]) rhs)) #'rhs))]) ;; then compile the rest, with our name as the esc diff --git a/collects/tests/match/examples.ss b/collects/tests/match/examples.ss index b09c703191..2e66a284b6 100644 --- a/collects/tests/match/examples.ss +++ b/collects/tests/match/examples.ss @@ -577,5 +577,11 @@ [(vector a b) a] [else 'bad])) + (comp '(1 2) + (call-with-values + (lambda () + (match 'foo [_ (=> skip) (skip)] [_ (values 1 2)])) + list)) + )) From bba0d3b3d46663927eb3f21bd5dbe7216b1056a3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 18 Nov 2008 00:02:28 +0000 Subject: [PATCH 021/193] Increasing code xrefs svn: r12481 --- collects/web-server/scribblings/lang.scrbl | 6 +++++ collects/web-server/scribblings/running.scrbl | 24 +++++++++++-------- .../web-server/scribblings/servlet-env.scrbl | 7 ++++-- .../scribblings/stateless-servlet.scrbl | 5 +++- .../web-server/scribblings/v1-servlet.scrbl | 3 ++- .../web-server/scribblings/v2-servlet.scrbl | 4 +++- collects/web-server/scribblings/web.scrbl | 8 ++++--- collects/web-server/scribblings/writing.scrbl | 5 ++-- 8 files changed, 42 insertions(+), 20 deletions(-) diff --git a/collects/web-server/scribblings/lang.scrbl b/collects/web-server/scribblings/lang.scrbl index 255e8d6a1c..65bb088714 100644 --- a/collects/web-server/scribblings/lang.scrbl +++ b/collects/web-server/scribblings/lang.scrbl @@ -3,6 +3,12 @@ @title[#:tag "lang/web.ss"]{Stateless Web Interaction} +@(require (for-label net/url + xml + scheme/serialize + web-server/servlet/servlet-structs + web-server/http)) + @section{Low Level} @(require (for-label web-server/lang/abort-resume)) diff --git a/collects/web-server/scribblings/running.scrbl b/collects/web-server/scribblings/running.scrbl index 9595ceebae..89c95c415b 100644 --- a/collects/web-server/scribblings/running.scrbl +++ b/collects/web-server/scribblings/running.scrbl @@ -34,7 +34,7 @@ You are given the entire @schememodname[web-server/servlet] API. @subsection{Customization API} -@defmodule[web-server/insta/insta] { +@defmodule[web-server/insta/insta]{ The following API is provided to customize the server instance: @@ -81,11 +81,15 @@ To run the web server with MrEd, use @; ------------------------------------------------------------ @section[#:tag "web-server.ss"]{Functional} -@(require (for-label web-server/web-server)) -@(require (for-label web-server/dispatchers/filesystem-map) - (for-label web-server/web-config-unit) - (for-label web-server/web-config-sig) - (for-label web-server/configuration/configuration-table) +@(require (for-label web-server/web-server + web-server/dispatchers/filesystem-map + web-server/web-config-unit + web-server/web-config-sig + web-server/private/dispatch-server-unit + web-server/private/dispatch-server-sig + web-server/dispatchers/dispatch + web-server/configuration/configuration-table) + (prefix-in raw: (for-label net/tcp-unit)) (prefix-in files: (for-label web-server/dispatchers/dispatch-files))) @defmodule[web-server/web-server]{ @@ -94,14 +98,14 @@ To run the web server with MrEd, use of the @web-server in other applications, or loading a custom dispatcher. -@defproc[(serve [#:dispatch dispatch dispatcher?] +@defproc[(serve [#:dispatch dispatch dispatcher/c] [#:tcp@ tcp@ tcp-unit^ raw:tcp@] [#:port port integer? 80] [#:listen-ip listen-ip (or/c string? false/c) #f] [#:max-waiting max-waiting integer? 40] [#:initial-connection-timeout initial-connection-timeout integer? 60]) (-> void)]{ - Constructs an appropriate @scheme[dispatch-config^], invokes the + Constructs an appropriate @scheme[dispatch-server-config^], invokes the @scheme[dispatch-server@], and calls its @scheme[serve] function. The @scheme[#:tcp@] keyword is provided for building an SSL server. See @secref["faq:https"]. @@ -122,7 +126,7 @@ from a given path: #:port 8080)) ] -@defproc[(serve/ports [#:dispatch dispatch dispatcher?] +@defproc[(serve/ports [#:dispatch dispatch dispatcher/c] [#:tcp@ tcp@ tcp-unit^ raw:tcp@] [#:ports ports (listof integer?) (list 80)] [#:listen-ip listen-ip (or/c string? false/c) #f] @@ -133,7 +137,7 @@ from a given path: a function that shuts down all of the server instances. } -@defproc[(serve/ips+ports [#:dispatch dispatch dispatcher?] +@defproc[(serve/ips+ports [#:dispatch dispatch dispatcher/c] [#:tcp@ tcp@ tcp-unit^ raw:tcp@] [#:ips+ports ips+ports (listof (cons/c (or/c string? false/c) (listof integer?))) (list (cons #f (list 80)))] [#:max-waiting max-waiting integer? 40] diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 3e5e4bcf94..bc8e7d94dc 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -3,7 +3,10 @@ @title[#:tag "servlet-env.ss" #:style 'toc]{Simple Single Servlet Servers} -@(require (for-label web-server/servlet-env)) +@(require (for-label web-server/servlet-env + web-server/http + web-server/managers/lru + scheme/list)) @defmodule[web-server/servlet-env]{ @@ -77,7 +80,7 @@ the top-level interacts with continuations. (Read: Don't do it.) [#:servlet-regexp servlet-regexp regexp? (regexp (format "^~a$" (regexp-quote servlet-path)))] [#:stateless? stateless? boolean? #f] - [#:manager manager manager? default-threshold-LRU-manager] + [#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))] [#:servlet-namespace servlet-namespace (listof module-path?) empty] [#:server-root-path server-root-path path? default-server-root-path] [#:extra-files-paths extra-files-paths (listof path?) (list (build-path server-root-path "htdocs"))] diff --git a/collects/web-server/scribblings/stateless-servlet.scrbl b/collects/web-server/scribblings/stateless-servlet.scrbl index cb1e4101f4..3bdeda9df0 100644 --- a/collects/web-server/scribblings/stateless-servlet.scrbl +++ b/collects/web-server/scribblings/stateless-servlet.scrbl @@ -3,7 +3,8 @@ @title[#:tag "stateless-servlets"]{Stateless Servlets} -@(require (for-label "dummy-stateless-servlet.ss")) @; to give a binding context +@(require (for-label web-server/http + "dummy-stateless-servlet.ss")) @; to give a binding context @declare-exporting[#:use-sources (web-server/scribblings/dummy-stateless-servlet)] @defthing[interface-version (one-of/c 'stateless)]{ @@ -29,6 +30,8 @@ The @schememodname[web-server] language automatically provides the @schememodnam @; ------------------------------------------------------------ @section[#:tag "considerations"]{Usage Considerations} +@(require (for-label web-server/lang/web)) + @defmodulelang[web-server] A servlet has the following process performed on it automatically: diff --git a/collects/web-server/scribblings/v1-servlet.scrbl b/collects/web-server/scribblings/v1-servlet.scrbl index 315b49c2e0..0ffbc32f0a 100644 --- a/collects/web-server/scribblings/v1-servlet.scrbl +++ b/collects/web-server/scribblings/v1-servlet.scrbl @@ -2,7 +2,8 @@ @(require "web-server.ss") @title{Version 1 Servlets} -@(require (for-label "dummy-v1-servlet.ss")) @; to give a binding context +@(require (for-label web-server/http + "dummy-v1-servlet.ss")) @; to give a binding context @declare-exporting[#:use-sources (web-server/scribblings/dummy-v1-servlet)] @defthing[interface-version (one-of/c 'v1)]{ diff --git a/collects/web-server/scribblings/v2-servlet.scrbl b/collects/web-server/scribblings/v2-servlet.scrbl index 84c7b2edcc..4021ba108d 100644 --- a/collects/web-server/scribblings/v2-servlet.scrbl +++ b/collects/web-server/scribblings/v2-servlet.scrbl @@ -2,7 +2,9 @@ @(require "web-server.ss") @title{Version 2 Servlets} -@(require (for-label "dummy-v2-servlet.ss")) @; to give a binding context +@(require (for-label web-server/http + (except-in web-server/managers/manager manager) + "dummy-v2-servlet.ss")) @; to give a binding context @declare-exporting[#:use-sources (web-server/scribblings/dummy-v2-servlet)] @defthing[interface-version (one-of/c 'v2)]{ diff --git a/collects/web-server/scribblings/web.scrbl b/collects/web-server/scribblings/web.scrbl index 146712abc5..7b5358d893 100644 --- a/collects/web-server/scribblings/web.scrbl +++ b/collects/web-server/scribblings/web.scrbl @@ -2,7 +2,9 @@ @(require "web-server.ss") @title[#:tag "web.ss"]{Web Interaction} -@(require (for-label web-server/servlet/web)) +@(require (for-label web-server/servlet/web + web-server/servlet/servlet-structs + web-server/http)) @defmodule[web-server/servlet/web]{The @schememodname[web-server/servlet/web] library provides the primary @@ -23,7 +25,7 @@ functions of interest for the servlet developer. ] } -@defproc[(send/suspend [make-response response-generator?] +@defproc[(send/suspend [make-response response-generator/c] [exp expiration-handler/c (current-servlet-continuation-expiration-handler)]) request?]{ Captures the current continuation, stores it with @scheme[exp] as the expiration @@ -81,7 +83,7 @@ functions of interest for the servlet developer. your application and you may think of it as ``embedding'' value-less callbacks. } -@defproc[(send/forward [make-response response-generator?] +@defproc[(send/forward [make-response response-generator/c] [exp expiration-handler/c (current-servlet-continuation-expiration-handler)]) request?]{ Calls @scheme[clear-continuation-table!], then @scheme[send/suspend]. diff --git a/collects/web-server/scribblings/writing.scrbl b/collects/web-server/scribblings/writing.scrbl index 1d18388c9c..56b08917a6 100644 --- a/collects/web-server/scribblings/writing.scrbl +++ b/collects/web-server/scribblings/writing.scrbl @@ -55,7 +55,7 @@ Equivalent to @scheme[string?]. Example: @scheme["http://localhost:8080/servlets;1*1*20131636/examples/add.ss"]} -@defthing[response-generator? contract?]{ +@defthing[response-generator/c contract?]{ Equivalent to @scheme[(k-url? . -> . response?)]. Example: @schemeblock[(lambda (k-url) @@ -91,7 +91,8 @@ This is what @scheme[send/suspend/dispatch] gives to its function argument. @; ------------------------------------------------------------ @section[#:tag "lang/file-box.ss"]{File Boxes} -@(require (for-label web-server/lang/file-box)) +@(require (for-label web-server/lang/file-box + scheme/serialize)) @defmodule[web-server/lang/file-box]{ From d9f9f22c0598a55eff85d5e0d6676859577d92b0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 18 Nov 2008 08:50:13 +0000 Subject: [PATCH 022/193] Welcome to a new PLT day. svn: r12482 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 62f0e8c300..eae3df392a 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "17nov2008") +#lang scheme/base (provide stamp) (define stamp "18nov2008") From 11a9c3c92939f28753349666dd6bd63fec0db2d6 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Tue, 18 Nov 2008 09:19:39 +0000 Subject: [PATCH 023/193] Synch German string constants with latest. svn: r12483 --- collects/string-constants/german-string-constants.ss | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss index 8a969ac10f..b3112612d7 100644 --- a/collects/string-constants/german-string-constants.ss +++ b/collects/string-constants/german-string-constants.ss @@ -901,6 +901,8 @@ (enforce-primitives-group-box-label "Initiale Bindungen") (enforce-primitives-check-box-label "Änderungen von initialen Bindungen verbieten") + (automatically-compile? "Quelldateien automatisch compilieren?") + ;; used in the bottom left of the drscheme frame as the label ;; above the programming language's name ;; used the popup menu from the just above; greyed out and only From be97f1db72626e11ca2a3f9d546bfadfdd5455b9 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 18 Nov 2008 12:01:46 +0000 Subject: [PATCH 024/193] svn: r12485 --- collects/handin-server/status-web-root/servlets/status.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss index 7a89f1888b..4fc8d6659b 100644 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ b/collects/handin-server/status-web-root/servlets/status.ss @@ -20,7 +20,7 @@ (get-preference (string->symbol user) (lambda () #f) #f users-file)))) (define (clean-str s) - (regexp-replace #rx" *$" (regexp-replace #rx"^ *" s "") "")) + (regexp-replace #rx" +$" (regexp-replace #rx"^ +" s "") "")) (define (aget alist key) (cond [(assq key alist) => cdr] [else #f])) From e0ac6dd80fbf63bf5ba262549fbb6f0de05a2f2f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 18 Nov 2008 12:05:15 +0000 Subject: [PATCH 025/193] get rid of unused argument svn: r12486 --- collects/handin-server/status-web-root/servlets/status.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss index 4fc8d6659b..1f939f9a52 100644 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ b/collects/handin-server/status-web-root/servlets/status.ss @@ -207,7 +207,7 @@ (one-status-page user for-handin) (all-status-page user))) - (define (login-page status for-handin errmsg) + (define (login-page for-handin errmsg) (let* ([request (send/suspend (lambda (k) @@ -238,7 +238,7 @@ (or (equal? pw (car user-data)) (equal? pw (get-conf 'master-password))))) (status-page user for-handin)] - [else (login-page status for-handin "Bad username or password")]))) + [else (login-page for-handin "Bad username or password")]))) (define web-counter (let ([sema (make-semaphore 1)] @@ -251,7 +251,7 @@ (define (start initial-request) (parameterize ([current-session (web-counter)]) - (login-page null (aget (request-bindings initial-request) 'handin) #f))) + (login-page (aget (request-bindings initial-request) 'handin) #f))) (define interface-version 'v2) (define name "status") From 2b17f505e51f241d3744d77479bc3ba8c879a48b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 18 Nov 2008 13:45:13 +0000 Subject: [PATCH 026/193] svn: r12487 --- collects/games/chat-noir/chat-noir.ss | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/collects/games/chat-noir/chat-noir.ss b/collects/games/chat-noir/chat-noir.ss index ff389fc9e9..af8c67309a 100644 --- a/collects/games/chat-noir/chat-noir.ss +++ b/collects/games/chat-noir/chat-noir.ss @@ -1,14 +1,9 @@ -#| - -hint: include the size of the board in your world structure -This enables you to make test cases with different size boards, -making some of the test cases much easier to manage. - -|# - +;; constants (define circle-radius 20) (define circle-spacing 22) +;; data definitions + ;; a world is: ;; (make-world board posn state number) (define-struct world (board cat state size)) @@ -138,21 +133,20 @@ making some of the test cases much easier to manage. ;; board->image : board number -> image (define (board->image cs world-size) - (foldl overlay + (foldl (lambda (x y) (overlay y x)) (nw:rectangle (world-width world-size) (world-height world-size) - 'outline - 'black) + 'solid + 'white) (map cell->image cs))) (check-expect (board->image (list (make-cell (make-posn 0 0) false)) 3) (overlay - (cell->image - (make-cell (make-posn 0 0) false)) (nw:rectangle (world-width 3) (world-height 3) - 'outline - 'black))) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false)))) ;; cell->image : cell -> image From 96075e97938b6b01cac043c7a76b366180e12801 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 18 Nov 2008 14:49:31 +0000 Subject: [PATCH 027/193] bugfix commit from Jens Axel svn: r12489 --- collects/srfi/42/expansion.scm | 68 ++++++++++++++++++--------- collects/srfi/42/extra-generators.scm | 10 +++- 2 files changed, 55 insertions(+), 23 deletions(-) diff --git a/collects/srfi/42/expansion.scm b/collects/srfi/42/expansion.scm index e06475b4b5..076ccbd1f8 100644 --- a/collects/srfi/42/expansion.scm +++ b/collects/srfi/42/expansion.scm @@ -27,15 +27,33 @@ (generator? (syntax-local-value #'name (lambda () #f))))] [_ #f])) - (require (lib "stx.ss" "syntax")) - (define (filter-clause? clause-stx) - (syntax-case* clause-stx (if not and or) module-or-top-identifier=? - [(if . more) #t] - [(not . more) #t] - [(and . more) #t] - [(or . more) #t] - [_ #f])) + (require (lib "stx.ss" "syntax")) + (require (prefix base: scheme) + (for-meta 1 (prefix base: scheme))) + (define (if-filter? stx) + (syntax-case stx () + [(head expr) + (and (identifier? #'head) + (eq? 'if (syntax-e #'head)))] + [else #f])) + + (require (prefix new- scheme)) + + #;(define (if-filter? stx) + (syntax-case* stx (if new-if) module-or-top-identifier=? + [(if expr) #t] + [(new-if expr) #t] + [_ #f])) + + (define (filter-clause? clause-stx) + (or (if-filter? clause-stx) + (syntax-case* clause-stx (if base:if not and or) module-or-top-identifier=? + [(not . more) #t] + [(and . more) #t] + [(or . more) #t] + [_ #f]))) + (define (begin-clause? clause-stx) (syntax-case clause-stx (begin) [(begin . more) #t] @@ -115,18 +133,26 @@ (loop2... body-stx)))] [(filter-clause? #'clause1) (let ([loop2... (expand-clauses #'(clause2 ...))]) - (syntax-case* #'clause1 (if not and or) module-or-top-identifier=? ; due to not - [(if expr) - #`(if expr #,(loop2... body-stx))] - [(not expr) - #`(if (not expr) #,(loop2... body-stx))] - [(or expr ...) - #`(if (or expr ...) #,(loop2... body-stx))] - [(and expr ...) - #`(if (and expr ...) #,(loop2... body-stx))] - [_ - (raise-syntax-error 'expand-clauses - "unimplemented " #'clause1)]))] + (cond + [(if-filter? #'clause1) + (syntax-case #'clause1 () + [(the-if expr) + #`(if expr #,(loop2... body-stx))] + [else (raise-syntax-error 'expand-clauses + "internal error: expected" #'clause1)])] + [else + (syntax-case* #'clause1 (if not and or) module-or-top-identifier=? ; due to not + #;[(if expr) + #`(if expr #,(loop2... body-stx))] + [(not expr) + #`(if (not expr) #,(loop2... body-stx))] + [(or expr ...) + #`(if (or expr ...) #,(loop2... body-stx))] + [(and expr ...) + #`(if (and expr ...) #,(loop2... body-stx))] + [_ + (raise-syntax-error 'expand-clauses + "unimplemented " #'clause1)])]))] [(begin-clause? #'clause1) (let ([loop2... (expand-clauses #'(clause2 ...))]) (syntax-case #'clause1 () @@ -192,4 +218,4 @@ stx)] [_ (raise-syntax-error 'add-index "think" stx)])) - ) \ No newline at end of file + ) diff --git a/collects/srfi/42/extra-generators.scm b/collects/srfi/42/extra-generators.scm index 72fce3b42f..888fe66947 100644 --- a/collects/srfi/42/extra-generators.scm +++ b/collects/srfi/42/extra-generators.scm @@ -10,11 +10,17 @@ :vector-combinations :do-until :pairs + :pairs-by :list-by :alist :hash-table :hash-table-keys - :hash-table-values) + :hash-table-values + indices->list + indices->vector + last-combination? + next-combination + first-combination) (require "ec-core.scm") (require-for-syntax "ec-core.scm") @@ -367,4 +373,4 @@ 'match "expected (:match )" stx)])) - ) \ No newline at end of file + ) From b35c6545a72c97371c3a05153c69657bc41ad117 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Tue, 18 Nov 2008 15:33:24 +0000 Subject: [PATCH 028/193] fixed small bug in error message for draw/idraw teachpack svn: r12491 --- collects/htdch/draw/support.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/htdch/draw/support.scm b/collects/htdch/draw/support.scm index ba9b802c51..0044fa9661 100644 --- a/collects/htdch/draw/support.scm +++ b/collects/htdch/draw/support.scm @@ -74,7 +74,7 @@ (define (check-arg value method argument) (or (> value 0) (raise-error - (format "Method ~a expects an int >= 0 for ~a argument, given ~a" method argument value)))) + (format "Method ~a expects an int > 0 for ~a argument, given ~a" method argument value)))) (define (to-lower-case s) (letrec ((lower From ce734b819c07223cc99d99a9ac402b1409b676f8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 18 Nov 2008 17:08:04 +0000 Subject: [PATCH 029/193] Increasing crossrefs. Eli, you can include this in the release svn: r12492 --- .../scribblings/configuration.scrbl | 5 +++- .../web-server/scribblings/dispatchers.scrbl | 18 +++++++---- collects/web-server/scribblings/private.scrbl | 13 ++++++-- .../scribblings/servlet-setup.scrbl | 30 +++++++++++++++++-- .../scribblings/web-config-unit.scrbl | 19 ++++++++---- .../scribblings/web-server-unit.scrbl | 12 +++++--- 6 files changed, 76 insertions(+), 21 deletions(-) diff --git a/collects/web-server/scribblings/configuration.scrbl b/collects/web-server/scribblings/configuration.scrbl index ea9dd0356d..ce9b731b20 100644 --- a/collects/web-server/scribblings/configuration.scrbl +++ b/collects/web-server/scribblings/configuration.scrbl @@ -11,7 +11,10 @@ configuring the @web-server . @; ------------------------------------------------------------ @section[#:tag "configuration-table-structs.ss"]{Configuration Table Structure} -@(require (for-label web-server/configuration/configuration-table-structs)) +@(require (for-label web-server/configuration/configuration-table-structs + web-server/http + net/url + web-server/private/util)) @defmodule[web-server/configuration/configuration-table-structs]{ diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index 0d07bf4c98..1f7ffe3c0d 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -1,5 +1,13 @@ #lang scribble/doc @(require "web-server.ss" + (for-label web-server/http + net/url + web-server/servlet/setup + web-server/configuration/responders + web-server/private/servlet + scheme/date + web-server/private/util + web-server/private/connection-manager) (for-syntax scheme/base)) @(define-syntax (a-dispatcher stx) @@ -70,7 +78,7 @@ Consider the following example dispatcher, that captures the essence of URL rewr (code:comment "Call the inner dispatcher...") (inner conn (code:comment "with a new request object...") - (copy-struct request req + (struct-copy request req (code:comment "with a new URL!") [request-uri (rule (request-uri req))])))) ] @@ -109,7 +117,7 @@ URLs to paths on the filesystem. by a file. The most prominent example is obviously servlets.} @defproc[(filter-url->path [regex regexp?] - [url->path url-path/c]) + [url->path url->path/c]) url->path/c]{ Runs the underlying @scheme[url->path] but will only return if the path, when considered as a string, matches the @scheme[regex]. This is useful to disallow strange files, like GIFs, from being considered @@ -286,7 +294,7 @@ a URL that refreshes the password file, servlet cache, etc.} @scheme[password-file] is parsed as: @schemeblock[(list ([domain : string?] - [path : string-regexp?] + [path : string?] (code:comment "This string is interpreted as a regex") (list [user : symbol?] [pass : string?]) ...) @@ -351,11 +359,11 @@ a URL that refreshes the password file, servlet cache, etc.} @defproc[(make [url->servlet url->servlet/c] [#:responders-servlet-loading responders-servlet-loading - ((url url?) (exn exn?) . -> . response?) + (url? exn? . -> . response?) servlet-loading-responder] [#:responders-servlet responders-servlet - ((url url?) (exn exn?) . -> . response?) + (url? exn? . -> . response?) servlet-error-responder]) dispatcher/c]{ This dispatcher runs Scheme servlets, using @scheme[url->servlet] to resolve URLs to the underlying servlets. diff --git a/collects/web-server/scribblings/private.scrbl b/collects/web-server/scribblings/private.scrbl index 80b1b5e166..7e84ba30a8 100644 --- a/collects/web-server/scribblings/private.scrbl +++ b/collects/web-server/scribblings/private.scrbl @@ -2,6 +2,12 @@ @(require "web-server.ss") @title[#:tag "private" #:style 'toc]{Internal} +@(require (for-label scheme/tcp + web-server/dispatchers/dispatch + net/url + scheme/serialize + xml + net/tcp-sig)) The @web-server is a complicated piece of software and as a result, defines a number of interesting and independently useful sub-components. @@ -147,12 +153,15 @@ The @scheme[dispatch-server^] signature is an alias for @defthing[initial-connection-timeout integer?]{Specifies the initial timeout given to a connection.} @defproc[(read-request [c connection?] [p port?] - [port-addresses port-addresses?]) + [port-addresses (-> port? boolean? + (or/c (values string? string?) + (values string? (integer-in 1 65535) + string? (integer-in 1 65535))))]) any/c]{ Defines the way the server reads requests off connections to be passed to @scheme[dispatch]. } - @defthing[dispatch dispatcher?]{How to handle requests.} + @defthing[dispatch dispatcher/c]{How to handle requests.} } } diff --git a/collects/web-server/scribblings/servlet-setup.scrbl b/collects/web-server/scribblings/servlet-setup.scrbl index c10f91b277..c227d33150 100644 --- a/collects/web-server/scribblings/servlet-setup.scrbl +++ b/collects/web-server/scribblings/servlet-setup.scrbl @@ -2,7 +2,11 @@ @(require "web-server.ss") @title[#:tag "setup.ss"]{Setting Up Servlets} -@(require (for-label web-server/servlet/setup)) +@(require (for-label web-server/servlet/setup + web-server/http + web-server/private/servlet + web-server/managers/manager + web-server/configuration/namespace)) @defmodule[web-server/servlet/setup]{ @@ -39,7 +43,7 @@ Equivalent to @scheme[(path? . -> . servlet?)]. @defproc[(make-default-path->servlet [#:make-servlet-namespace make-servlet-namespace - make-servlet-namespace? + make-servlet-namespace/c (make-make-servlet-namespace)] [#:timeouts-default-servlet timeouts-default-servlet @@ -50,4 +54,24 @@ Equivalent to @scheme[(path? . -> . servlet?)]. using a timeout manager with @scheme[timeouts-default-servlet] as the default timeout (if no manager is given.) } -} \ No newline at end of file +} + +@section{Internal Servlet Representation} + +@defmodule[web-server/private/servlet]{ + @defstruct[servlet ([custodian custodian?] + [namespace namespace?] + [manager manager?] + [directory path?] + [handler (request? . -> . response?)]) + #:mutable]{ + Instances of this structure hold the necessary parts of a servlet: + the @scheme[custodian] responsible for the servlet's resources, + the @scheme[namespace] the servlet is executed within, + the @scheme[manager] responsible for the servlet's continuations, + the current @scheme[directory] of the servlet, + and the @scheme[handler] for all requests to the servlet. + } +} + + diff --git a/collects/web-server/scribblings/web-config-unit.scrbl b/collects/web-server/scribblings/web-config-unit.scrbl index 875a12f702..4aa33691df 100644 --- a/collects/web-server/scribblings/web-config-unit.scrbl +++ b/collects/web-server/scribblings/web-config-unit.scrbl @@ -3,8 +3,15 @@ @title[#:tag "web-config-unit.ss" #:style 'toc]{Web Config Unit} -@(require (for-label web-server/web-config-unit) - (for-label web-server/web-config-sig)) +@(require (for-label web-server/web-config-unit + web-server/configuration/namespace + web-server/configuration/configuration-table + web-server/configuration/configuration-table-structs + web-server/private/util + web-server/servlet/setup + scheme/tcp + (prefix-in servlets: web-server/dispatchers/dispatch-servlets) + web-server/web-config-sig)) The @web-server offers a unit-based approach to configuring the server. @@ -40,8 +47,8 @@ Provides contains the following identifiers. Passed to @scheme[tcp-accept]. } -@defthing[make-servlet-namespace make-servlet-namespace?]{ - Passed to @scheme[servlets:make]. +@defthing[make-servlet-namespace make-servlet-namespace/c]{ + Passed to @scheme[servlets:make] through @scheme[make-default-path->servlet]. } } @@ -54,7 +61,7 @@ Provides contains the following identifiers. @defproc[(configuration-table->web-config@ [path path?] [#:port port (or/c false/c port-number?) #f] [#:listen-ip listen-ip (or/c false/c string?) #f] - [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace? (make-make-servlet-namespace)]) + [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)]) (unit? web-config^)]{ Reads the S-expression at @scheme[path] and calls @scheme[configuration-table-sexpr->web-config@] appropriately. @@ -64,7 +71,7 @@ Provides contains the following identifiers. [#:web-server-root web-server-root path? (directory-part default-configuration-table-path)] [#:port port (or/c false/c port-number?) #f] [#:listen-ip listen-ip (or/c false/c string?) #f] - [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace? (make-make-servlet-namespace)]) + [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)]) (unit? web-config^)]{ Parses @scheme[sexpr] as a configuration-table and constructs a @scheme[web-config^] unit. } diff --git a/collects/web-server/scribblings/web-server-unit.scrbl b/collects/web-server/scribblings/web-server-unit.scrbl index 88094ea6c1..eddcff7bdd 100644 --- a/collects/web-server/scribblings/web-server-unit.scrbl +++ b/collects/web-server/scribblings/web-server-unit.scrbl @@ -3,8 +3,12 @@ @title[#:tag "web-server-unit.ss" #:style 'toc]{Web Server Unit} -@(require (for-label web-server/web-server-sig) - (for-label web-server/web-server-unit)) +@(require (for-label web-server/web-server-sig + web-server/web-server-unit + net/tcp-sig + web-server/dispatchers/dispatch + web-server/web-config-sig + web-server/web-config-unit)) The @web-server offers a unit-based approach to running the server. @@ -37,7 +41,7 @@ The @web-server offers a unit-based approach to running the server. @defthing[web-server@ (unit/c (web-config^ tcp^) (web-server^))]{ -Uses the @scheme[web-config^] to construct a @scheme[dispatcher?] +Uses the @scheme[web-config^] to construct a @scheme[dispatcher/c] function that sets up one virtual host dispatcher, for each virtual host in the @scheme[web-config^], that sequences the following operations: @@ -52,7 +56,7 @@ operations: @item{Serves files under the @scheme["/"] URL in the given htdocs directory.} ] -Using this @scheme[dispatcher?], it loads a dispatching server that provides @scheme[serve] +Using this @scheme[dispatcher/c], it loads a dispatching server that provides @scheme[serve] and @scheme[serve-ports] functions that operate as expected. } From cc25f3852f5986e0f64c31c379f3c3c2c0c11307 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Tue, 18 Nov 2008 17:10:19 +0000 Subject: [PATCH 030/193] Corrected bug in test display and custodians shutting down windows. (Had accidentally put the gui actions back on the user's eventspace) Commit is for the release svn: r12493 --- collects/profj/tool.ss | 5 +++-- collects/test-engine/test-display.scm | 22 +++------------------- collects/test-engine/test-engine.scm | 2 +- 3 files changed, 7 insertions(+), 22 deletions(-) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 2ae863f5aa..88f34c72b3 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -28,7 +28,7 @@ (dynamic-require the-file 'id))]) (apply orig-fn x))) ...)])) - + (dr "compile.ss" compile-java compile-interactions compile-files compile-ast compile-interactions-ast compilation-unit-code compilation-unit-contains set-compilation-unit-code! @@ -763,11 +763,12 @@ (send collect-coverage enable #f)) (install-classpath (profj-settings-classpath settings))]))) + (define eventspace (current-eventspace)) (define/public (front-end/complete-program port settings) (mred? #t) (let ([name (object-name port)] [rep (drscheme:rep:current-rep)] - [eventspace (current-eventspace)] + #;[eventspace (current-eventspace)] [execute-types (create-type-record)]) (let ([name-to-require #f] [require? #f] diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index 797fb5f2f0..d8b4006170 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -32,7 +32,6 @@ (lambda () (put-preferences '(test:test-window:docked?) '(#f)) #f)))) (define/public (report-success) - (printf "calling report-success~n") (when current-rep (unless current-tab (set! current-tab (send (send current-rep get-definitions-text) get-tab))) @@ -40,25 +39,20 @@ (set! drscheme-frame (send current-rep get-top-level-window))) (let ([curr-win (and current-tab (send current-tab get-test-window))] [content (make-object (editor:standard-style-list-mixin text%))]) - (printf "current-tab ~a , curr-win ~a ~n" current-tab curr-win) (send this insert-test-results content test-info src-editor) - (printf "inserted test results~n") (send content lock #t) - (printf "locked content~n") (when curr-win (send curr-win update-editor content)) - (printf "updated test-window editor~n") (when current-tab (send current-tab current-test-editor content)) - (printf "editors updated~n") (when (and curr-win (docked?)) (send drscheme-frame display-test-panel content) #;(send curr-win show #f)) - (printf "done~n")))) + ))) (define/public (display-results) (let* ([curr-win (and current-tab (send current-tab get-test-window))] [window (or curr-win (make-object test-window%))] [content (make-object (editor:standard-style-list-mixin text%))]) - + (send this insert-test-results content test-info src-editor) (send content lock #t) (send window update-editor content) @@ -116,7 +110,7 @@ [(zero? failed-checks) (format "All ~as passed!\n\n" ck)] [(= failed-checks total-checks) (format "0 ~as passed.\n" ck)] [else (format "~a of the ~a ~as failed.\n\n" - failed-checks ck total-checks)]))))]) + failed-checks total-checks ck)]))))]) (case style [(test-require) (test-outcomes "This program must be tested!\n") @@ -236,7 +230,6 @@ (super-instantiate ((string-constant test-engine-window-title) #f 400 350)) - #;(define editor #f) (define switch-func void) (define disable-func void) (define close-cleanup void) @@ -256,14 +249,6 @@ (when (eq? 'button (send c get-event-type)) (close-cleanup) (send this show #f)))) - #;(make-object button% - (string-constant profj-test-results-close-and-disable) - button-panel - (lambda (b c) - (when (eq? 'button (send c get-event-type)) - (disable-func) - (close-cleanup) - (send this show #f)))) (make-object button% (string-constant dock) button-panel @@ -276,7 +261,6 @@ (make-object grow-box-spacer-pane% button-panel))) (define/public (update-editor e) - #;(set! editor e) (send content set-editor e)) (define/public (update-switch thunk) diff --git a/collects/test-engine/test-engine.scm b/collects/test-engine/test-engine.scm index a209261423..9a321a80e4 100644 --- a/collects/test-engine/test-engine.scm +++ b/collects/test-engine/test-engine.scm @@ -145,7 +145,7 @@ (fprintf port "Tests disabled.\n")])) (define/private (display-success port event count) - #;(when event + (when event (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event]) ((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display report-success))))) From d085b21a90cd5c3055983cbd81cbfcdf43682947 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 18 Nov 2008 17:53:18 +0000 Subject: [PATCH 031/193] Clarifying manager docs and adding interface to serve/servlets svn: r12494 --- .../web-server/scribblings/managers.scrbl | 2 +- .../web-server/scribblings/servlet-env.scrbl | 54 +++++++++++-------- collects/web-server/servlet-env.ss | 52 ++++++++++-------- 3 files changed, 64 insertions(+), 44 deletions(-) diff --git a/collects/web-server/scribblings/managers.scrbl b/collects/web-server/scribblings/managers.scrbl index 24ceb3a4a5..834fee6636 100644 --- a/collects/web-server/scribblings/managers.scrbl +++ b/collects/web-server/scribblings/managers.scrbl @@ -165,7 +165,7 @@ The recommended usage of this manager is codified as the following function: [memory-threshold number?]) manager?]{ This creates an LRU manager with the following behavior: - The memory limit is set to @scheme[memory-threshold]. Continuations start with @scheme[24] + The memory limit is set to @scheme[memory-threshold] bytes. Continuations start with @scheme[24] life points. Life points are deducted at the rate of one every @scheme[10] minutes, or one every @scheme[5] seconds when the memory limit is exceeded. Hence the maximum life time for a continuation is @scheme[4] hours, and the minimum is @scheme[2] minutes. diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index bc8e7d94dc..7b93592f84 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -6,6 +6,7 @@ @(require (for-label web-server/servlet-env web-server/http web-server/managers/lru + web-server/configuration/responders scheme/list)) @defmodule[web-server/servlet-env]{ @@ -70,26 +71,34 @@ Suppose you would like to start a server for a stateless Web servlet @filepath{s Note: If you put the call to @scheme[serve/servlet] in the module like normal, strange things will happen because of the way the top-level interacts with continuations. (Read: Don't do it.) +If you want to use @scheme[serve/servlet] in a start up script for a Web server, and don't want a browser opened or the DrScheme banner printed, then you can write: +@schemeblock[ +(serve/servlet my-app + #:command-line? #t) +] + @defproc[(serve/servlet [start (request? . -> . response?)] - [#:launch-browser? launch-browser? boolean? #t] - [#:quit? quit? boolean? #t] - [#:listen-ip listen-ip string? "127.0.0.1"] - [#:port port number? 8000] - [#:servlet-path servlet-path string? - "/servlets/standalone.ss"] - [#:servlet-regexp servlet-regexp regexp? - (regexp (format "^~a$" (regexp-quote servlet-path)))] - [#:stateless? stateless? boolean? #f] - [#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))] - [#:servlet-namespace servlet-namespace (listof module-path?) empty] - [#:server-root-path server-root-path path? default-server-root-path] - [#:extra-files-paths extra-files-paths (listof path?) (list (build-path server-root-path "htdocs"))] - [#:servlets-root servlets-root path? (build-path server-root-path "htdocs")] - [#:servlet-current-directory servlet-current-directory path? servlets-root] - [#:file-not-found-path file-not-found-path path? - (build-path server-root-path "conf" "not-found.html")] - [#:mime-types-path mime-types-path path? - (build-path server-root-path "mime.types")]) + [#:command-line? command-line? boolean? #f] + [#:launch-browser? launch-browser? boolean? (not command-line?)] + [#:quit? quit? boolean? (not command-line?)] + [#:banner? banner? boolean? (not command-line?)] + [#:listen-ip listen-ip string? "127.0.0.1"] + [#:port port number? 8000] + [#:servlet-path servlet-path string? + "/servlets/standalone.ss"] + [#:servlet-regexp servlet-regexp regexp? + (regexp (format "^~a$" (regexp-quote servlet-path)))] + [#:stateless? stateless? boolean? #f] + [#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))] + [#:servlet-namespace servlet-namespace (listof module-path?) empty] + [#:server-root-path server-root-path path? default-server-root-path] + [#:extra-files-paths extra-files-paths (listof path?) (list (build-path server-root-path "htdocs"))] + [#:servlets-root servlets-root path? (build-path server-root-path "htdocs")] + [#:servlet-current-directory servlet-current-directory path? servlets-root] + [#:file-not-found-responder file-not-found-responder + (gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))] + [#:mime-types-path mime-types-path path? + (build-path server-root-path "mime.types")]) void]{ This sets up and starts a fairly default server instance. @@ -99,7 +108,7 @@ the top-level interacts with continuations. (Read: Don't do it.) If @scheme[launch-browser?] is true, then a web browser is opened to @filepath{http://localhost:}. If @scheme[quit?] is true, then the URL @filepath["/quit"] ends the server. - + If @scheme[stateless?] is true, then the servlet is run as a stateless @schememodname[web-server] module. Advanced users may need the following options: @@ -118,7 +127,10 @@ the top-level interacts with continuations. (Read: Don't do it.) Other servlets are served from @scheme[servlets-root]. - If a file cannot be found, @scheme[file-not-found-path] is used as an error response. + If a file cannot be found, @scheme[file-not-found-responder] is used to generate an error response. + + If @scheme[banner?] is true, then an informative banner is printed. You may want to use this when + running from the command line, in which case the @scheme[command-line?] option controls similar options. MIME types are looked up at @scheme[mime-types-path]. } diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index d9b90ecc61..e6988ba34d 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -41,27 +41,33 @@ (provide/contract [serve/servlet (((request? . -> . response?)) - (#:launch-browser? boolean? - #:quit? boolean? - #:listen-ip string? - #:port number? - #:manager manager? - #:servlet-namespace (listof module-path?) - #:server-root-path path? - #:stateless? boolean? - #:extra-files-paths (listof path?) - #:servlets-root path? - #:file-not-found-path path? - #:mime-types-path path? - #:servlet-path string? - #:servlet-regexp regexp?) + (#:command-line? boolean? + #:launch-browser? boolean? + #:quit? boolean? + #:banner? boolean? + #:listen-ip string? + #:port number? + #:manager manager? + #:servlet-namespace (listof module-path?) + #:server-root-path path? + #:stateless? boolean? + #:extra-files-paths (listof path?) + #:servlets-root path? + #:file-not-found-responder (request? . -> . response?) + #:mime-types-path path? + #:servlet-path string? + #:servlet-regexp regexp?) . ->* . void)]) (define (serve/servlet start + #:command-line? + [command-line? #f] #:launch-browser? - [launch-browser? #t] + [launch-browser? (not command-line?)] #:quit? - [quit? #t] + [quit? (not command-line?)] + #:banner? + [banner? (not command-line?)] #:listen-ip [listen-ip "127.0.0.1"] @@ -93,8 +99,8 @@ [servlets-root (build-path server-root-path "htdocs")] #:servlet-current-directory [servlet-current-directory servlets-root] - #:file-not-found-path - [file-not-found-path (build-path server-root-path "conf" "not-found.html")] + #:file-not-found-responder + [file-not-found-responder (gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))] #:mime-types-path [mime-types-path (build-path server-root-path "mime.types")]) (define standalone-url @@ -149,19 +155,21 @@ (build-path server-root-path "htdocs")) #:path->mime-type (make-path->mime-type (build-path server-root-path "mime.types")) #:indices (list "index.html" "index.htm")) - (lift:make (gen-file-not-found-responder file-not-found-path)))) + (lift:make file-not-found-responder))) (define shutdown-server (serve #:dispatch dispatcher #:listen-ip listen-ip #:port the-port)) (when launch-browser? ((send-url) standalone-url #t)) - (printf "Your Web application is running at ~a.~n" standalone-url) - (printf "Click 'Stop' at any time to terminate the Web Server.~n") + (when banner? + (printf "Your Web application is running at ~a.~n" standalone-url) + (printf "Click 'Stop' at any time to terminate the Web Server.~n")) (with-handlers ([exn:break? (lambda (exn) - (printf "~nWeb Server stopped.~n") + (when banner? + (printf "~nWeb Server stopped.~n")) (shutdown-server))]) (semaphore-wait/enable-break sema)) ; We shouldn't get here, because nothing posts to the semaphore. But just in case... From 9e7a4e9e1dbb6b46be8020fe9eb5766f00b80b37 Mon Sep 17 00:00:00 2001 From: John Clements Date: Tue, 18 Nov 2008 18:26:31 +0000 Subject: [PATCH 032/193] fixed felix's bug svn: r12495 --- collects/stepper/private/lifting.ss | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/stepper/private/lifting.ss b/collects/stepper/private/lifting.ss index 84739085b8..b120af7042 100644 --- a/collects/stepper/private/lifting.ss +++ b/collects/stepper/private/lifting.ss @@ -54,7 +54,10 @@ ;; distinguish a top-level begin from one that's the result of some evaluation. ;; I think for the moment that it will solve our problem simply to remove the ;; special case for begin at the top level. JBC, 2006-10-09 - + + ;; ... aaaand, yep, there's a bug. The input is not fully-expanded syntax, and + ;; therefore _can_ include a two-branched 'if' (because the reconstructor produces it.) + ;; (define (top-level-expr-iterator stx context-so-far) (let ([try (try->offset-try (make-try-all-subexprs stx 'top-level context-so-far))]) @@ -120,6 +123,8 @@ (loop (+ count 1) (cdr clauses))))] [(if test then else) (try-exprs-offset 1 #'(test then else))] + [(if test then) + (try-exprs-offset 1 #'(test then))] [(begin . bodies) (try-exprs-offset 1 #'bodies)] [(begin0 . bodies) From dce2d2529e6754fddc5a7179fafd5bee2ab260f4 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Tue, 18 Nov 2008 18:58:22 +0000 Subject: [PATCH 033/193] Make coverage buttons uneditable. svn: r12496 --- collects/test-engine/test-coverage.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/test-engine/test-coverage.scm b/collects/test-engine/test-coverage.scm index 72ef1aa740..40e165e8b6 100644 --- a/collects/test-engine/test-coverage.scm +++ b/collects/test-engine/test-coverage.scm @@ -108,6 +108,7 @@ (send coverage display-coverage src-editor))] [else (lambda (t s e) (void))]) #f #f) + (send button-editor lock #t) (let ([c (new style-delta%)]) (send c set-delta-foreground "royalblue") (send dest change-style c start (sub1 (send dest get-end-position)) From 4c0c3c0ff8c71c9b37680c35c196585e4d96565d Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 18 Nov 2008 21:17:36 +0000 Subject: [PATCH 034/193] Fix dynamic context of use of match failure continuations. svn: r12497 --- collects/scheme/match/compiler.ss | 10 ++++++---- collects/scheme/match/runtime.ss | 5 ++++- collects/tests/match/examples.ss | 14 ++++++++++++++ 3 files changed, 24 insertions(+), 5 deletions(-) diff --git a/collects/scheme/match/compiler.ss b/collects/scheme/match/compiler.ss index 5c43ec57c6..0d0efd74fb 100644 --- a/collects/scheme/match/compiler.ss +++ b/collects/scheme/match/compiler.ss @@ -429,10 +429,12 @@ (quote-syntax #,esc))]) #,(Row-rhs (car blocks)))]) (if (Row-unmatch (car blocks)) - #`(let/ec k - (let ([#,(Row-unmatch (car blocks)) - (lambda () (call-with-values #,esc k))]) - rhs)) + #`(call-with-continuation-prompt + (lambda () (let ([#,(Row-unmatch (car blocks)) + (lambda () (abort-current-continuation match-prompt-tag))]) + rhs)) + match-prompt-tag + (lambda () (#,esc))) #'rhs))]) ;; then compile the rest, with our name as the esc (loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))]) diff --git a/collects/scheme/match/runtime.ss b/collects/scheme/match/runtime.ss index 8bd598543f..6b38c07fbb 100644 --- a/collects/scheme/match/runtime.ss +++ b/collects/scheme/match/runtime.ss @@ -7,7 +7,10 @@ exn:misc:match? match:error fail - matchable?) + matchable? + match-prompt-tag) + +(define match-prompt-tag (make-continuation-prompt-tag 'match)) (define match-equality-test (make-parameter equal?)) diff --git a/collects/tests/match/examples.ss b/collects/tests/match/examples.ss index 2e66a284b6..679f6c09e5 100644 --- a/collects/tests/match/examples.ss +++ b/collects/tests/match/examples.ss @@ -2,6 +2,7 @@ (require scheme/match scheme/mpair + scheme/control (for-syntax scheme/base) (prefix-in m: mzlib/match) (only-in srfi/13 string-contains)) @@ -582,6 +583,19 @@ (lambda () (match 'foo [_ (=> skip) (skip)] [_ (values 1 2)])) list)) + (comp 0 + (let ([z (make-parameter 0)]) + (match 1 + [(? number?) (=> f) (parameterize ([z 1]) (f))] + [(? number?) (z)]))) + ;; make sure the prompts don't interfere + (comp 12 + (% + (let ([z (make-parameter 0)]) + (match 1 + [(? number?) (=> f) (parameterize ([z 1]) (fcontrol 5))] + [(? number?) (z)])) + (lambda _ 12))) )) From cfb1805e4484a986039039f5babecaccb42ea999 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 18 Nov 2008 21:47:06 +0000 Subject: [PATCH 035/193] Updating re: Eli svn: r12498 --- collects/web-server/template/examples/run.ss | 54 +++----------------- 1 file changed, 7 insertions(+), 47 deletions(-) diff --git a/collects/web-server/template/examples/run.ss b/collects/web-server/template/examples/run.ss index d88b7c48e3..98b7919883 100644 --- a/collects/web-server/template/examples/run.ss +++ b/collects/web-server/template/examples/run.ss @@ -1,55 +1,15 @@ #lang scheme +(require scribble/text + scheme/port) -(require scheme/include - (for-syntax scheme) - (prefix-in text: scribble/text) - (for-syntax (prefix-in text: scribble/text)) - (for-syntax (prefix-in at: scribble/reader))) - -; XXX I have to do this because without it there is an infinite loop. -; at:read-syntax-inside returns #'() instead of eof -(define-for-syntax (*read-syntax . args) - (define r (apply at:read-syntax-inside args)) - (if (eof-object? r) r - (if (null? (syntax->datum r)) - eof - r))) - -(define-syntax (include-template stx) - (syntax-case stx () - [(_ a-path) - ; XXX Not desireable, but necessary to get at the body, - ; rather than it being used as a string applied to the rest - (with-syntax ([(begin (#%app body ...)) - (local-expand - (with-syntax ([_stx stx]) - (syntax/loc stx - (include-at/relative-to/reader - _stx _stx - (file a-path) *read-syntax))) - 'module-begin - empty) - ]) - (syntax/loc stx - (with-output-to-string - (begin/show body ...))))])) - -(define-syntax with-output-to-string +(define-syntax include-template (syntax-rules () - [(_ e ...) - (let ([os (open-output-string)]) - (parameterize ([current-output-port os]) - e ...) - (get-output-string os))])) + [(_ p) + (with-output-to-string + (lambda () + (output (include/text p))))])) -; XXX Want to have this instead of every begin, but perhaps should make a list rather than use show directly -(define-syntax begin/show - (syntax-rules () - [(_ e) e] - [(_ e ...) - (begin (text:output e) ...)])) (define t list) - (define-syntax in (syntax-rules () [(_ x xs e ...) From cb68faa140daf073e05e97b1bc18a12ddf18446a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 18 Nov 2008 22:02:16 +0000 Subject: [PATCH 036/193] Contract svn: r12499 --- collects/web-server/insta/insta.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/insta/insta.ss b/collects/web-server/insta/insta.ss index 4a35107704..13059eb40d 100644 --- a/collects/web-server/insta/insta.ss +++ b/collects/web-server/insta/insta.ss @@ -13,7 +13,7 @@ (define launch-browser? #t) (provide/contract - [static-files-path ((or/c string? path?) . -> . void?)]) + [static-files-path (path-string? . -> . void?)]) (define (static-files-path path) (set! extra-files-path (if (path? path) From a01728e63a7058037fcdebc24c6e5b3303d189b4 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 18 Nov 2008 22:03:44 +0000 Subject: [PATCH 037/193] Templates svn: r12500 --- collects/web-server/template/examples/basic.html | 2 +- collects/web-server/template/examples/if.html | 6 +++--- collects/web-server/template/examples/run.ss | 15 +++++++++++++-- 3 files changed, 17 insertions(+), 6 deletions(-) diff --git a/collects/web-server/template/examples/basic.html b/collects/web-server/template/examples/basic.html index e90c8dd09d..c8104be091 100644 --- a/collects/web-server/template/examples/basic.html +++ b/collects/web-server/template/examples/basic.html @@ -3,7 +3,7 @@ @in[c @clients]{ - @t{ + @list{ diff --git a/collects/web-server/template/examples/if.html b/collects/web-server/template/examples/if.html index a5a7fa3cb4..df0af05025 100644 --- a/collects/web-server/template/examples/if.html +++ b/collects/web-server/template/examples/if.html @@ -1,5 +1,5 @@ @(if (@monkeys . > . @monkey-limit) - @t{

There are too many monkeys!

} + @list{

There are too many monkeys!

} @(if (@monkeys . < . @monkey-minimum) - @t{

There aren't enough monkeys!

} - @t{

There are just enough monkeys!

})) + @list{

There aren't enough monkeys!

} + @list{

There are just enough monkeys!

})) diff --git a/collects/web-server/template/examples/run.ss b/collects/web-server/template/examples/run.ss index 98b7919883..79ec4e4f5a 100644 --- a/collects/web-server/template/examples/run.ss +++ b/collects/web-server/template/examples/run.ss @@ -1,5 +1,6 @@ #lang scheme -(require scribble/text +(require xml + scribble/text scheme/port) (define-syntax include-template @@ -9,7 +10,17 @@ (lambda () (output (include/text p))))])) -(define t list) +(define-syntax include-template/xexpr + (syntax-rules () + [(_ p) + (string->xexpr (include-template p))])) + +(define (string->xexpr s) + (with-input-from-string + s + (lambda () + (xml->xexpr (document-element (read-xml)))))) + (define-syntax in (syntax-rules () [(_ x xs e ...) From f81826e792efae09ee87c7cd7b438ea27d11c129 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 18 Nov 2008 23:22:56 +0000 Subject: [PATCH 038/193] move threads-are-not-OS-threads docs from 10 to 1.1.13 svn: r12501 --- collects/scribblings/reference/concurrency.scrbl | 8 +++----- collects/scribblings/reference/eval-model.scrbl | 8 ++++++-- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/collects/scribblings/reference/concurrency.scrbl b/collects/scribblings/reference/concurrency.scrbl index d9098d684f..e0a9ca6729 100644 --- a/collects/scribblings/reference/concurrency.scrbl +++ b/collects/scribblings/reference/concurrency.scrbl @@ -3,11 +3,9 @@ @title[#:tag "concurrency" #:style 'toc]{Concurrency} -PLT Scheme supports multiple threads of control within a -program. Threads run concurrently, in the sense that one thread can -preempt another without its cooperation, but threads currently all run -on the same processor (i.e., the same underlying OS process and -thread). +PLT Scheme supports multiple threads of control within a program, +thread-local storage, some primitive synchronization mechanisms, and a +framework for composing synchronization abstractions. @local-table-of-contents[] diff --git a/collects/scribblings/reference/eval-model.scrbl b/collects/scribblings/reference/eval-model.scrbl index b9303df996..c646ebf7f4 100644 --- a/collects/scribblings/reference/eval-model.scrbl +++ b/collects/scribblings/reference/eval-model.scrbl @@ -650,8 +650,12 @@ escape-continuation aborts can cross continuation barriers. @;------------------------------------------------------------------------ @section[#:tag "thread-model"]{Threads} -Scheme supports multiple, pre-emptive @deftech{threads} of -evaluation. Threads are created explicitly by functions such as @scheme[thread]. +Scheme supports multiple @deftech{threads} of evaluation. Threads run +concurrently, in the sense that one thread can preempt another without +its cooperation, but threads currently all run on the same processor +(i.e., the same underlying OS process and thread). + +Threads are created explicitly by functions such as @scheme[thread]. In terms of the evaluation model, each step in evaluation actually consists of multiple concurrent expressions, up to one per thread, rather than a single expression. The expressions all share the same objects and top-level variables, so that they can From f66e852163e1822d2e4e7d190408fb37c9e67edb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 18 Nov 2008 23:33:29 +0000 Subject: [PATCH 039/193] add cross-references from model section to function sections svn: r12502 --- collects/scribblings/reference/eval-model.scrbl | 17 +++++++++++++++++ collects/scribblings/reference/namespaces.scrbl | 2 +- .../scribblings/reference/syntax-model.scrbl | 3 +++ 3 files changed, 21 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/eval-model.scrbl b/collects/scribblings/reference/eval-model.scrbl index c646ebf7f4..2c75b4300c 100644 --- a/collects/scribblings/reference/eval-model.scrbl +++ b/collects/scribblings/reference/eval-model.scrbl @@ -339,6 +339,9 @@ specified with the datatype and its associated procedures. @;------------------------------------------------------------------------ @section[#:tag "gc-model"]{Garbage Collection} +@margin-note/ref{See @secref["memory"] for functions related to +garbage collection.} + In the program state @prog-steps[ @@ -504,6 +507,8 @@ access the same @tech{location}. @;------------------------------------------------------------------------ @section[#:tag "module-eval-model"]{Modules and Module-Level Variables} +@margin-note/ref{See @secref["module"] for the syntax of modules.} + Most definitions in PLT Scheme are in modules. In terms of evaluation, a module is essentially a prefix on a defined name, so that different modules can define the name. That is, a @deftech{module-level @@ -599,6 +604,8 @@ re-declared, each re-declaration of the module is immediately @;------------------------------------------------------------------------ @section[#:tag "mark-model"]{Continuation Frames and Marks} +@margin-note/ref{See @secref["contmarks"] for continuation-mark forms and functions.} + Every continuation @scheme[_C] can be partitioned into @deftech{continuation frames} @frame[1], @frame[2], ..., @frame["n"] such that @scheme[_C] = @*sub[@frame[1] @*sub[@frame[2] @*sub["..." @@ -618,6 +625,8 @@ to implement dynamic scope. @;------------------------------------------------------------------------ @section[#:tag "prompt-model"]{Prompts, Delimited Continuations, and Barriers} +@margin-note/ref{See @secref["cont"] for continuation and prompt functions.} + A @deftech{prompt} is a special kind of continuation frame that is annotated with a specific @deftech{prompt tag} (essentially a continuation mark). Various operations allow the capture of frames in @@ -650,6 +659,8 @@ escape-continuation aborts can cross continuation barriers. @;------------------------------------------------------------------------ @section[#:tag "thread-model"]{Threads} +@margin-note/ref{See @secref["concurrency"] for thread and synchronization functions.} + Scheme supports multiple @deftech{threads} of evaluation. Threads run concurrently, in the sense that one thread can preempt another without its cooperation, but threads currently all run on the same processor @@ -677,6 +688,8 @@ is created) as all other threads. @;------------------------------------------------------------------------ @section[#:tag "parameter-model"]{Parameters} +@margin-note/ref{See @secref["parameters"] for parameter forms and functions.} + @deftech{Parameters} are essentially a derived concept in Scheme; they are defined in terms of @tech{continuation marks} and @tech{thread cells}. However, parameters are also built in, in the sense that some @@ -705,6 +718,8 @@ the current continuation's frame. @;------------------------------------------------------------------------ @section[#:tag "exn-model"]{Exceptions} +@margin-note/ref{See @secref["exns"] for exception forms, functions, and types.} + @deftech{Exceptions} are essentially a derived concept in Scheme; they are defined in terms of continuations, prompts, and continuation marks. However, exceptions are also built in, in the sense that @@ -727,6 +742,8 @@ outermost frame of the continuation for any new thread. @;------------------------------------------------------------------------ @section[#:tag "custodian-model"]{Custodians} +@margin-note/ref{See @secref["custodians"] for custodian functions.} + A @deftech{custodian} manages a collection of threads, file-stream ports, TCP ports, TCP listeners, UDP sockets, and byte converters. Whenever a thread, file-stream port, TCP port, TCP listener, or UDP diff --git a/collects/scribblings/reference/namespaces.scrbl b/collects/scribblings/reference/namespaces.scrbl index 38317f83cc..1e2f38072f 100644 --- a/collects/scribblings/reference/namespaces.scrbl +++ b/collects/scribblings/reference/namespaces.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require "mz.ss") -@title{Namespaces} +@title[#:tag "Namespaces"]{Namespaces} See @secref["namespace-model"] for basic information on the @tech{namespace} model. diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index 1f44537925..79220ca738 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/collects/scribblings/reference/syntax-model.scrbl @@ -682,6 +682,9 @@ it, compiles it, and evaluates it. @;------------------------------------------------------------------------ @section[#:tag "namespace-model"]{Namespaces} +@margin-note/ref{See @secref["Namespaces"] for functions that +manipulate namespaces.} + A @deftech{namespace} is a top-level mapping from symbols to binding information. It is the starting point for expanding an expression; a @tech{syntax object} produced by @scheme[read-syntax] has no initial From 18b219bcb0ecadff00a7429ed7a9c5ac0ff482bc Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 19 Nov 2008 08:50:21 +0000 Subject: [PATCH 040/193] Welcome to a new PLT day. svn: r12505 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index eae3df392a..cd6d48b8c9 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "18nov2008") +#lang scheme/base (provide stamp) (define stamp "19nov2008") From 894224bc5256aeeadac8204a1a0424487681bc7c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 19 Nov 2008 14:27:13 +0000 Subject: [PATCH 041/193] update release notes for 4.1.3 (should be merged) svn: r12506 --- doc/release-notes/mred/HISTORY.txt | 6 ++++++ doc/release-notes/mzscheme/HISTORY.txt | 18 ++++++------------ 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index 6b682db1ab..1d97658d8b 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,3 +1,9 @@ +Version 4.1.3, November 2008 + +Minor bug fixes + +---------------------------------------------------------------------- + Version 4.1.2, October 2008 Changed -z/--text-repl to a configuration option diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 6e301a729f..dcedcf7591 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,20 +1,14 @@ -Version 4.1.2.5 +Version 4.1.3, November 2008 Changed scheme to re-export scheme/port -In scheme/port: added [call-]with-input-from-{string,bytes} and - [call-]with-output-to-{string,bytes} - -Version 4.1.2.4 +In scheme/port: added Added call-with-immediate-continuation-mark In scheme/port: added port->string, port->bytes, port->lines - port->bytes-lines, and display-lines + port->bytes-lines, display-lines, [call-]with-input-from-{string,bytes}, + and [call-]with-output-to-{string,bytes} In scheme/file: added file->string, file->bytes, file->lines, - file->value, file->bytes-lines, write-to-file, display-to-file, - and display-lines-to-file - -Version 4.1.2.3 + file->value, file->bytes-lines, write-to-file, display-to-file, + and display-lines-to-file Added variable-reference? and empty #%variable-reference form - -Version 4.1.2.1 Extended continuation-marks to work on a thread argument Version 4.1.2, October 2008 From 9ede3dbb163b63c60958b7251e3ad8a86b36a65a Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Wed, 19 Nov 2008 16:52:26 +0000 Subject: [PATCH 042/193] no sign. updates svn: r12508 --- doc/release-notes/teachpack/HISTORY.txt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index 9e267c9f5b..9033b8bac4 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,3 +1,8 @@ +------------------------------------------------------------------------ +Version 4.1.3 [Wed Nov 19 10:20:41 EST 2008] + +tiny bug fixes + ------------------------------------------------------------------------ Version 4.1.2 [Sat Oct 25 10:31:05 EDT 2008] From 83e9431ec5a3e8ec6ed0da847d4c04e14e37b5c6 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 19 Nov 2008 19:04:22 +0000 Subject: [PATCH 043/193] Templates before tests svn: r12509 --- .../htdocs/servlets/examples/static.html | 11 + .../htdocs/servlets/examples/template-full.ss | 13 + .../servlets/examples/template-simple.ss | 8 + .../servlets/examples/template-xexpr.ss | 11 + .../web-server/scribblings/templates.scrbl | 228 ++++++++++++++++++ collects/web-server/scribblings/writing.scrbl | 1 + .../web-server/template/examples/basic.html | 4 +- collects/web-server/template/examples/run.ss | 30 +-- collects/web-server/templates.ss | 31 +++ 9 files changed, 305 insertions(+), 32 deletions(-) create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/static.html create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/template-full.ss create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/template-simple.ss create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/template-xexpr.ss create mode 100644 collects/web-server/scribblings/templates.scrbl create mode 100644 collects/web-server/templates.ss diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/static.html b/collects/web-server/default-web-root/htdocs/servlets/examples/static.html new file mode 100644 index 0000000000..b211384e7a --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/static.html @@ -0,0 +1,11 @@ + + Title + +
@(client-surname c), @(client-firstname c) @(client-email c)
+ + + + +
Example, Mr.example@"@"foo.com
+ + diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/template-full.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/template-full.ss new file mode 100644 index 0000000000..5643aab6ad --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/template-full.ss @@ -0,0 +1,13 @@ +#lang scheme +(require web-server/templates + web-server/http) +(provide (all-defined-out)) +(define interface-version 'v1) +(define timeout +inf.0) + +(define (start initial-request) + (make-response/full + 200 "Okay" + (current-seconds) TEXT/HTML-MIME-TYPE + empty + (list (include-template "static.html")))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/template-simple.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/template-simple.ss new file mode 100644 index 0000000000..61ef233ab8 --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/template-simple.ss @@ -0,0 +1,8 @@ +#lang scheme +(require web-server/templates) +(provide (all-defined-out)) +(define interface-version 'v1) +(define timeout +inf.0) + +(define (start initial-request) + (list #"text/html" (include-template "static.html"))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/template-xexpr.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/template-xexpr.ss new file mode 100644 index 0000000000..28407c62ca --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/template-xexpr.ss @@ -0,0 +1,11 @@ +#lang scheme +(require web-server/templates + xml) +(provide (all-defined-out)) +(define interface-version 'v1) +(define timeout +inf.0) + +(define (start initial-request) + `(html (pre ,(include-template "static.html")) + "versus" + ,(make-cdata #f #f (include-template "static.html")))) \ No newline at end of file diff --git a/collects/web-server/scribblings/templates.scrbl b/collects/web-server/scribblings/templates.scrbl new file mode 100644 index 0000000000..a42b233b04 --- /dev/null +++ b/collects/web-server/scribblings/templates.scrbl @@ -0,0 +1,228 @@ +#lang scribble/doc +@(require "web-server.ss") +@(require (for-label web-server/servlet + web-server/templates + scheme/list + xml)) + +@(define xexpr @tech[#:doc '(lib "xml/xml.scrbl")]{X-expression}) +@(define at-reader-ref @secref[#:doc '(lib "scribblings/scribble/scribble.scrbl")]{reader}) + +@title[#:tag "templates"]{Templates} + +@defmodule[web-server/templates] + +The @web-server provides a powerful Web template system for separating the presentation logic of a Web application +and enabling non-programmers to contribute to PLT-based Web applications. + +@local-table-of-contents[] + +@section{Static} + +Suppose we have a file @filepath{static.html} with the contents: +@verbatim[#:indent 2]|{ + + Fastest Templates in the West! + +

Bang!

+

Bang!

+ + +}| + +If we write the following in our code: +@schemeblock[ + (include-template "static.html") +] + +Then the contents of @filepath{static.html} will be read @emph{at compile time} and compiled into a +Scheme program that returns the contents of @filepath{static.html} as a string: +@schemeblock[ + "\n Fastest Templates in the West!\n \n

Bang!

\n

Bang!

\n \n" +] + +@section{Dynamic} + +@scheme[include-template] gives the template access to the @emph{complete lexical context} of the including program. This context can be +accessed via the @at-reader-ref syntax. For example, if @filepath{simple.html} contains: +@verbatim[#:indent 2]|{ + + Fastest @thing in the West! + +

Bang!

+

Bang!

+ + +}| + +Then +@schemeblock[ + (let ([thing "Templates"]) + (include-template "simple.html")) +] +evaluates to the same content as the static example. + +There is no constraints on the values, the way they are used, or the way they are defined, that are made accessible to the template. +For example, +@schemeblock[ + (define (fast-template thing) + (include-template "simple.html")) + + (fast-template "Templates") + (fast-template "Noodles") +] +evalutes to two strings with the predictable contents: +@verbatim[#:indent 2]|{ + + Fastest Templates in the West! + +

Bang!

+

Bang!

+ + +}| + +and + +@verbatim[#:indent 2]|{ + + Fastest Noodles in the West! + +

Bang!

+

Bang!

+ + +}| + +@section{Gotchas} + +One of the most important things to remember about the @at-reader-ref syntax is that the @"@" symbol must be escaped in content: +@verbatim[#:indent 2]|{ + + Fastest @"@"s in the West! + +

Bang!

+

Bang!

+ + +}| + +The other gotcha is that since the template is compiled into a Scheme program, only its results will be printed. For example, suppose +we have the template: +@verbatim[#:indent 2]|{ + + @for[([c clients])]{ + + } +
@(car c), @(cdr c)
+}| + +If this is included in a lexical context with @scheme[clients] bound to @scheme[(list (cons "Young" "Brigham") (cons "Smith" "Joseph"))], +then the template will be printed as: +@verbatim[#:indent 2]|{ + +
+}| +because @scheme[for] does not return the value of the body. +Suppose that we change the template to use @scheme[for/list] (which combines them into a list): +@verbatim[#:indent 2]|{ + + @for/list[([c clients])]{ + + } +
@(car c), @(cdr c)
+}| + +Now the result is: +@verbatim[#:indent 2]|{ + + + +
+}| +because only the final expression of the body of the @scheme[for/list] is included in the result. We can capture all the sub-expressions +by using @scheme[list] in the body: +@verbatim[#:indent 2]|{ + + @for/list[([c clients])]{ + @list{ + + } + } +
@(car c), @(cdr c)
+}| +Now the result is: +@verbatim[#:indent 2]|{ + + + +
Young, Brigham
Smith, Joseph
+}| + +The templating library provides a syntactic form to deal with this issue for you called @scheme[in]: +@verbatim[#:indent 2]|{ + + @in[c clients]{ + + } +
@(car c), @(cdr c)
+}| +Notice how it also avoids the absurd amount of punctuation on line two. + +@section{HTTP Responses} + +The quickest way to generate an HTTP response from a template is using the @scheme[list] response type: +@schemeblock[ + (list #"text/html" (include-template "static.html")) +] + +If you want more control then you can generate a @scheme[response/full] struct: +@schemeblock[ + (make-response/full + 200 "Okay" + (current-seconds) TEXT/HTML-MIME-TYPE + empty + (list (include-template "static.html"))) +] + +Finally, if you want to include the contents of a template inside a larger @xexpr : +@schemeblock[ + `(html ,(include-template "static.html")) +] +will result in the literal string being included (and entity-escaped). If you actually want +the template to be unescaped, then create a @scheme[cdata] structure: +@schemeblock[ + `(html ,(make-cdata #f #f (include-template "static.html"))) +] + +@section{API Details} + +@defform[(include-template path)]{ + Compiles the template at @scheme[path] using the @at-reader-ref syntax within the enclosing lexical context. + + Example: + @schemeblock[ + (include-template "static.html") + ] +} + +@defform[(in x xs e ...)]{ + Expands into + @schemeblock[ + (for/list ([x xs]) + (list e ...)) + ] + + Template Example: + @verbatim[#:indent 2]|{ + @in[c clients]{ + @(car c), @(cdr c) + } + }| + + Scheme Example: + @schemeblock[ + (in c clients "" (car c) ", " (cdr c) "") + ] +} + \ No newline at end of file diff --git a/collects/web-server/scribblings/writing.scrbl b/collects/web-server/scribblings/writing.scrbl index 56b08917a6..2f3de6e8ef 100644 --- a/collects/web-server/scribblings/writing.scrbl +++ b/collects/web-server/scribblings/writing.scrbl @@ -165,4 +165,5 @@ things in the Web Language, they are sensitive to source code modification. @; ------------------------------------------------------------ @include-section["formlets.scrbl"] +@include-section["templates.scrbl"] @include-section["managers.scrbl"] diff --git a/collects/web-server/template/examples/basic.html b/collects/web-server/template/examples/basic.html index c8104be091..ed0197c19b 100644 --- a/collects/web-server/template/examples/basic.html +++ b/collects/web-server/template/examples/basic.html @@ -2,13 +2,11 @@ @title - @in[c @clients]{ - @list{ + @in[c clients]{ - } }
@(client-surname c), @(client-firstname c) @(client-email c)
diff --git a/collects/web-server/template/examples/run.ss b/collects/web-server/template/examples/run.ss index 79ec4e4f5a..ec85009b99 100644 --- a/collects/web-server/template/examples/run.ss +++ b/collects/web-server/template/examples/run.ss @@ -1,33 +1,5 @@ #lang scheme -(require xml - scribble/text - scheme/port) - -(define-syntax include-template - (syntax-rules () - [(_ p) - (with-output-to-string - (lambda () - (output (include/text p))))])) - -(define-syntax include-template/xexpr - (syntax-rules () - [(_ p) - (string->xexpr (include-template p))])) - -(define (string->xexpr s) - (with-input-from-string - s - (lambda () - (xml->xexpr (document-element (read-xml)))))) - -(define-syntax in - (syntax-rules () - [(_ x xs e ...) - (for/list ([x xs]) - e ...)])) - -; Examples +(require web-server/templates) (include-template "static.html") diff --git a/collects/web-server/templates.ss b/collects/web-server/templates.ss new file mode 100644 index 0000000000..5ee1b8798f --- /dev/null +++ b/collects/web-server/templates.ss @@ -0,0 +1,31 @@ +#lang scheme +(require xml + scribble/text + scheme/port) + +(define-syntax include-template + (syntax-rules () + [(_ p) + (with-output-to-string + (lambda () + (output (include/text p))))])) + +(define-syntax include-template/xexpr + (syntax-rules () + [(_ p) + (string->xexpr (include-template p))])) + +(define (string->xexpr s) + (with-input-from-string + s + (lambda () + (xml->xexpr (document-element (read-xml)))))) + +(define-syntax in + (syntax-rules () + [(_ x xs e ...) + (for/list ([x xs]) + (list e ...))])) + +(provide include-template + in) \ No newline at end of file From a687555c38a0acf49cf763a341021acd3d76a638 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 19 Nov 2008 22:22:02 +0000 Subject: [PATCH 044/193] moving tests svn: r12512 --- collects/{ => tests}/web-server/template/examples/basic.html | 0 collects/{ => tests}/web-server/template/examples/if.html | 0 collects/{ => tests}/web-server/template/examples/run.ss | 0 collects/{ => tests}/web-server/template/examples/static.html | 0 4 files changed, 0 insertions(+), 0 deletions(-) rename collects/{ => tests}/web-server/template/examples/basic.html (100%) rename collects/{ => tests}/web-server/template/examples/if.html (100%) rename collects/{ => tests}/web-server/template/examples/run.ss (100%) rename collects/{ => tests}/web-server/template/examples/static.html (100%) diff --git a/collects/web-server/template/examples/basic.html b/collects/tests/web-server/template/examples/basic.html similarity index 100% rename from collects/web-server/template/examples/basic.html rename to collects/tests/web-server/template/examples/basic.html diff --git a/collects/web-server/template/examples/if.html b/collects/tests/web-server/template/examples/if.html similarity index 100% rename from collects/web-server/template/examples/if.html rename to collects/tests/web-server/template/examples/if.html diff --git a/collects/web-server/template/examples/run.ss b/collects/tests/web-server/template/examples/run.ss similarity index 100% rename from collects/web-server/template/examples/run.ss rename to collects/tests/web-server/template/examples/run.ss diff --git a/collects/web-server/template/examples/static.html b/collects/tests/web-server/template/examples/static.html similarity index 100% rename from collects/web-server/template/examples/static.html rename to collects/tests/web-server/template/examples/static.html From 117f01698220739fe967a40f91e1db65f7b06d56 Mon Sep 17 00:00:00 2001 From: John Clements Date: Wed, 19 Nov 2008 22:31:39 +0000 Subject: [PATCH 045/193] 4.1.3 history update svn: r12513 --- doc/release-notes/stepper/HISTORY.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/release-notes/stepper/HISTORY.txt b/doc/release-notes/stepper/HISTORY.txt index b80dff5077..fe02426a99 100644 --- a/doc/release-notes/stepper/HISTORY.txt +++ b/doc/release-notes/stepper/HISTORY.txt @@ -1,6 +1,10 @@ Stepper ------- +Changes for v4.1.3: + +Minor bug fixes. + Changes for v4.1.2: None. From 8f0544f37d0d7d061852c6eda3dcb7237e30c741 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 19 Nov 2008 22:41:49 +0000 Subject: [PATCH 046/193] Bug after moving instance lookup inside servlet namespace svn: r12514 --- .../dispatchers/dispatch-servlets.ss | 18 +--------- collects/web-server/private/servlet.ss | 4 --- collects/web-server/servlet/setup.ss | 33 +++++++++++-------- 3 files changed, 21 insertions(+), 34 deletions(-) diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index cf0147436f..a28932d4db 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -51,10 +51,6 @@ #:responders-servlet (url? any/c . -> . response?)) dispatcher/c)]) -;; default-server-instance-expiration-handler : (request -> response) -(define (default-servlet-instance-expiration-handler req) - (next-dispatcher)) - (define (make url->servlet #:responders-servlet-loading [responders-servlet-loading servlet-loading-responder] #:responders-servlet [responders-servlet servlet-error-responder]) @@ -70,15 +66,6 @@ (define response (with-handlers ([exn:fail:filesystem:exists? (lambda (the-exn) (next-dispatcher))] - [exn:fail:servlet-manager:no-instance? - (lambda (the-exn) - ((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) req))] - [exn:fail:servlet-manager:no-continuation? - (lambda (the-exn) - ((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) req))] - [exn:fail:servlet:instance? - (lambda (the-exn) - (default-servlet-instance-expiration-handler req))] [(lambda (x) #t) (lambda (the-exn) (responders-servlet-loading uri the-exn))]) (define the-servlet (url->servlet uri)) @@ -87,10 +74,7 @@ [current-directory (servlet-directory the-servlet)] [current-namespace (servlet-namespace the-servlet)]) (with-handlers ([(lambda (x) #t) - (lambda (exn) - (responders-servlet - (request-uri req) - exn))]) + (lambda (exn) (responders-servlet uri exn))]) (call-with-continuation-barrier (lambda () (call-with-continuation-prompt diff --git a/collects/web-server/private/servlet.ss b/collects/web-server/private/servlet.ss index 392d740b75..482f394fff 100644 --- a/collects/web-server/private/servlet.ss +++ b/collects/web-server/private/servlet.ss @@ -4,7 +4,6 @@ web-server/http) (define servlet-prompt (make-continuation-prompt-tag 'servlet)) -(define-struct (exn:fail:servlet:instance exn:fail) ()) (define-struct servlet (custodian namespace manager directory handler) #:mutable) (define-struct execution-context (request)) @@ -18,9 +17,6 @@ (provide/contract [servlet-prompt continuation-prompt-tag?] - [struct (exn:fail:servlet:instance exn:fail) - ([message string?] - [continuation-marks continuation-mark-set?])] [struct servlet ([custodian custodian?] [namespace namespace?] diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss index 2cecb0b0d5..b3d85f1451 100644 --- a/collects/web-server/servlet/setup.ss +++ b/collects/web-server/servlet/setup.ss @@ -49,19 +49,26 @@ (lambda (req) (define uri (request-uri req)) - (define-values (instance-id handler) - (cond - [(continuation-url? uri) - => (match-lambda - [(list instance-id k-id salt) - (values instance-id - (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])] - [else - (values ((manager-create-instance manager) (exit-handler)) - start)])) - - (parameterize ([current-servlet-instance-id instance-id]) - (handler req))))) + (with-handlers ([exn:fail:servlet-manager:no-instance? + (lambda (the-exn) + ((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) req))] + [exn:fail:servlet-manager:no-continuation? + (lambda (the-exn) + ((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) req))]) + + (define-values (instance-id handler) + (cond + [(continuation-url? uri) + => (match-lambda + [(list instance-id k-id salt) + (values instance-id + (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])] + [else + (values ((manager-create-instance manager) (exit-handler)) + start)])) + + (parameterize ([current-servlet-instance-id instance-id]) + (handler req)))))) (define (make-stateless.servlet directory start) (define ses From 8dad54e520a10471b1879b2f960365b1fa718301 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 19 Nov 2008 22:49:43 +0000 Subject: [PATCH 047/193] Fix doc typo. svn: r12515 --- collects/net/scribblings/url.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/net/scribblings/url.scrbl b/collects/net/scribblings/url.scrbl index 43fa60828c..287c374e2c 100644 --- a/collects/net/scribblings/url.scrbl +++ b/collects/net/scribblings/url.scrbl @@ -44,7 +44,7 @@ re-exported by @schememodname[net/url].} [query (listof (cons/c symbol? (or/c false/c string?)))] [fragment (or/c false/c string?)])]{ -The basic structure for all URLs, hich is explained in RFC 3986 +The basic structure for all URLs, which is explained in RFC 3986 @cite["RFC3986"]. The following diagram illustrates the parts: @verbatim[#:indent 2]|{ From a4ac14b124cb70127897fcb117d4d9312ab17518 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 19 Nov 2008 22:50:10 +0000 Subject: [PATCH 048/193] Add scheme/tcp bindings. svn: r12516 --- collects/typed-scheme/private/base-env.ss | 15 ++++++++++++++- .../private/type-effect-convenience.ss | 3 ++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 1bcfa78f87..641376322e 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -2,6 +2,7 @@ (require scheme/list + scheme/tcp (only-in rnrs/lists-6 fold-left) '#%paramz (only-in '#%kernel [apply kernel:apply]) @@ -480,4 +481,16 @@ [eof (-val eof)] [read-accept-reader (-Param B B)] -[maybe-print-message (-String . -> . -Void)] \ No newline at end of file +[maybe-print-message (-String . -> . -Void)] + +;; scheme/tcp +[tcp-listener? (make-pred-ty -TCP-Listener)] +[tcp-abandon-port (-Port . -> . -Void)] +[tcp-accept (-TCP-Listener . -> . (-values (list -Input-Port -Output-Port)) )] +[tcp-accept/enable-break (-TCP-Listener . -> . (-values (list -Input-Port -Output-Port)) )] +[tcp-accept-ready? (-TCP-Listener . -> . B )] +[tcp-addresses (-Port . -> . (-values (list N N)))] +[tcp-close (-TCP-Listener . -> . -Void )] +[tcp-connect (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] +[tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] +[tcp-listen (N . -> . -TCP-Listener)] \ No newline at end of file diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 6776fe5419..217e0c0c7d 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -12,7 +12,7 @@ scheme/promise (for-syntax macro-debugger/stxclass/stxclass) (for-syntax scheme/base) - (for-template scheme/base scheme/contract)) + (for-template scheme/base scheme/contract scheme/tcp)) (provide (all-defined-out) ;; these should all eventually go away @@ -134,6 +134,7 @@ (define -Namespace (make-Base 'Namespace #'namespace?)) (define -Output-Port (make-Base 'Output-Port #'output-port?)) (define -Input-Port (make-Base 'Input-Port #'input-port?)) +(define -TCP-Listener (make-Base 'TCP-Listener #'tcp-listener?)) (define -Syntax make-Syntax) (define -HT make-Hashtable) From 66b9b932ef7d5b5eec53731ec7f196ba4d6b263f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 19 Nov 2008 22:50:54 +0000 Subject: [PATCH 049/193] Refactor require/typed/provide and dt into new private dir. svn: r12517 --- collects/typed/framework/framework.ss | 3 ++- collects/typed/mred/mred.ss | 10 +--------- collects/typed/private/utils.ss | 11 +++++++++++ 3 files changed, 14 insertions(+), 10 deletions(-) create mode 100644 collects/typed/private/utils.ss diff --git a/collects/typed/framework/framework.ss b/collects/typed/framework/framework.ss index fab2f91dff..513cfa1d29 100644 --- a/collects/typed/framework/framework.ss +++ b/collects/typed/framework/framework.ss @@ -1,6 +1,7 @@ #lang typed-scheme -(require (only-in typed/mred/mred dt require/typed/provide Font%)) +(require typed/private/utils + (only-in typed/mred/mred Font%)) (dt Style-List% (Class () () diff --git a/collects/typed/mred/mred.ss b/collects/typed/mred/mred.ss index 03f60efbd5..80984c28a8 100644 --- a/collects/typed/mred/mred.ss +++ b/collects/typed/mred/mred.ss @@ -1,14 +1,6 @@ #lang typed-scheme -(define-syntax-rule (dt nm t) - (begin (define-type-alias nm t) (provide nm))) - -(define-syntax-rule (require/typed/provide lib [nm t] ...) - (begin - (require/typed lib [nm t] ...) - (provide nm ...))) - -(provide dt require/typed/provide) +(require typed/private/utils) (dt Bitmap% (Class (Number Number Boolean) () diff --git a/collects/typed/private/utils.ss b/collects/typed/private/utils.ss new file mode 100644 index 0000000000..c1fdbea7f6 --- /dev/null +++ b/collects/typed/private/utils.ss @@ -0,0 +1,11 @@ +#lang typed-scheme + +(define-syntax-rule (dt nm t) + (begin (define-type-alias nm t) (provide nm))) + +(define-syntax-rule (require/typed/provide lib [nm t] ...) + (begin + (require/typed lib [nm t] ...) + (provide nm ...))) + +(provide dt require/typed/provide) From 7124d1e1a1a4e04f4fb23fb2a2d02a82fd6b5426 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 19 Nov 2008 22:51:24 +0000 Subject: [PATCH 050/193] Typed wrappers for file/gif and almost all of net/*. svn: r12518 --- collects/typed/file/gif.ss | 17 ++++++++ collects/typed/net/base64.ss | 13 ++++++ collects/typed/net/cgi.ss | 27 +++++++++++++ collects/typed/net/cookie.ss | 23 +++++++++++ collects/typed/net/dns.ss | 10 +++++ collects/typed/net/ftp.ss | 16 ++++++++ collects/typed/net/gifwrite.ss | 4 ++ collects/typed/net/head.ss | 31 ++++++++++++++ collects/typed/net/imap.ss | 55 +++++++++++++++++++++++++ collects/typed/net/mime.ss | 71 +++++++++++++++++++++++++++++++++ collects/typed/net/nntp.ss | 31 ++++++++++++++ collects/typed/net/pop3.ss | 38 ++++++++++++++++++ collects/typed/net/qp.ss | 10 +++++ collects/typed/net/sendmail.ss | 12 ++++++ collects/typed/net/sendurl.ss | 9 +++++ collects/typed/net/smtp.ss | 11 +++++ collects/typed/net/uri-codec.ss | 15 +++++++ collects/typed/net/url.ss | 59 +++++++++++++++++++++++++++ 18 files changed, 452 insertions(+) create mode 100644 collects/typed/file/gif.ss create mode 100644 collects/typed/net/base64.ss create mode 100644 collects/typed/net/cgi.ss create mode 100644 collects/typed/net/cookie.ss create mode 100644 collects/typed/net/dns.ss create mode 100644 collects/typed/net/ftp.ss create mode 100644 collects/typed/net/gifwrite.ss create mode 100644 collects/typed/net/head.ss create mode 100644 collects/typed/net/imap.ss create mode 100644 collects/typed/net/mime.ss create mode 100644 collects/typed/net/nntp.ss create mode 100644 collects/typed/net/pop3.ss create mode 100644 collects/typed/net/qp.ss create mode 100644 collects/typed/net/sendmail.ss create mode 100644 collects/typed/net/sendurl.ss create mode 100644 collects/typed/net/smtp.ss create mode 100644 collects/typed/net/uri-codec.ss create mode 100644 collects/typed/net/url.ss diff --git a/collects/typed/file/gif.ss b/collects/typed/file/gif.ss new file mode 100644 index 0000000000..3a17435eb0 --- /dev/null +++ b/collects/typed/file/gif.ss @@ -0,0 +1,17 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/opaque-type GIF-Stream gif-stream? file/gif) + +(require/typed/provide file/gif + [gif-start ( Output-Port Number Number Number (U #f (Listof (Vectorof Number))) -> Void )] + [gif-add-image ( GIF-Stream Number Number Number Number Boolean (U #f Number) String -> Void )] + [gif-add-control ( GIF-Stream Symbol Boolean Number (U #f Number) -> Void)] + [gif-add-loop-control ( GIF-Stream Number -> Void )] + [gif-add-comment ( GIF-Stream String -> Void )] + [gif-end ( GIF-Stream -> Void )] + [quantize ( String -> (values String (Listof (Vectorof Number)) (U #f (Vectorof Number))))]) + +(provide gif-stream? GIF-Stream) + \ No newline at end of file diff --git a/collects/typed/net/base64.ss b/collects/typed/net/base64.ss new file mode 100644 index 0000000000..13061e4ea5 --- /dev/null +++ b/collects/typed/net/base64.ss @@ -0,0 +1,13 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/base64 + [base64-encode-stream (case-lambda (Input-Port Output-Port -> Void) + (Input-Port Output-Port Bytes -> Void))] + [base64-decode-stream (Input-Port Output-Port -> Void)] + [base64-encode (Bytes -> Bytes)] + [base64-decode (Bytes -> Bytes)]) + +(provide base64-encode-stream base64-decode-stream base64-encode base64-decode) + \ No newline at end of file diff --git a/collects/typed/net/cgi.ss b/collects/typed/net/cgi.ss new file mode 100644 index 0000000000..7287e6f073 --- /dev/null +++ b/collects/typed/net/cgi.ss @@ -0,0 +1,27 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require-typed-struct cgi-error () net/cgi) +(require-typed-struct incomplete-%-suffix ([chars : (Listof Char)]) net/cgi) +(require-typed-struct invalid-%-suffix ([char : Char]) net/cgi) + +(require/typed/provide net/cgi + [get-bindings (-> (Listof (cons (U Symbol String) String)))] + [get-bindings/post (-> (Listof (Pair (U Symbol String) String)))] + [get-bindings/get (-> (Listof (Pair (U Symbol String) String)) )] + [output-http-headers (-> Void)] + [generate-html-output (case-lambda (String (Listof String) -> Void) + (String (Listof String) String String String String String -> Void))] + [generate-error-output ((Listof String) -> (U))] + [bindings-as-html ((Listof (cons (U Symbol String) String)) -> (Listof String))] + [extract-bindings ((U Symbol String) (Listof (cons (U Symbol String) String)) -> ( Listof String))] + [extract-binding/single ((U Symbol String) (Listof (Pair (U Symbol String) String)) -> String)] + [get-cgi-method (-> (U "GET" "POST"))] + [string->html (String -> String)] + [generate-link-text (String String -> String)]) + +(provide + (struct-out cgi-error) + (struct-out incomplete-%-suffix) + (struct-out invalid-%-suffix)) \ No newline at end of file diff --git a/collects/typed/net/cookie.ss b/collects/typed/net/cookie.ss new file mode 100644 index 0000000000..f2ff60224c --- /dev/null +++ b/collects/typed/net/cookie.ss @@ -0,0 +1,23 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/opaque-type Cookie cookie? net/cookie) + +(require/typed/provide net/cookie + [set-cookie (String String -> Cookie)] + [cookie:add-comment (Cookie String -> Cookie)] + [cookie:add-domain (Cookie String -> Cookie)] + [cookie:add-max-age (Cookie Number -> Cookie)] + [cookie:add-path (Cookie String -> Cookie)] + [cookie:secure (Cookie Boolean -> Cookie)] + [cookie:version (Cookie Number -> Cookie)] + + [print-cookie (Cookie -> String)] + + [get-cookie (String String -> (Listof String))] + [get-cookie/single (String String -> (Option String))]) + +(require-typed-struct cookie-error () net/cookie) + +(provide Cookie cookie? (struct-out cookie-error)) \ No newline at end of file diff --git a/collects/typed/net/dns.ss b/collects/typed/net/dns.ss new file mode 100644 index 0000000000..24ef679f81 --- /dev/null +++ b/collects/typed/net/dns.ss @@ -0,0 +1,10 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/dns + [dns-get-address (String String -> String)] + [dns-get-name (String String -> String)] + [dns-get-mail-exchanger (String String -> String )] + [dns-find-nameserver (-> (Option String))]) + diff --git a/collects/typed/net/ftp.ss b/collects/typed/net/ftp.ss new file mode 100644 index 0000000000..041befc0d5 --- /dev/null +++ b/collects/typed/net/ftp.ss @@ -0,0 +1,16 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/opaque-type FTP-Connection ftp-connection? net/ftp) + +(require/typed/provide net/ftp + [ftp-cd (FTP-Connection String -> Void)] + [ftp-establish-connection (String Number String String -> FTP-Connection)] + [ftp-close-connection (FTP-Connection -> Void)] + [ftp-directory-list (FTP-Connection -> (Listof (List (U "-" "d" "l") String String)))] + [ftp-download-file (FTP-Connection Path String -> Void)] + [ftp-make-file-seconds (String -> Number)]) + +(provide ftp-connection? FTP-Connection) + diff --git a/collects/typed/net/gifwrite.ss b/collects/typed/net/gifwrite.ss new file mode 100644 index 0000000000..cfe9167c5b --- /dev/null +++ b/collects/typed/net/gifwrite.ss @@ -0,0 +1,4 @@ +#lang typed-scheme + +(require typed/file/gif) +(provide (all-from-out typed/file/gif)) diff --git a/collects/typed/net/head.ss b/collects/typed/net/head.ss new file mode 100644 index 0000000000..958eea1ef7 --- /dev/null +++ b/collects/typed/net/head.ss @@ -0,0 +1,31 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/head + [empty-header String] + [validate-header (String -> Void)] + [extract-field (Bytes (U Bytes String) -> (Option Bytes))] + [remove-field (String String -> String)] + [insert-field (String String String -> String)] + [replace-field (String String String -> String)] + [extract-all-fields ((U String Bytes) -> (Listof (cons (U String Bytes) (U Bytes String))))] + [append-headers (String String -> String)] + [standard-message-header (String (Listof String) (Listof String) (Listof String) String -> String)] + [data-lines->data ((Listof String) -> String)] + [extract-addresses (String Symbol -> (U (Listof String) (Listof (Listof String))))] + [assemble-address-field ((Listof String) -> String)]) + +(provide + empty-header + validate-header + extract-field + remove-field + insert-field + replace-field + extract-all-fields + append-headers + standard-message-header + data-lines->data + extract-addresses + assemble-address-field) \ No newline at end of file diff --git a/collects/typed/net/imap.ss b/collects/typed/net/imap.ss new file mode 100644 index 0000000000..a4639fad19 --- /dev/null +++ b/collects/typed/net/imap.ss @@ -0,0 +1,55 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/opaque-type IMAP-Connection imap-connection? net/imap) + +(define-type-alias bstring (U String Bytes)) + +(require/typed/provide net/imap + [imap-port-number (Number -> Void)] + + [imap-connect (String String String String -> (values IMAP-Connection Number Number))] + [imap-connect* (Number Number String String String -> (values IMAP-Connection Number Number))] + [imap-disconnect (IMAP-Connection -> Void)] + [imap-force-disconnect (IMAP-Connection -> Void)] + [imap-reselect (IMAP-Connection String -> (values Number Number))] + [imap-examine (IMAP-Connection String -> (values Number Number))] + [imap-noop (IMAP-Connection -> (values Number Number))] + [imap-status (IMAP-Connection String (Listof Symbol) -> (Listof (Listof Number)))] + [imap-poll (IMAP-Connection -> Void)] + + [imap-new? (IMAP-Connection -> Boolean)] + [imap-messages (IMAP-Connection -> Number)] + [imap-recent (IMAP-Connection -> Number)] + [imap-uidnext (IMAP-Connection -> (Option Number))] + [imap-uidvalidity (IMAP-Connection -> (Option Number))] + [imap-unseen (IMAP-Connection -> (Option Number))] + [imap-reset-new! (IMAP-Connection -> Void)] + + [imap-get-expunges (IMAP-Connection -> (Listof Number))] + [imap-pending-expunges? (IMAP-Connection -> Boolean)] + [imap-get-updates (IMAP-Connection -> (Listof (cons Number (Listof (Pair Any Any)))))] + [imap-pending-updates? (IMAP-Connection -> Boolean)] + + [imap-get-messages + (IMAP-Connection (Listof Number) Symbol -> (Listof (Listof (U Number String String (Listof Symbol)))))] + [imap-copy (IMAP-Connection (Listof Number) String -> Void)] + [imap-append (IMAP-Connection String String -> Void)] + [imap-store (IMAP-Connection Symbol (Listof Number) Symbol -> Void)] + [imap-flag->symbol (Symbol -> Symbol)] + [symbol->imap-flag (Symbol -> Symbol)] + [imap-expunge (IMAP-Connection -> Void)] + + [imap-mailbox-exists? (IMAP-Connection String -> Boolean)] + [imap-create-mailbox (IMAP-Connection String -> Void)] + + [imap-list-child-mailboxes + (case-lambda (IMAP-Connection bstring -> (Listof (cons (Listof Symbol) (cons String '())))) + (IMAP-Connection bstring (Option bstring) -> (Listof (List (Listof Symbol) String))))] + [imap-mailbox-flags (IMAP-Connection String -> (Listof Symbol))] + [imap-get-hierarchy-delimiter (IMAP-Connection -> String)]) + +(provide + imap-connection? + IMAP-Connection) \ No newline at end of file diff --git a/collects/typed/net/mime.ss b/collects/typed/net/mime.ss new file mode 100644 index 0000000000..167f000335 --- /dev/null +++ b/collects/typed/net/mime.ss @@ -0,0 +1,71 @@ +#lang typed-scheme + +(require typed/private/utils) +;; -- basic mime structures -- +(require-typed-struct disposition + ([type : Symbol] + [filename : String] + [creation : String] + [modification : String] + [read : String] + [size : Number] + [params : Any]) + net/mime) +(require-typed-struct entity ([type : (U Symbol String)] + [subtype : (U Symbol String)] + [charset : (U Symbol String)] + [encoding : Symbol] + [disposition : disposition ] + [params : (Listof (cons Symbol String))] + [id : String] + [description : String] + [other : String] + [fields : Any] + [parts : (Listof String) ] + [body : (Output-Port -> Void)]) + net/mime) +(require-typed-struct message + ([version : String] [entity : entity] [fields : (Listof Symbol)]) + net/mime) + + +;; -- exceptions raised -- +(require/typed mime-error? (Any -> Boolean : (Opaque mime-error?)) net/mime) +(require/typed unexpected-termination? (Any -> Boolean :(Opaque unexpected-termination?)) net/mime) +(require/typed unexpected-termination-msg ((Opaque unexpected-termination?) -> message) net/mime) +(require/typed missing-multipart-boundary-parameter? (Any -> Boolean : (Opaque missing-multipart-boundary-parameter?)) net/mime) +(require/typed malformed-multipart-entity? (Any -> Boolean : (Opaque malformed-multipart-entity?)) net/mime) +(require/typed malformed-multipart-entity-msg ((Opaque malformed-multipart-entity?)-> message) net/mime) +(require/typed empty-mechanism? (Any -> Boolean : (Opaque empty-mechanism?)) net/mime) +(require/typed empty-type? (Any -> Boolean : (Opaque empty-type?)) net/mime) +(require/typed empty-subtype? (Any -> Boolean : (Opaque empty-subtype?)) net/mime) +(require/typed empty-disposition-type? (Any -> Boolean : (Opaque empty-disposition-type?)) net/mime) + + +;; -- mime methods -- +(require/typed/provide net/mime + [mime-analyze ((U Bytes Input-Port) Any -> message)]) + +(provide + ;; -- exceptions raised -- + mime-error? + unexpected-termination? + unexpected-termination-msg + missing-multipart-boundary-parameter? + malformed-multipart-entity? + malformed-multipart-entity-msg + empty-mechanism? + empty-type? + empty-subtype? + empty-disposition-type? + + ;; -- basic mime structures -- + message + entity + + disposition + + ;; -- mime methods -- + mime-analyze +) + diff --git a/collects/typed/net/nntp.ss b/collects/typed/net/nntp.ss new file mode 100644 index 0000000000..04468077f1 --- /dev/null +++ b/collects/typed/net/nntp.ss @@ -0,0 +1,31 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require-typed-struct communicator ([sender : Number] [receiver : Number] [server : String] [port : Number]) + net/nntp) + +(require/typed/provide net/nntp + [connect-to-server (case-lambda (String -> communicator) (String Number -> communicator))] + [disconnect-from-server (communicator -> Void)] + [authenticate-user (communicator String String -> Void)] + [open-news-group (communicator String -> (values Number Number Number))] + [head-of-message (communicator Number -> (Listof String))] + [body-of-message (communicator Number -> (Listof String))] + [newnews-since (communicator Number -> (Listof String))] + [generic-message-command (communicator Number -> (Listof String))] + [make-desired-header (String -> String)] ;;-> Regexp + [extract-desired-headers ((Listof String) (Listof String) -> (Listof String))]) ;;2nd: Of Regexp +#| +;; requires structure inheritance +(require-typed-struct nntp ()] +(require-typed-struct unexpected-response ([code : Number] [text : String])] +(require-typed-struct bad-status-line ([line : String])] +(require-typed-struct premature-close ([communicator : communicator])] +(require-typed-struct bad-newsgroup-line ([line : String])] +(require-typed-struct non-existent-group ([group : String])] +(require-typed-struct article-not-in-group ([article : Number])] +(require-typed-struct no-group-selected ()] +(require-typed-struct article-not-found ([article : Number])] +(require-typed-struct authentication-rejected ()] +|# diff --git a/collects/typed/net/pop3.ss b/collects/typed/net/pop3.ss new file mode 100644 index 0000000000..8ecaa8f528 --- /dev/null +++ b/collects/typed/net/pop3.ss @@ -0,0 +1,38 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require-typed-struct communicator ([sender : Number] [receiver : Number] [server : String] [port : Number] [state : Symbol])net/pop3) + +(require/typed/provide net/pop3 + [connect-to-server ( case-lambda (String -> (Opaque communicator?)) (String Number -> (Opaque communicator?)) )] + + [disconnect-from-server ( (Opaque communicator?) -> Void )] + [authenticate/plain-text ( String String (Opaque communicator?) -> Void )] + [get-mailbox-status ( (Opaque communicator?) -> (values Number Number) )] + [get-message/complete ( (Opaque communicator?) Number -> (values (Listof String)(Listof String)) )] + [get-message/headers ( (Opaque communicator?) Number -> (Listof String) )] + [get-message/body ( (Opaque communicator?) Number -> (Listof String) )] + [delete-message ( (Opaque communicator?) Number -> Void )] + [get-unique-id/single ( (Opaque communicator?) Number -> String )] + [get-unique-id/all ( (Opaque communicator?) -> (Listof (cons Number String)) )] + + [make-desired-header ( String -> String )];-> Regexp + [extract-desired-headers ( (Listof String)(Listof String)-> (Listof String) )];2nd:of Regexp + ) +(provide (struct-out communicator)) + +#| +(require-typed-struct pop3 ()] +(require-typed-struct cannot-connect ()] +(require-typed-struct username-rejected ()] +(require-typed-struct password-rejected ()] +(require-typed-struct not-ready-for-transaction ([ communicator : (Opaque communicator?) ])net/pop3) +(require-typed-struct not-given-headers ([ communicator : (Opaque communicator?) ] [message : String])] +(require-typed-struct illegal-message-number ([communicator : (Opaque communicator?)] [message : String])] +(require-typed-struct cannot-delete-message ([communicator : (Opaque communicator?)] [message : String])] +(require-typed-struct disconnect-not-quiet ([communicator : (Opaque communicator?)])] +(require-typed-struct malformed-server-response ([communicator : (Opaque communicator?)])net/pop3) +|# + + \ No newline at end of file diff --git a/collects/typed/net/qp.ss b/collects/typed/net/qp.ss new file mode 100644 index 0000000000..092ccdde3a --- /dev/null +++ b/collects/typed/net/qp.ss @@ -0,0 +1,10 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/qp + [qp-encode ( String -> String )] + [qp-decode ( String -> String )] + [qp-encode-stream (case-lambda (Input-Port Output-Port -> Void) (Input-Port Output-Port String -> Void) )] + [qp-decode-stream ( Input-Port Output-Port -> Void )]) + \ No newline at end of file diff --git a/collects/typed/net/sendmail.ss b/collects/typed/net/sendmail.ss new file mode 100644 index 0000000000..1dd748d8be --- /dev/null +++ b/collects/typed/net/sendmail.ss @@ -0,0 +1,12 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/sendmail + [send-mail-message/port + (String String (Listof String) (Listof String) (Listof String) String * -> Output-Port)] + [send-mail-message + (String String (Listof String) (Listof String) (Listof String) (Listof String) String * -> Output-Port)]) + +(provide send-mail-message/port send-mail-message #;no-mail-recipients) + \ No newline at end of file diff --git a/collects/typed/net/sendurl.ss b/collects/typed/net/sendurl.ss new file mode 100644 index 0000000000..205096db36 --- /dev/null +++ b/collects/typed/net/sendurl.ss @@ -0,0 +1,9 @@ +#lang typed-scheme +(require/typed net/sendurl + [send-url (String -> Void)] + [unix-browser-list (Listof Symbol)] + [browser-preference? (String -> Boolean)] + [external-browser (-> (U Symbol #f (Pair String String)))]) + +(provide send-url unix-browser-list browser-preference? external-browser) + \ No newline at end of file diff --git a/collects/typed/net/smtp.ss b/collects/typed/net/smtp.ss new file mode 100644 index 0000000000..4923a4b116 --- /dev/null +++ b/collects/typed/net/smtp.ss @@ -0,0 +1,11 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/smtp + [smtp-send-message (String String (Listof String) String (Listof String) -> Void)] + [smtp-sending-end-of-message (Parameter (-> Any))]) + +(provide smtp-send-message smtp-sending-end-of-message) + + \ No newline at end of file diff --git a/collects/typed/net/uri-codec.ss b/collects/typed/net/uri-codec.ss new file mode 100644 index 0000000000..bfbc991191 --- /dev/null +++ b/collects/typed/net/uri-codec.ss @@ -0,0 +1,15 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/uri-codec + [uri-encode ( String -> String )] + [uri-decode ( String -> String )] + + [form-urlencoded-encode ( String -> String )] + [form-urlencoded-decode ( String -> String )] + + [alist->form-urlencoded ( (Listof (cons Symbol String)) -> String )] + [form-urlencoded->alist ( String -> (Listof (cons Symbol String)) )] + [current-alist-separator-mode (Parameter Symbol)]) + \ No newline at end of file diff --git a/collects/typed/net/url.ss b/collects/typed/net/url.ss new file mode 100644 index 0000000000..86add4fef6 --- /dev/null +++ b/collects/typed/net/url.ss @@ -0,0 +1,59 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require-typed-struct path/param ([path : (U String 'up 'same)] [param : (Listof String)]) net/url) + +(require-typed-struct url ([scheme : (Option String)] + [user : (Option String)] + [host : (Option String)] + [port : (Option Integer)] + [path-absolute? : Boolean] + [path : (Listof path/param)] + [query : (Listof (Pair Symbol (Option String)))] + [fragment : (Option String)]) + net/url) + +(require/opaque-type URL-Exception url-exception? net/url) + +(define-type-alias PortT (case-lambda (url -> Input-Port) (url (Listof String)-> Input-Port))) +(define-type-alias PortT/String (case-lambda (url String -> Input-Port) (url String (Listof String)-> Input-Port))) + +(require/typed/provide net/url + + [path->url (Path -> url)] + [url->path (case-lambda (url -> Path) (url (U 'unix 'windows) -> Path))] + + [file-url-path-convention-type (Parameter (U 'unix 'windows))] + + [get-pure-port PortT] + [head-pure-port PortT] + [delete-pure-port PortT] + + [get-impure-port PortT] + [head-impure-port PortT] + [delete-impure-port PortT] + + [post-pure-port PortT/String] + [put-pure-port PortT/String] + + [post-impure-port PortT/String] + [put-impure-port PortT/String] + + [display-pure-port (Input-Port -> Void)] + [purify-port (Input-Port -> String)] + + [call/input-url (case-lambda [url url (Input-Port -> Any) -> Any])] ;;FIXME - need polymorphism + + [current-proxy-servers (Parameter (Listof (List String String Integer)))] + + [netscape/string->url (String -> url)] + [string->url (String -> url)] + [url->string (url -> String)] + [combine-url/relative (url String -> url)]) + +(provide + URL-Exception + url-exception? + (struct-out url) + (struct-out path/param)) From 447cea73d08c145385fc75a236cb705c5d2a705f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 00:16:25 +0000 Subject: [PATCH 051/193] set svn:eol-style svn: r12520 --- collects/typed/file/gif.ss | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/typed/file/gif.ss b/collects/typed/file/gif.ss index 3a17435eb0..402c340692 100644 --- a/collects/typed/file/gif.ss +++ b/collects/typed/file/gif.ss @@ -14,4 +14,3 @@ [quantize ( String -> (values String (Listof (Vectorof Number)) (U #f (Vectorof Number))))]) (provide gif-stream? GIF-Stream) - \ No newline at end of file From 959c8917942f3c44057d8f4cd85322af3324b456 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 20 Nov 2008 02:15:01 +0000 Subject: [PATCH 052/193] svn: r12521 --- doc/release-notes/drscheme/HISTORY.txt | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/doc/release-notes/drscheme/HISTORY.txt b/doc/release-notes/drscheme/HISTORY.txt index 2ecc672274..6421c44f94 100644 --- a/doc/release-notes/drscheme/HISTORY.txt +++ b/doc/release-notes/drscheme/HISTORY.txt @@ -1,3 +1,16 @@ +------------------------------ + Version 4.3 +------------------------------ + + . minor bug fixes + +------------------------------ + Version 4.2 +------------------------------ + + . contract library's function contract + combinatiors now preserve tail recursion. + ------------------------------ Version 4.1 ------------------------------ From 7c0db197ec0a9f9d9c49415208256009693cbb37 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 02:27:02 +0000 Subject: [PATCH 053/193] * Made --ssl set a port number only if it wasn't already before * Made -p reject non-integers and bad port numbers svn: r12523 --- collects/web-server/private/launch.ss | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/web-server/private/launch.ss b/collects/web-server/private/launch.ss index c24473910c..6884af754f 100644 --- a/collects/web-server/private/launch.ss +++ b/collects/web-server/private/launch.ss @@ -18,7 +18,7 @@ default))) (define ssl (make-parameter #f)) -(define port (make-parameter 80)) +(define port (make-parameter #f)) (define configuration@ (parse-command-line @@ -27,7 +27,7 @@ `((once-each [("--ssl") ,(lambda (flag) - (port 443) + (unless (port) (port 443)) (ssl #t)) ("Run with SSL using server-cert.pem and private-key.pem in the current directory, with 443 as the default port.")] [("-f" "--configuration-table") @@ -41,7 +41,10 @@ ("Use an alternate configuration table" "file-name")] [("-p" "--port") ,(lambda (flag the-port) - (port (string->number the-port))) + (let ([p (string->number the-port)]) + (if (and (integer? p) (<= 1 p 65535)) + (port p) + (error 'web-server "expecting a valid port number, got \"~a\"" the-port)))) ("Use an alternate network port." "port")] [("-a" "--ip-address") ,(lambda (flag ip-address) @@ -58,7 +61,7 @@ (lambda (flags) (configuration-table->web-config@ (extract-flag 'config flags default-configuration-table-path) - #:port (port) + #:port (or (port) 80) #:listen-ip (extract-flag 'ip-address flags #f))) '())) From 788b94e28b02cb8c010163219ba47cdd7165f6b7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 02:55:28 +0000 Subject: [PATCH 054/193] Mostly reformatting svn: r12524 --- collects/web-server/servlet-env.ss | 193 ++++++++++++++--------------- collects/web-server/web-server.ss | 24 ++-- 2 files changed, 107 insertions(+), 110 deletions(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index e6988ba34d..3f4f224674 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -9,7 +9,7 @@ web-server/managers/manager web-server/private/servlet web-server/configuration/namespace - web-server/private/cache-table + web-server/private/cache-table web-server/http web-server/private/util web-server/configuration/responders @@ -18,10 +18,10 @@ web-server/configuration/configuration-table web-server/servlet/setup (prefix-in lift: web-server/dispatchers/dispatch-lift) - (prefix-in fsmap: web-server/dispatchers/filesystem-map) + (prefix-in fsmap: web-server/dispatchers/filesystem-map) (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) (prefix-in files: web-server/dispatchers/dispatch-files) - (prefix-in filter: web-server/dispatchers/dispatch-filter) + (prefix-in filter: web-server/dispatchers/dispatch-filter) (prefix-in servlets: web-server/dispatchers/dispatch-servlets)) (define send-url (make-parameter net:send-url)) @@ -30,93 +30,89 @@ (lift:make (lambda (request) (thread (lambda () (sleep 2) (semaphore-post sema))) - `(html - (head - (title "Server Stopped") - (link ([rel "stylesheet"] [href "/error.css"]))) - (body - (div ([class "section"]) - (div ([class "title"]) "Server Stopped") - (p "Return to DrScheme."))))))) + `(html (head (title "Server Stopped") + (link ([rel "stylesheet"] [href "/error.css"]))) + (body (div ([class "section"]) + (div ([class "title"]) "Server Stopped") + (p "Return to DrScheme."))))))) (provide/contract [serve/servlet (((request? . -> . response?)) (#:command-line? boolean? - #:launch-browser? boolean? - #:quit? boolean? - #:banner? boolean? - #:listen-ip string? - #:port number? - #:manager manager? - #:servlet-namespace (listof module-path?) - #:server-root-path path? - #:stateless? boolean? - #:extra-files-paths (listof path?) - #:servlets-root path? - #:file-not-found-responder (request? . -> . response?) - #:mime-types-path path? - #:servlet-path string? - #:servlet-regexp regexp?) + #:launch-browser? boolean? + #:quit? boolean? + #:banner? boolean? + #:listen-ip string? + #:port number? + #:manager manager? + #:servlet-namespace (listof module-path?) + #:server-root-path path? + #:stateless? boolean? + #:extra-files-paths (listof path?) + #:servlets-root path? + #:file-not-found-responder (request? . -> . response?) + #:mime-types-path path? + #:servlet-path string? + #:servlet-regexp regexp?) . ->* . void)]) -(define (serve/servlet start - #:command-line? - [command-line? #f] - #:launch-browser? - [launch-browser? (not command-line?)] - #:quit? - [quit? (not command-line?)] - #:banner? - [banner? (not command-line?)] - - #:listen-ip - [listen-ip "127.0.0.1"] - #:port - [the-port 8000] - - #:manager - [manager - (make-threshold-LRU-manager - (lambda (request) - `(html (head (title "Page Has Expired.")) - (body (p "Sorry, this page has expired. Please go back.")))) - (* 64 1024 1024))] - - #:servlet-path - [servlet-path "/servlets/standalone.ss"] - #:servlet-regexp - [servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))] - #:stateless? - [stateless? #f] - - #:servlet-namespace - [servlet-namespace empty] - #:server-root-path - [server-root-path (directory-part default-configuration-table-path)] - #:extra-files-paths - [extra-files-paths (list (build-path server-root-path "htdocs"))] - #:servlets-root - [servlets-root (build-path server-root-path "htdocs")] - #:servlet-current-directory - [servlet-current-directory servlets-root] - #:file-not-found-responder - [file-not-found-responder (gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))] - #:mime-types-path - [mime-types-path (build-path server-root-path "mime.types")]) - (define standalone-url - (format "http://localhost:~a~a" the-port servlet-path)) +(define (serve/servlet + start + #:command-line? + [command-line? #f] + #:launch-browser? + [launch-browser? (not command-line?)] + #:quit? + [quit? (not command-line?)] + #:banner? + [banner? (not command-line?)] + + #:listen-ip + [listen-ip "127.0.0.1"] + #:port + [the-port 8000] + + #:manager + [manager + (make-threshold-LRU-manager + (lambda (request) + `(html (head (title "Page Has Expired.")) + (body (p "Sorry, this page has expired. Please go back.")))) + (* 64 1024 1024))] + + #:servlet-path + [servlet-path "/servlets/standalone.ss"] + #:servlet-regexp + [servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))] + #:stateless? + [stateless? #f] + + #:servlet-namespace + [servlet-namespace empty] + #:server-root-path + [server-root-path (directory-part default-configuration-table-path)] + #:extra-files-paths + [extra-files-paths (list (build-path server-root-path "htdocs"))] + #:servlets-root + [servlets-root (build-path server-root-path "htdocs")] + #:servlet-current-directory + [servlet-current-directory servlets-root] + #:file-not-found-responder + [file-not-found-responder + (gen-file-not-found-responder + (build-path server-root-path "conf" "not-found.html"))] + #:mime-types-path + [mime-types-path (build-path server-root-path "mime.types")]) + (define standalone-url (format "http://localhost:~a~a" the-port servlet-path)) (define make-servlet-namespace - (make-make-servlet-namespace - #:to-be-copied-module-specs servlet-namespace)) + (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)) (define sema (make-semaphore 0)) (define servlet-box (box #f)) (define dispatcher (sequencer:make (if quit? - (filter:make - #rx"^/quit$" - (quit-server sema)) - (lambda _ (next-dispatcher))) + (filter:make #rx"^/quit$" (quit-server sema)) + (lambda _ (next-dispatcher))) (filter:make servlet-regexp (servlets:make @@ -129,8 +125,8 @@ #:additional-specs default-module-specs)]) (if stateless? - (make-stateless.servlet servlet-current-directory start) - (make-v2.servlet servlet-current-directory manager start)))]) + (make-stateless.servlet servlet-current-directory start) + (make-v2.servlet servlet-current-directory manager start)))]) (set-box! servlet-box servlet) servlet))))) (let-values ([(clear-cache! url->servlet) @@ -144,33 +140,34 @@ (servlets:make url->servlet)) (apply sequencer:make (map (lambda (extra-files-path) - (files:make - #:url->path (fsmap:make-url->path - extra-files-path) + (files:make + #:url->path (fsmap:make-url->path extra-files-path) #:path->mime-type (make-path->mime-type mime-types-path) #:indices (list "index.html" "index.htm"))) extra-files-paths)) - (files:make - #:url->path (fsmap:make-url->path - (build-path server-root-path "htdocs")) - #:path->mime-type (make-path->mime-type (build-path server-root-path "mime.types")) + (files:make + #:url->path (fsmap:make-url->path (build-path server-root-path "htdocs")) + #:path->mime-type (make-path->mime-type + (build-path server-root-path "mime.types")) #:indices (list "index.html" "index.htm")) (lift:make file-not-found-responder))) (define shutdown-server (serve #:dispatch dispatcher #:listen-ip listen-ip #:port the-port)) + (define welcome + (if banner? + (lambda () + (printf "Your Web application is running at ~a.\n" standalone-url) + (printf "Click 'Stop' at any time to terminate the Web Server.\n")) + (void))) + (define (bye) + (when banner? (printf "\nWeb Server stopped.\n")) + (shutdown-server)) (when launch-browser? ((send-url) standalone-url #t)) - (when banner? - (printf "Your Web application is running at ~a.~n" standalone-url) - (printf "Click 'Stop' at any time to terminate the Web Server.~n")) - (with-handlers - ([exn:break? - (lambda (exn) - (when banner? - (printf "~nWeb Server stopped.~n")) - (shutdown-server))]) + (welcome) + (with-handlers ([exn:break? (lambda (exn) (bye))]) (semaphore-wait/enable-break sema)) - ; We shouldn't get here, because nothing posts to the semaphore. But just in case... - (shutdown-server)) \ No newline at end of file + ;; We can get here if a /quit url is visited + (bye)) diff --git a/collects/web-server/web-server.ss b/collects/web-server/web-server.ss index 3a293ad793..1491095d57 100644 --- a/collects/web-server/web-server.ss +++ b/collects/web-server/web-server.ss @@ -15,25 +15,25 @@ [serve (->* (#:dispatch dispatcher/c) (#:tcp@ unit? - #:port number? - #:listen-ip (or/c false/c string?) - #:max-waiting number? - #:initial-connection-timeout number?) + #:port number? + #:listen-ip (or/c false/c string?) + #:max-waiting number? + #:initial-connection-timeout number?) (-> void))] [serve/ports (->* (#:dispatch dispatcher/c) (#:tcp@ unit? - #:ports (listof number?) - #:listen-ip (or/c false/c string?) - #:max-waiting number? - #:initial-connection-timeout number?) + #:ports (listof number?) + #:listen-ip (or/c false/c string?) + #:max-waiting number? + #:initial-connection-timeout number?) (-> void))] [serve/ips+ports (->* (#:dispatch dispatcher/c) (#:tcp@ unit? - #:ips+ports (listof (cons/c (or/c false/c string?) (listof number?))) - #:max-waiting number? - #:initial-connection-timeout number?) + #:ips+ports (listof (cons/c (or/c false/c string?) (listof number?))) + #:max-waiting number? + #:initial-connection-timeout number?) (-> void))] [do-not-return (-> void)] [serve/web-config@ ((unit?) (#:tcp@ unit?) . ->* . (-> void?))]) @@ -59,7 +59,7 @@ dispatch-server@/tcp@ (import dispatch-server-config^) (export dispatch-server^)) - + (serve)) (define (serve/ports From 42d8f1ae1f2df731e9b7bfc28cc0b8491f3b7523 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 03:08:08 +0000 Subject: [PATCH 055/193] fix: just one shutdown message svn: r12525 --- collects/web-server/servlet-env.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 3f4f224674..52ce8f65bd 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -168,6 +168,6 @@ ((send-url) standalone-url #t)) (welcome) (with-handlers ([exn:break? (lambda (exn) (bye))]) - (semaphore-wait/enable-break sema)) - ;; We can get here if a /quit url is visited - (bye)) + (semaphore-wait/enable-break sema) + ;; We can get here if a /quit url is visited + (bye))) From 9405d572928173d33fb60376d71c5e4debb3fc89 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 03:13:01 +0000 Subject: [PATCH 056/193] allow #f for #:listen-ip svn: r12526 --- collects/web-server/servlet-env.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 52ce8f65bd..d817197aca 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -42,7 +42,7 @@ #:launch-browser? boolean? #:quit? boolean? #:banner? boolean? - #:listen-ip string? + #:listen-ip (or/c false/c string?) #:port number? #:manager manager? #:servlet-namespace (listof module-path?) From 8b5b87c80765d3d6a5c28ca6b2906ca72fd99b2f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 04:55:14 +0000 Subject: [PATCH 057/193] * revise requires to scheme/* * use `for' and better use of regexp patterns in `match' * use a literal byte-regexp in `make-path->mime-type' and use it throught `match' * delay reading of the mime types table (since there are uses like serve/servlet that will never use it anyway) svn: r12527 --- collects/web-server/private/mime-types.ss | 27 +++++++++-------------- 1 file changed, 11 insertions(+), 16 deletions(-) diff --git a/collects/web-server/private/mime-types.ss b/collects/web-server/private/mime-types.ss index 429953a88e..b129767d36 100644 --- a/collects/web-server/private/mime-types.ss +++ b/collects/web-server/private/mime-types.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require mzlib/contract - mzlib/plt-match - mzlib/string) +(require scheme/contract + scheme/match + scheme/promise) (require "util.ss" web-server/http) (provide/contract @@ -17,13 +17,9 @@ (match (read-line (current-input-port) 'any) [(? eof-object?) (void)] - [(regexp #"^([^\t ]+)[\t ]+(.+)$" - (list s type exts)) - (for-each (lambda (ext) - (hash-set! MIME-TYPE-TABLE - (lowercase-symbol! ext) - type)) - (regexp-split #" " exts)) + [(regexp #rx#"^([^\t ]+)[\t ]+(.+)$" (list _ type exts)) + (for ([ext (in-list (regexp-split #" " exts))]) + (hash-set! MIME-TYPE-TABLE (lowercase-symbol! ext) type)) (loop)] [_ (loop)])))) @@ -36,12 +32,11 @@ ;; 1. Can we determine the mime type based on file contents? ;; 2. Assuming that 7-bit ASCII is correct for mime-type (define (make-path->mime-type a-path) - (define MIME-TYPE-TABLE (read-mime-types a-path)) - (define file-suffix-regexp (byte-regexp #".*\\.([^\\.]*$)")) + (define MIME-TYPE-TABLE (delay (read-mime-types a-path))) (lambda (path) - (match (regexp-match file-suffix-regexp (path->bytes path)) - [(list path-bytes sffx) - (hash-ref MIME-TYPE-TABLE + (match (path->bytes path) + [(regexp #rx#".*\\.([^\\.]*$)" (list _ sffx)) + (hash-ref (force MIME-TYPE-TABLE) (lowercase-symbol! sffx) - (lambda () TEXT/HTML-MIME-TYPE))] + TEXT/HTML-MIME-TYPE)] [_ TEXT/HTML-MIME-TYPE]))) From f6aa15c531e9e2c7bdeae10e0b4ef3da5c78ce4c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 04:59:26 +0000 Subject: [PATCH 058/193] Use the given `mime-types-path' for all files svn: r12528 --- collects/web-server/servlet-env.ss | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index d817197aca..bf76c2602c 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -147,8 +147,7 @@ extra-files-paths)) (files:make #:url->path (fsmap:make-url->path (build-path server-root-path "htdocs")) - #:path->mime-type (make-path->mime-type - (build-path server-root-path "mime.types")) + #:path->mime-type (make-path->mime-type mime-types-path) #:indices (list "index.html" "index.htm")) (lift:make file-not-found-responder))) (define shutdown-server From a41971ba6d5dd11093c4dc95838d14d47c0ff666 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 05:53:04 +0000 Subject: [PATCH 059/193] Added #:ssl? for making an https server. It is hard-wired to using "server-cert.pem" and "private-key.pem" in `server-root-path', but that seems to be the same as the --ssl command-line option. The ssl server is created using the same code that "private/launch.ss" uses, so it might be a good idea to abstract it into a separate file. Also, `mime-types-path' defaults to "mime.types" in the `server-root-path', but if the file is missing, then it uses "mime.types" in the `default-configuration-table-path', which is a sensible choice for just getting a server running. svn: r12529 --- collects/web-server/servlet-env.ss | 59 +++++++++++++++++++++--------- 1 file changed, 41 insertions(+), 18 deletions(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index bf76c2602c..7342405b98 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -3,7 +3,11 @@ #lang scheme/base (require (prefix-in net: net/sendurl) scheme/contract - scheme/list) + scheme/list + scheme/unit + net/tcp-unit + net/tcp-sig + net/ssl-tcp-unit) (require web-server/web-server web-server/managers/lru web-server/managers/manager @@ -44,6 +48,7 @@ #:banner? boolean? #:listen-ip (or/c false/c string?) #:port number? + #:ssl? boolean? #:manager manager? #:servlet-namespace (listof module-path?) #:server-root-path path? @@ -71,6 +76,8 @@ [listen-ip "127.0.0.1"] #:port [the-port 8000] + #:ssl? + [ssl? #f] #:manager [manager @@ -102,8 +109,18 @@ (gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))] #:mime-types-path - [mime-types-path (build-path server-root-path "mime.types")]) - (define standalone-url (format "http://localhost:~a~a" the-port servlet-path)) + [mime-types-path (let ([p (build-path server-root-path "mime.types")]) + (if (file-exists? p) + p + (build-path + (directory-part default-configuration-table-path) + "mime.types")))]) + (define standalone-url + (string-append (if ssl? "https" "http") + "://localhost" + (if (and (not ssl?) (= the-port 80)) + "" (format ":~a" the-port)) + servlet-path)) (define make-servlet-namespace (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)) (define sema (make-semaphore 0)) @@ -153,20 +170,26 @@ (define shutdown-server (serve #:dispatch dispatcher #:listen-ip listen-ip - #:port the-port)) - (define welcome - (if banner? - (lambda () - (printf "Your Web application is running at ~a.\n" standalone-url) - (printf "Click 'Stop' at any time to terminate the Web Server.\n")) - (void))) - (define (bye) - (when banner? (printf "\nWeb Server stopped.\n")) - (shutdown-server)) + #:port the-port + #:tcp@ (if ssl? + (let () + (define-unit-binding ssl-tcp@ + (make-ssl-tcp@ + (build-path server-root-path "server-cert.pem") + (build-path server-root-path "private-key.pem") + #f #f #f #f #f) + (import) (export tcp^)) + ssl-tcp@) + tcp@))) (when launch-browser? ((send-url) standalone-url #t)) - (welcome) - (with-handlers ([exn:break? (lambda (exn) (bye))]) - (semaphore-wait/enable-break sema) - ;; We can get here if a /quit url is visited - (bye))) + (when banner? + (printf "Your Web application is running at ~a.\n" standalone-url) + (printf "Click 'Stop' at any time to terminate the Web Server.\n")) + (let ([bye (lambda () + (when banner? (printf "\nWeb Server stopped.\n")) + (shutdown-server))]) + (with-handlers ([exn:break? (lambda (exn) (bye))]) + (semaphore-wait/enable-break sema) + ;; We can get here if a /quit url is visited + (bye)))) From 56abd457ecdfe1ffe73eb4bef47c128ce82ac11f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 08:50:13 +0000 Subject: [PATCH 060/193] Welcome to a new PLT day. svn: r12530 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index cd6d48b8c9..925fa0040c 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "19nov2008") +#lang scheme/base (provide stamp) (define stamp "20nov2008") From beea721bc41026a982e4316dc8d63aa44d4b6b47 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 09:48:03 +0000 Subject: [PATCH 061/193] Use the new web-server's `serve/servlet' for the status servlet. svn: r12531 --- collects/handin-server/main.ss | 4 +- .../scribblings/quick-start.scrbl | 5 +- .../scribblings/server-setup.scrbl | 4 +- .../handin-server/status-web-root/index.html | 8 - .../status-web-root/servlets/status.ss | 277 -------------- collects/handin-server/web-status-server.ss | 347 ++++++++++++++---- 6 files changed, 278 insertions(+), 367 deletions(-) delete mode 100644 collects/handin-server/status-web-root/index.html delete mode 100644 collects/handin-server/status-web-root/servlets/status.ss diff --git a/collects/handin-server/main.ss b/collects/handin-server/main.ss index 1bd32f3b5d..ba1730692c 100644 --- a/collects/handin-server/main.ss +++ b/collects/handin-server/main.ss @@ -10,7 +10,7 @@ "private/run-status.ss" "private/reloadable.ss" "private/hooker.ss" - "web-status-server.ss" + (prefix-in web: "web-status-server.ss") ;; this sets some global parameter values, and this needs ;; to be done in the main thread, rather than later in a ;; user session thread (that will make the global changes @@ -623,7 +623,7 @@ (hook 'server-start `([port ,(get-conf 'port-number)])) (define stop-status - (cond [(get-conf 'https-port-number) => serve-status] + (cond [(get-conf 'https-port-number) => web:run] [else void])) (define session-count 0) diff --git a/collects/handin-server/scribblings/quick-start.scrbl b/collects/handin-server/scribblings/quick-start.scrbl index 5fb1855056..dc522b882e 100644 --- a/collects/handin-server/scribblings/quick-start.scrbl +++ b/collects/handin-server/scribblings/quick-start.scrbl @@ -50,9 +50,8 @@ The submitted file will be @filepath{.../test/tester/handin.scm}.} @item{Check the status of your submission by pointing a web browser at - @tt{https://localhost:7980/servlets/status.ss}. Note the ``s'' in - ``https''. Use the ``@tt{tester}'' username and ``@tt{pw}'' - password, as before. + @tt{https://localhost:7980/}. Note the ``s'' in ``https''. Use the + ``@tt{tester}'' username and ``@tt{pw}'' password, as before. NOTE: The @scheme[https-port-number] line in the @filepath{config.ss} file enables the embedded secure server. You diff --git a/collects/handin-server/scribblings/server-setup.scrbl b/collects/handin-server/scribblings/server-setup.scrbl index 1116902f2d..5be0694ea0 100644 --- a/collects/handin-server/scribblings/server-setup.scrbl +++ b/collects/handin-server/scribblings/server-setup.scrbl @@ -482,11 +482,11 @@ the correct assignment in the handin dialog. A student can download his/her own submissions through a web server that runs concurrently with the handin server. The starting URL is -@commandline{https://SERVER:PORT/servlets/status.ss} +@commandline{https://SERVER:PORT/} to obtain a list of all assignments, or -@commandline{https://SERVER:PORT/servlets/status.ss?handin=ASSIGNMENT} +@commandline{https://SERVER:PORT/?handin=ASSIGNMENT} to start with a specific assignment (named ASSIGNMENT). The default PORT is 7980. diff --git a/collects/handin-server/status-web-root/index.html b/collects/handin-server/status-web-root/index.html deleted file mode 100644 index 26af46228c..0000000000 --- a/collects/handin-server/status-web-root/index.html +++ /dev/null @@ -1,8 +0,0 @@ - -Handin Status Web Server - -The handin status server is running. -
-You can check your submissions on this server. - - diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss deleted file mode 100644 index 1f939f9a52..0000000000 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ /dev/null @@ -1,277 +0,0 @@ -(module status mzscheme - (require mzlib/file - mzlib/list - mzlib/string - mzlib/date - web-server/servlet - web-server/servlet/servlet-structs - web-server/managers/timeouts - web-server/private/util - net/uri-codec - net/url - handin-server/private/md5 - handin-server/private/logger - handin-server/private/config - handin-server/private/hooker) - - (define get-user-data - (let ([users-file (build-path server-dir "users.ss")]) - (lambda (user) - (get-preference (string->symbol user) (lambda () #f) #f users-file)))) - - (define (clean-str s) - (regexp-replace #rx" +$" (regexp-replace #rx"^ +" s "") "")) - - (define (aget alist key) - (cond [(assq key alist) => cdr] [else #f])) - - (define (make-page title . body) - `(html (head (title ,title)) - (body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body))) - - (define (relativize-path p) - (path->string (find-relative-path (normalize-path server-dir) p))) - - (define (make-k k tag) - (format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?") - (uri-encode tag))) - - ;; `look-for' can be a username as a string (will find "bar+foo" for "foo"), - ;; or a regexp that should match the whole directory name (used with - ;; "^solution" below) - (define (find-handin-entry hi look-for) - (let ([dir (assignment<->dir hi)]) - (and (directory-exists? dir) - (ormap - (lambda (d) - (let ([d (path->string d)]) - (and (cond [(string? look-for) - (member look-for (regexp-split #rx" *[+] *" d))] - [(regexp? look-for) (regexp-match? look-for d)] - [else (error 'find-handin-entry - "internal error: ~e" look-for)]) - (build-path dir d)))) - (directory-list dir))))) - - (define (handin-link k user hi) - (let* ([dir (find-handin-entry hi user)] - [l (and dir (with-handlers ([exn:fail? (lambda (x) null)]) - (parameterize ([current-directory dir]) - (sort (filter (lambda (f) - (and (not (equal? f "grade")) - (file-exists? f))) - (map path->string (directory-list))) - stringstring - (seconds->date - (file-or-directory-modify-seconds hi)) - #t) - ")"))) - l))) - (list (format "No handins accepted so far for user ~s, assignment ~s" - user hi))))) - - (define (solution-link k hi) - (let ([soln (and (member (assignment<->dir hi) (get-conf 'inactive-dirs)) - (find-handin-entry hi #rx"^solution"))] - [none `((i "---"))]) - (cond [(not soln) none] - [(file-exists? soln) - `((a ((href ,(make-k k (relativize-path soln)))) "Solution"))] - [(directory-exists? soln) - (parameterize ([current-directory soln]) - (let ([files (sort (map path->string - (filter file-exists? (directory-list))) - stringdir dir)]) - `(tr ([valign "top"]) - ,(apply header hi - (if active? `((br) (small (small "[active]"))) '())) - ,(apply cell (handin-link k user hi)) - ,(rcell (handin-grade user hi)) - ,(apply cell (solution-link k hi))))) - (let* ([next - (send/suspend - (lambda (k) - (make-page - (format "All Handins for ~a" user) - `(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"]) - (tr () ,@(map header '(nbsp "Files" "Grade" "Solution"))) - ,@(append (map (row k #t) (get-conf 'active-dirs)) - (map (row k #f) (get-conf 'inactive-dirs)))))))] - [tag (aget (request-bindings next) 'tag)]) - (download user tag))) - - (define (download who tag) - (define (check path elts allow-active?) - (let loop ([path path] [elts (reverse elts)]) - (let*-values ([(base name dir?) (split-path path)] - [(name) (path->string name)] - [(check) (and (pair? elts) (car elts))]) - (if (null? elts) - ;; must be rooted in a submission directory (why build-path instead - ;; of using `path'? -- because path will have a trailing slash) - (member (build-path base name) - (get-conf (if allow-active? 'all-dirs 'inactive-dirs))) - (and (cond [(eq? '* check) #t] - [(regexp? check) (regexp-match? check name)] - [(string? check) - (or (equal? name check) - (member check (regexp-split #rx" *[+] *" name)))] - [else #f]) - (loop base (cdr elts))))))) - (define file (build-path server-dir tag)) - (with-handlers ([exn:fail? - (lambda (exn) - (log-line "Status exception: ~a" (exn-message exn)) - (make-page "Error" "Illegal file access"))]) - ;; Make sure the user is allowed to read the requested file: - (or (check file `(,who *) #t) - (check file `(#rx"^solution") #f) - (check file `(#rx"^solution" *) #f) - (error 'download "bad file access for ~s: ~a" who file)) - (log-line "Status file-get: ~s ~a" who file) - (hook 'status-file-get `([username ,(string->symbol who)] [file ,file])) - ;; Return the downloaded file - (let* ([data (with-input-from-file file - (lambda () (read-bytes (file-size file))))] - [html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))] - [wxme? (regexp-match? #rx#"^(?:#reader[(]lib\"read.ss\"\"wxme\"[)])?WXME" data)]) - (make-response/full 200 "Okay" (current-seconds) - (cond [html? #"text/html"] - [wxme? #"application/data"] - [else #"text/plain"]) - (list - (make-header #"Content-Length" - (string->bytes/latin-1 - (number->string (bytes-length data)))) - (make-header #"Content-Disposition" - (string->bytes/utf-8 - (format "~a; filename=~s" - (if wxme? "attachment" "inline") - (let-values ([(base name dir?) (split-path file)]) - (path->string name)))))) - (list data))))) - - (define (status-page user for-handin) - (log-line "Status access: ~s" user) - (hook 'status-login `([username ,(string->symbol user)])) - (if for-handin - (one-status-page user for-handin) - (all-status-page user))) - - (define (login-page for-handin errmsg) - (let* ([request - (send/suspend - (lambda (k) - (make-page - "Handin Status Login" - `(form ([action ,k] [method "post"]) - (table ([align "center"]) - (tr (td ([colspan "2"] [align "center"]) - (font ([color "red"]) ,(or errmsg 'nbsp)))) - (tr (td "Username") - (td (input ([type "text"] [name "user"] [size "20"] - [value ""])))) - (tr (td nbsp)) - (tr (td "Password") - (td (input ([type "password"] [name "passwd"] - [size "20"] [value ""])))) - (tr (td ([colspan "2"] [align "center"]) - (input ([type "submit"] [name "post"] - [value "Login"])))))))))] - [bindings (request-bindings request)] - [user (aget bindings 'user)] - [passwd (aget bindings 'passwd)] - [user (and user (clean-str user))] - [user-data (get-user-data user)]) - (cond [(and user-data - (string? passwd) - (let ([pw (md5 passwd)]) - (or (equal? pw (car user-data)) - (equal? pw (get-conf 'master-password))))) - (status-page user for-handin)] - [else (login-page for-handin "Bad username or password")]))) - - (define web-counter - (let ([sema (make-semaphore 1)] - [count 0]) - (lambda () - (dynamic-wind - (lambda () (semaphore-wait sema)) - (lambda () (set! count (add1 count)) (format "w~a" count)) - (lambda () (semaphore-post sema)))))) - - (define (start initial-request) - (parameterize ([current-session (web-counter)]) - (login-page (aget (request-bindings initial-request) 'handin) #f))) - - (define interface-version 'v2) - (define name "status") - - (define (instance-expiration-handler failed-request) - (let* (;; get the current url, and strip off the continuation data - [cont-url (request-uri failed-request)] - [base-url (url-replace-path - (lambda (pl) - (map (lambda (pp) - (make-path/param (path/param-path pp) empty)) - pl)) - cont-url)] - [base-url-str (url->string base-url)]) - `(html (head (meta [(http-equiv "refresh") - (content ,(format "3;URL=~a" base-url-str))])) - (body "Your session has expired, " - (a ([href ,base-url-str]) "restarting") " in 3 seconds.")))) - - (define manager - (create-timeout-manager instance-expiration-handler 600 600)) - - (provide interface-version start name manager)) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index b95cd91ca3..64307edc6e 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -1,82 +1,279 @@ -#lang scheme/base -(require scheme/unit - net/ssl-tcp-unit - net/tcp-sig - net/tcp-unit - (only-in mzlib/etc this-expression-source-directory) - web-server/web-server-unit - web-server/web-server-sig - web-server/web-config-sig - web-server/web-config-unit - web-server/configuration/namespace - "private/config.ss") +#lang scheme +(require scheme/list + scheme/file + scheme/date + net/uri-codec + web-server/servlet + web-server/servlet-env + web-server/managers/lru + handin-server/private/md5 + handin-server/private/logger + handin-server/private/config + handin-server/private/hooker) -(provide serve-status) +(define (aget alist key) + (cond [(assq key alist) => cdr] [else #f])) -(define (serve-status port-no) +(define (clean-str s) + (regexp-replace #rx" +$" (regexp-replace #rx"^ +" s "") "")) - (define ((in-dir dir) . paths) (path->string (apply build-path dir paths))) - (define in-web-dir - (in-dir (or (get-conf 'web-base-dir) - (build-path (this-expression-source-directory) - "status-web-root")))) - (define in-plt-web-dir - (in-dir (build-path (collection-path "web-server") "default-web-root"))) +(define (make-page title . body) + `(html (head (title ,title)) + (body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body))) - (define config - `((port ,port-no) - (max-waiting 40) - (initial-connection-timeout 30) - (default-host-table - (host-table - (default-indices "index.html") - (log-format parenthesized-default) - (messages - (servlet-message "servlet-error.html") - (authentication-message "forbidden.html") - (servlets-refreshed "servlet-refresh.html") - (passwords-refreshed "passwords-refresh.html") - (file-not-found-message "not-found.html") - (protocol-message "protocol-error.html") - (collect-garbage "collect-garbage.html")) - (timeouts - (default-servlet-timeout 120) - (password-connection-timeout 300) - (servlet-connection-timeout 86400) - (file-per-byte-connection-timeout 1/20) - (file-base-connection-timeout 30)) - (paths - (configuration-root ,(in-plt-web-dir "conf")) - (host-root ".") - (log-file-path ,(cond [(get-conf 'web-log-file) => path->string] - [else #f])) - (file-root ".") - (servlet-root ,(in-web-dir "servlets")) - (mime-types ,(in-plt-web-dir "mime.types")) - (password-authentication ,(in-plt-web-dir "passwords"))))) - (virtual-host-table))) +(define get-user-data + (let ([users-file (build-path server-dir "users.ss")]) + (unless (file-exists? users-file) + (error 'get-user-data "users file missing at: ~a" users-file)) + (lambda (user) + (get-preference (string->symbol user) (lambda () #f) #f users-file)))) - (define configuration - (configuration-table-sexpr->web-config@ - config - #:web-server-root (in-web-dir) - #:make-servlet-namespace - (make-make-servlet-namespace - #:to-be-copied-module-specs - '(handin-server/private/md5 - handin-server/private/logger - handin-server/private/config - handin-server/private/hooker - handin-server/private/reloadable)))) +(define (relativize-path p) + (path->string (find-relative-path (normalize-path server-dir) p))) - (define-unit-binding config@ configuration (import) (export web-config^)) - (define-unit-binding ssl-tcp@ - (make-ssl-tcp@ "server-cert.pem" "private-key.pem" #f #f #f #f #f) - (import) (export tcp^)) - (define-compound-unit/infer status-server@ - (import) - (link ssl-tcp@ config@ web-server@) - (export web-server^)) - (define-values/invoke-unit/infer status-server@) +(define (make-k k tag) + (format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?") + (uri-encode tag))) - (serve)) +;; `look-for' can be a username as a string (will find "bar+foo" for "foo"), or +;; a regexp that should match the whole directory name (used with "^solution" +;; below) +(define (find-handin-entry hi look-for) + (let ([dir (assignment<->dir hi)]) + (and (directory-exists? dir) + (ormap + (lambda (d) + (let ([d (path->string d)]) + (and (cond [(string? look-for) + (member look-for (regexp-split #rx" *[+] *" d))] + [(regexp? look-for) (regexp-match? look-for d)] + [else (error 'find-handin-entry + "internal error: ~e" look-for)]) + (build-path dir d)))) + (directory-list dir))))) + +(define (handin-link k user hi) + (let* ([dir (find-handin-entry hi user)] + [l (and dir (with-handlers ([exn:fail? (lambda (x) null)]) + (parameterize ([current-directory dir]) + (sort (filter (lambda (f) + (and (not (equal? f "grade")) + (file-exists? f))) + (map path->string (directory-list))) + stringstring + (seconds->date (file-or-directory-modify-seconds hi)) + #t) + ")"))) + l)) + (list (format "No handins accepted so far for user ~s, assignment ~s" + user hi))))) + +(define (solution-link k hi) + (let ([soln (and (member (assignment<->dir hi) (get-conf 'inactive-dirs)) + (find-handin-entry hi #rx"^solution"))] + [none `((i "---"))]) + (cond [(not soln) none] + [(file-exists? soln) + `((a ((href ,(make-k k (relativize-path soln)))) "Solution"))] + [(directory-exists? soln) + (parameterize ([current-directory soln]) + (let ([files (sort (map path->string + (filter file-exists? (directory-list))) + stringdir dir)]) + `(tr ([valign "top"]) + ,(apply header hi (if active? `((br) (small (small "[active]"))) '())) + ,(apply cell (handin-link k user hi)) + ,(rcell (handin-grade user hi)) + ,(apply cell (solution-link k hi))))) + (let* ([next + (send/suspend + (lambda (k) + (make-page + (format "All Handins for ~a" user) + `(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"]) + (tr () ,@(map header '(nbsp "Files" "Grade" "Solution"))) + ,@(append (map (row k #t) (get-conf 'active-dirs)) + (map (row k #f) (get-conf 'inactive-dirs)))))))] + [tag (aget (request-bindings next) 'tag)]) + (download user tag))) + +(define (download who tag) + (define (check path elts allow-active?) + (let loop ([path path] [elts (reverse elts)]) + (let*-values ([(base name dir?) (split-path path)] + [(name) (path->string name)] + [(check) (and (pair? elts) (car elts))]) + (if (null? elts) + ;; must be rooted in a submission directory (why build-path instead + ;; of using `path'? -- because path will have a trailing slash) + (member (build-path base name) + (get-conf (if allow-active? 'all-dirs 'inactive-dirs))) + (and (cond [(eq? '* check) #t] + [(regexp? check) (regexp-match? check name)] + [(string? check) + (or (equal? name check) + (member check (regexp-split #rx" *[+] *" name)))] + [else #f]) + (loop base (cdr elts))))))) + (define file (build-path server-dir tag)) + (with-handlers ([exn:fail? + (lambda (exn) + (log-line "Status exception: ~a" (exn-message exn)) + (make-page "Error" "Illegal file access"))]) + ;; Make sure the user is allowed to read the requested file: + (or (check file `(,who *) #t) + (check file `(#rx"^solution") #f) + (check file `(#rx"^solution" *) #f) + (error 'download "bad file access for ~s: ~a" who file)) + (log-line "Status file-get: ~s ~a" who file) + (hook 'status-file-get `([username ,(string->symbol who)] [file ,file])) + ;; Return the downloaded file + (let* ([data (file->bytes file)] + [html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))] + [wxme? (regexp-match? + #rx#"^(?:#reader[(]lib\"read.ss\"\"wxme\"[)])?WXME" data)]) + (make-response/full 200 "Okay" (current-seconds) + (cond [html? #"text/html"] + [wxme? #"application/data"] + [else #"text/plain"]) + (list + (make-header #"Content-Length" + (string->bytes/latin-1 + (number->string (bytes-length data)))) + (make-header #"Content-Disposition" + (string->bytes/utf-8 + (format "~a; filename=~s" + (if wxme? "attachment" "inline") + (let-values ([(base name dir?) (split-path file)]) + (path->string name)))))) + (list data))))) + +(define (status-page user for-handin) + (log-line "Status access: ~s" user) + (hook 'status-login `([username ,(string->symbol user)])) + (if for-handin + (one-status-page user for-handin) + (all-status-page user))) + +(define (login-page for-handin errmsg) + (let* ([request + (send/suspend + (lambda (k) + (make-page + "Handin Status Login" + `(form ([action ,k] [method "post"]) + (table ([align "center"]) + (tr (td ([colspan "2"] [align "center"]) + (font ([color "red"]) ,(or errmsg 'nbsp)))) + (tr (td "Username") + (td (input ([type "text"] [name "user"] [size "20"] + [value ""])))) + (tr (td nbsp)) + (tr (td "Password") + (td (input ([type "password"] [name "passwd"] + [size "20"] [value ""])))) + (tr (td ([colspan "2"] [align "center"]) + (input ([type "submit"] [name "post"] + [value "Login"])))))))))] + [bindings (request-bindings request)] + [user (aget bindings 'user)] + [passwd (aget bindings 'passwd)] + [user (and user (clean-str user))] + [user-data (get-user-data user)]) + (cond [(and user-data + (string? passwd) + (let ([pw (md5 passwd)]) + (or (equal? pw (car user-data)) + (equal? pw (get-conf 'master-password))))) + (status-page user for-handin)] + [else (login-page for-handin "Bad username or password")]))) + +(define web-counter + (let ([sema (make-semaphore 1)] [count 0]) + (lambda () + (dynamic-wind + (lambda () (semaphore-wait sema)) + (lambda () (set! count (add1 count)) (format "w~a" count)) + (lambda () (semaphore-post sema)))))) + +(define ((send-error msg) req) + `(html (head (meta [(http-equiv "refresh") (content "3;URL=/")]) + (title ,msg)) + (body ,msg "; " (a ([href "/"]) "restarting") " in 3 seconds."))) + +(define ((run-servlet port)) + (define dir (string->path server-dir)) + (serve/servlet + (lambda (request) + (parameterize ([current-session (web-counter)]) + (login-page (aget (request-bindings request) 'handin) #f))) + #:port port #:listen-ip #f #:ssl? #t #:command-line? #t + #:servlet-path "/" #:servlet-regexp #rx"" + #:server-root-path dir #:servlets-root dir + #:file-not-found-responder (send-error "File not found") + #:servlet-namespace '(handin-server/private/md5 + handin-server/private/logger + handin-server/private/config + handin-server/private/hooker + handin-server/private/reloadable) + #:manager (make-threshold-LRU-manager + (send-error "Your session has expired") (* 12 1024 1024)))) + + + +(provide run) +(define (run p) + (thread (lambda () (dynamic-wind + (lambda () (log-line "*** starting web server")) + (run-servlet p) + (lambda () (log-line "*** web server died!"))))) + (void)) From 827b76cb6fb431a7d34fc8fef1d17dcced35b876 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 09:54:05 +0000 Subject: [PATCH 062/193] return a thunk that can kill the web server svn: r12532 --- collects/handin-server/web-status-server.ss | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index 64307edc6e..d6c371ab5c 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -272,8 +272,9 @@ (provide run) (define (run p) - (thread (lambda () (dynamic-wind - (lambda () (log-line "*** starting web server")) - (run-servlet p) - (lambda () (log-line "*** web server died!"))))) - (void)) + (define t + (thread (lambda () (dynamic-wind + (lambda () (log-line "*** starting web server")) + (run-servlet p) + (lambda () (log-line "*** web server died!")))))) + (lambda () (thread-break t))) From aa824d8e054049df38cc3394dbc8ea2554f15159 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 11:42:28 +0000 Subject: [PATCH 063/193] remove web-base-dir which does not make any sense now svn: r12533 --- collects/handin-server/private/config.ss | 1 - .../scribblings/server-setup.scrbl | 20 +++++-------------- 2 files changed, 5 insertions(+), 16 deletions(-) diff --git a/collects/handin-server/private/config.ss b/collects/handin-server/private/config.ss index 892c348c4e..ffaead0b06 100644 --- a/collects/handin-server/private/config.ss +++ b/collects/handin-server/private/config.ss @@ -74,7 +74,6 @@ [(allow-new-users) (values #f id )] [(allow-change-info) (values #f id )] [(master-password) (values #f id )] - [(web-base-dir) (values #f path/false )] [(log-output) (values #t id )] [(log-file) (values "log" path/false )] [(web-log-file) (values #f path/false )] diff --git a/collects/handin-server/scribblings/server-setup.scrbl b/collects/handin-server/scribblings/server-setup.scrbl index 5be0694ea0..90429b0d91 100644 --- a/collects/handin-server/scribblings/server-setup.scrbl +++ b/collects/handin-server/scribblings/server-setup.scrbl @@ -114,16 +114,6 @@ This directory contains the following files and sub-directories: option), or @scheme[#f] for no log file; defaults to @filepath{log}.} - @item{@indexed-scheme[web-base-dir] --- if @scheme[#f] (the - default), the built-in web server will use the - @filepath{status-web-root} in the handin collection for its - configuration; to have complete control over the built in server - content, you can copy and edit @filepath{status-web-root}, then - add this configuration entry set to the name of your new copy - (relative to the handin server directory, or absolute). Note that - you must copy the @filepath{servlets} directory if you want the - status servlet.} - @item{@indexed-scheme[web-log-file] --- a path (relative to handin server directory or absolute) that specifies a filename for logging the internal HTTPS status web server; or @scheme[#f] (the @@ -218,11 +208,11 @@ This directory contains the following files and sub-directories: Changes to @filepath{config.ss} are detected, the file will be re-read, and options are reloaded. A few options are fixed at - startup time: port numbers, log file specs, and the - @scheme[web-base-dir] are fixed as configured at startup. All other - options will change the behavior of the running server (but things - like @scheme[username-case-sensitive?] it would be unwise to do - so). (For safety, options are not reloaded until the file parses + startup time: port numbers and log file specs are fixed as + configured at startup. All other options will change the behavior + of the running server (but things like + @scheme[username-case-sensitive?] it would be unwise to do so). + (For safety, options are not reloaded until the file parses correctly, but make sure that you don't save a copy that has inconsistent options: it is best to create a new configuration file and move it over the old one, or use an editor that does so and not From 44ae50652657e7d85d8a3285ca543f2a7b7d30bd Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 11:59:37 +0000 Subject: [PATCH 064/193] typo svn: r12534 --- collects/handin-server/web-status-server.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index d6c371ab5c..d6b37813a5 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -277,4 +277,4 @@ (lambda () (log-line "*** starting web server")) (run-servlet p) (lambda () (log-line "*** web server died!")))))) - (lambda () (thread-break t))) + (lambda () (break-thread t))) From 631a8be60c4938e8de16a160158934f36445c945 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 12:11:37 +0000 Subject: [PATCH 065/193] * Added #:log-file to `serve/servlet' (always using the 'apache-default format for now) * Using a convenient `dispatcher-sequence' as a `sequencer:make' wrapper svn: r12535 --- collects/web-server/servlet-env.ss | 44 ++++++++++++++++++++---------- 1 file changed, 30 insertions(+), 14 deletions(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 7342405b98..2e8fd2a751 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -26,7 +26,8 @@ (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) (prefix-in files: web-server/dispatchers/dispatch-files) (prefix-in filter: web-server/dispatchers/dispatch-filter) - (prefix-in servlets: web-server/dispatchers/dispatch-servlets)) + (prefix-in servlets: web-server/dispatchers/dispatch-servlets) + (prefix-in log: web-server/dispatchers/dispatch-log)) (define send-url (make-parameter net:send-url)) @@ -58,9 +59,19 @@ #:file-not-found-responder (request? . -> . response?) #:mime-types-path path? #:servlet-path string? - #:servlet-regexp regexp?) + #:servlet-regexp regexp? + #:log-file (or/c false/c path?)) . ->* . void)]) + +;; utility for conveniently chaining dispatchers +(define (dispatcher-sequence . dispatchers) + (let loop ([ds dispatchers] [r '()]) + (cond [(null? ds) (apply sequencer:make (reverse r))] + [(not (car ds)) (loop (cdr ds) r)] + [(list? (car ds)) (loop (append (car ds) (cdr ds)) r)] + [else (loop (cdr ds) (cons (car ds) r))]))) + (define (serve/servlet start #:command-line? @@ -114,7 +125,10 @@ p (build-path (directory-part default-configuration-table-path) - "mime.types")))]) + "mime.types")))] + + #:log-file + [log-file #f]) (define standalone-url (string-append (if ssl? "https" "http") "://localhost" @@ -126,10 +140,13 @@ (define sema (make-semaphore 0)) (define servlet-box (box #f)) (define dispatcher - (sequencer:make - (if quit? - (filter:make #rx"^/quit$" (quit-server sema)) - (lambda _ (next-dispatcher))) + (dispatcher-sequence + (and log-file (log:make #:format (log:log-format->format + ;; 'parenthesized-default + ;; 'extended + 'apache-default) + #:log-path log-file)) + (and quit? (filter:make #rx"^/quit$" (quit-server sema))) (filter:make servlet-regexp (servlets:make @@ -155,13 +172,12 @@ (make-default-path->servlet #:make-servlet-namespace make-servlet-namespace))]) (servlets:make url->servlet)) - (apply sequencer:make - (map (lambda (extra-files-path) - (files:make - #:url->path (fsmap:make-url->path extra-files-path) - #:path->mime-type (make-path->mime-type mime-types-path) - #:indices (list "index.html" "index.htm"))) - extra-files-paths)) + (map (lambda (extra-files-path) + (files:make + #:url->path (fsmap:make-url->path extra-files-path) + #:path->mime-type (make-path->mime-type mime-types-path) + #:indices (list "index.html" "index.htm"))) + extra-files-paths) (files:make #:url->path (fsmap:make-url->path (build-path server-root-path "htdocs")) #:path->mime-type (make-path->mime-type mime-types-path) From ed8cd4b37f5753cf13212acb93ca65b4c419cd60 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 12:15:53 +0000 Subject: [PATCH 066/193] re-add the log file option svn: r12536 --- collects/handin-server/main.ss | 4 +--- collects/handin-server/web-status-server.ss | 23 ++++++++++++--------- 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/collects/handin-server/main.ss b/collects/handin-server/main.ss index ba1730692c..55291a7012 100644 --- a/collects/handin-server/main.ss +++ b/collects/handin-server/main.ss @@ -622,9 +622,7 @@ (log-line "server started ------------------------------") (hook 'server-start `([port ,(get-conf 'port-number)])) -(define stop-status - (cond [(get-conf 'https-port-number) => web:run] - [else void])) +(define stop-status (web:run)) (define session-count 0) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index d6b37813a5..f6cc7090ce 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -266,15 +266,18 @@ handin-server/private/hooker handin-server/private/reloadable) #:manager (make-threshold-LRU-manager - (send-error "Your session has expired") (* 12 1024 1024)))) - - + (send-error "Your session has expired") (* 12 1024 1024)) + #:log-file (get-conf 'web-log-file))) (provide run) -(define (run p) - (define t - (thread (lambda () (dynamic-wind - (lambda () (log-line "*** starting web server")) - (run-servlet p) - (lambda () (log-line "*** web server died!")))))) - (lambda () (break-thread t))) +(define (run) + (cond [(get-conf 'https-port-number) + => (lambda (p) + (define t + (thread (lambda () + (dynamic-wind + (lambda () (log-line "*** starting web server")) + (run-servlet p) + (lambda () (log-line "*** web server died!")))))) + (lambda () (break-thread t)))] + [else void])) From 1a4b3abba7cc0191ea431ef86a7bdd4911a0d41d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 Nov 2008 13:47:06 +0000 Subject: [PATCH 067/193] decompiler repairs svn: r12537 --- collects/compiler/decompile.ss | 122 ++++++++++++++++++--------------- collects/compiler/zo-parse.ss | 17 +++-- 2 files changed, 75 insertions(+), 64 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 70a64f71c1..4fc5259255 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -28,12 +28,12 @@ (hash-set! table n (car b))))) table)) -(define (list-ref/protect l pos) +(define (list-ref/protect l pos who) (list-ref l pos) #; (if (pos . < . (length l)) (list-ref l pos) - `(OUT-OF-BOUNDS ,pos ,l))) + `(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l))) ;; ---------------------------------------- @@ -44,7 +44,7 @@ (let-values ([(globs defns) (decompile-prefix prefix)]) `(begin ,@defns - ,(decompile-form form globs '(#%globals))))] + ,(decompile-form form globs '(#%globals) (make-hasheq))))] [else (error 'decompile "unrecognized: ~e" top)])) (define (decompile-prefix a-prefix) @@ -76,7 +76,7 @@ lift-ids) (map (lambda (stx id) `(define ,id ,(if stx - `(#%decode-syntax ,(stx-encoded stx)) + `(#%decode-syntax ,stx #;(stx-encoded stx)) #f))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -90,18 +90,19 @@ (match mod-form [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) (let-values ([(globs defns) (decompile-prefix prefix)] - [(stack) (append '(#%modvars) stack)]) + [(stack) (append '(#%modvars) stack)] + [(closed) (make-hasheq)]) `(module ,name .... ,@defns ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) syntax-body) ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) body)))] [else (error 'decompile-module "huh?: ~e" mod-form)])) -(define (decompile-form form globs stack) +(define (decompile-form form globs stack closed) (match form [(? mod?) (decompile-module form stack)] @@ -109,31 +110,31 @@ `(define-values ,(map (lambda (tl) (match tl [(struct toplevel (depth pos const? mutated?)) - (list-ref/protect globs pos)])) + (list-ref/protect globs pos 'def-vals)])) ids) - ,(decompile-expr rhs globs stack))] + ,(decompile-expr rhs globs stack closed))] [(struct def-syntaxes (ids rhs prefix max-let-depth)) `(define-syntaxes ,ids ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-form rhs globs '(#%globals)))))] + ,(decompile-form rhs globs '(#%globals) closed))))] [(struct def-for-syntax (ids rhs prefix max-let-depth)) `(define-values-for-syntax ,ids ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-expr rhs globs '(#%globals)))))] + ,(decompile-expr rhs globs '(#%globals) closed))))] [(struct sequence (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) forms))] [(struct splice (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) forms))] [else - (decompile-expr form globs stack)])) + (decompile-expr form globs stack closed)])) (define (extract-name name) (if (symbol? name) @@ -168,22 +169,22 @@ (extract-ids! body ids)] [else #f])) -(define (decompile-expr expr globs stack) +(define (decompile-expr expr globs stack closed) (match expr [(struct toplevel (depth pos const? mutated?)) - (let ([id (list-ref/protect globs pos)]) + (let ([id (list-ref/protect globs pos 'toplevel)]) (if const? id `(#%checked ,id)))] [(struct topsyntax (depth pos midpt)) - (list-ref/protect globs (+ midpt pos))] + (list-ref/protect globs (+ midpt pos) 'topsyntax)] [(struct primitive (id)) (hash-ref primitive-table id)] [(struct assign (id rhs undef-ok?)) - `(set! ,(decompile-expr id globs stack) - ,(decompile-expr rhs globs stack))] + `(set! ,(decompile-expr id globs stack closed) + ,(decompile-expr rhs globs stack closed))] [(struct localref (unbox? offset clear?)) - (let ([id (list-ref/protect stack offset)]) + (let ([id (list-ref/protect stack offset 'localref)]) (let ([e (if unbox? `(#%unbox ,id) id)]) @@ -191,17 +192,17 @@ `(#%sfs-clear ,e) e)))] [(? lam?) - `(lambda . ,(decompile-lam expr globs stack))] + `(lambda . ,(decompile-lam expr globs stack closed))] [(struct case-lam (name lams)) `(case-lambda ,@(map (lambda (lam) - (decompile-lam lam globs stack)) + (decompile-lam lam globs stack closed)) lams))] [(struct let-one (rhs body)) (let ([id (or (extract-id rhs) (gensym 'local))]) - `(let ([,id ,(decompile-expr rhs globs (cons id stack))]) - ,(decompile-expr body globs (cons id stack))))] + `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)]) + ,(decompile-expr body globs (cons id stack) closed)))] [(struct let-void (count boxes? body)) (let ([ids (make-vector count #f)]) (extract-ids! body ids) @@ -210,71 +211,76 @@ (or id (gensym 'localv)))]) `(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)]) vars) - ,(decompile-expr body globs (append vars stack)))))] + ,(decompile-expr body globs (append vars stack) closed))))] [(struct let-rec (procs body)) `(begin (#%set!-rec-values ,(for/list ([p (in-list procs)] [i (in-naturals)]) - (list-ref/protect stack i)) + (list-ref/protect stack i 'let-rec)) ,@(map (lambda (proc) - (decompile-expr proc globs stack)) + (decompile-expr proc globs stack closed)) procs)) - ,(decompile-expr body globs stack))] + ,(decompile-expr body globs stack closed))] [(struct install-value (count pos boxes? rhs body)) `(begin (,(if boxes? '#%set-boxes! 'set!-values) ,(for/list ([i (in-range count)]) - (list-ref/protect stack (+ i pos))) - ,(decompile-expr rhs globs stack)) - ,(decompile-expr body globs stack))] + (list-ref/protect stack (+ i pos) 'install-value)) + ,(decompile-expr rhs globs stack closed)) + ,(decompile-expr body globs stack closed))] [(struct boxenv (pos body)) - (let ([id (list-ref/protect stack pos)]) + (let ([id (list-ref/protect stack pos 'boxenv)]) `(begin (set! ,id (#%box ,id)) - ,(decompile-expr body globs stack)))] + ,(decompile-expr body globs stack closed)))] [(struct branch (test then else)) - `(if ,(decompile-expr test globs stack) - ,(decompile-expr then globs stack) - ,(decompile-expr else globs stack))] + `(if ,(decompile-expr test globs stack closed) + ,(decompile-expr then globs stack closed) + ,(decompile-expr else globs stack closed))] [(struct application (rator rands)) (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) stack)]) (annotate-inline - `(,(decompile-expr rator globs stack) + `(,(decompile-expr rator globs stack closed) ,@(map (lambda (rand) - (decompile-expr rand globs stack)) + (decompile-expr rand globs stack closed)) rands))))] [(struct apply-values (proc args-expr)) - `(#%apply-values ,(decompile-expr proc globs stack) - ,(decompile-expr args-expr globs stack))] + `(#%apply-values ,(decompile-expr proc globs stack closed) + ,(decompile-expr args-expr globs stack closed))] [(struct sequence (exprs)) `(begin ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack)))] + (decompile-expr expr globs stack closed)))] [(struct beg0 (exprs)) `(begin0 ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack)))] + (decompile-expr expr globs stack closed)))] [(struct with-cont-mark (key val body)) `(with-continuation-mark - ,(decompile-expr key globs stack) - ,(decompile-expr val globs stack) - ,(decompile-expr body globs stack))] + ,(decompile-expr key globs stack closed) + ,(decompile-expr val globs stack closed) + ,(decompile-expr body globs stack closed))] [(struct closure (lam gen-id)) - `(#%closed ,gen-id ,(decompile-expr lam globs stack))] + (if (hash-ref closed gen-id #f) + gen-id + (begin + (hash-set! closed gen-id #t) + `(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))] [(struct indirect (val)) (if (closure? val) - (closure-gen-id val) + (decompile-expr val globs stack closed) '???)] [else `(quote ,expr)])) -(define (decompile-lam expr globs stack) +(define (decompile-lam expr globs stack closed) (match expr - [(struct closure (lam gen-id)) (decompile-lam lam globs stack)] + [(struct indirect (val)) (decompile-lam val globs stack closed)] + [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)] [(struct lam (name flags num-params rest? closure-map max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)]) (gensym (format "arg~a-" i)))] [rest-vars (if rest? (list (gensym 'rest)) null)] [captures (map (lambda (v) - (list-ref/protect stack v)) + (list-ref/protect stack v 'lam)) (vector->list closure-map))]) `((,@vars . ,(if rest? (car rest-vars) @@ -285,8 +291,10 @@ ,@(if (null? captures) null `('(captures: ,@captures))) - ,(decompile-expr body globs (append captures - (append vars rest-vars)))))])) + ,(decompile-expr body globs + (append captures + (append vars rest-vars)) + closed)))])) (define (annotate-inline a) (if (and (symbol? (car a)) @@ -301,16 +309,16 @@ car cdr caar cadr cdar cddr mcar mcdr unbox vector-length syntax-e add1 sub1 - abs bitwise-not - list vector box))] + list list* vector vector-immutable box))] [(3) (memq (car a) '(eq? = <= < >= > bitwise-bit-set? char=? + - * / min max bitwise-and bitwise-ior arithmetic-shift vector-ref string-ref bytes-ref set-mcar! set-mcdr! cons mcons - list vector))] + list list* vector vector-immutable))] [(4) (memq (car a) '(vector-set! string-set! bytes-set! - list vector))] - [else (memq (car a) '(list vector))])) + list list* vector vector-immutable))] + [else (memq (car a) '(list list* vector vector-immutable))])) (cons '#%in a) a)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index a19caea4ad..57472a6c38 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -661,7 +661,7 @@ ;; Main parsing loop (define (read-compact cp) - (let loop ([need-car 0] [proper #f] [last #f] [first #f]) + (let loop ([need-car 0] [proper #f]) (begin-with-definitions (define ch (cp-getc cp)) (define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)]) @@ -707,7 +707,7 @@ (cons (read-compact cp) (if ppr null (read-compact cp))) (read-compact-list l ppr cp)) - (loop l ppr last first)))] + (loop l ppr)))] [(let-one) (make-let-one (read-compact cp) (read-compact cp))] [(branch) @@ -747,8 +747,10 @@ (read-compact cp))]) (vector->immutable-vector (list->vector lst)))] [(list) (let* ([n (read-compact-number cp)]) - (for/list ([i (in-range n)]) - (read-compact cp)))] + (append + (for/list ([i (in-range n)]) + (read-compact cp)) + (read-compact cp)))] [(prefab) (let ([v (read-compact cp)]) (apply make-prefab-struct @@ -845,9 +847,8 @@ [(symbol? s) s] [(vector? s) (vector-ref s 0)] [else 'closure]))))]) - (vector-set! (cport-symtab cp) l cl) (set-indirect-v! ind cl) - cl))] + ind))] [(svector) (read-compact-svector cp (read-compact-number cp))] [(small-svector) @@ -858,7 +859,7 @@ [(and proper (= need-car 1)) (cons v null)] [else - (cons v (loop (sub1 need-car) proper last first))])))) + (cons v (loop (sub1 need-car) proper))])))) ;; path -> bytes ;; implementes read.c:read_compiled @@ -898,11 +899,13 @@ (define symtab (make-vector symtabsize (make-not-ready))) (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) + (for/list ([i (in-range 1 symtabsize)]) (when (not-ready? (vector-ref symtab i)) (set-cport-pos! cp (vector-ref so* (sub1 i))) (let ([v (read-compact cp)]) (vector-set! symtab i v)))) + (set-cport-pos! cp shared-size) (read-marshalled 'compilation-top-type cp))) From 93a13222dc02fecd371e8269e3919f3f0f4f3ff7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 Nov 2008 13:48:48 +0000 Subject: [PATCH 068/193] Mac: change draw-point to use Quartz in smoothed mode svn: r12538 --- src/wxmac/src/mac/wx_dccan2.cc | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/src/wxmac/src/mac/wx_dccan2.cc b/src/wxmac/src/mac/wx_dccan2.cc index cd46d06c0b..a64e91ef88 100644 --- a/src/wxmac/src/mac/wx_dccan2.cc +++ b/src/wxmac/src/mac/wx_dccan2.cc @@ -533,6 +533,32 @@ void wxCanvasDC::DrawPoint(double x, double y) if (!current_pen || current_pen->GetStyle() == wxTRANSPARENT) return; + if (anti_alias) { + double xx, yy; + CGContextRef cg; + + SetCurrentDC(TRUE); + cg = GetCG(); + + CGContextSaveGState(cg); + + xx = SmoothingXFormX(x); + yy = SmoothingXFormY(y); + + CGContextMoveToPoint(cg, xx, yy); + CGContextAddLineToPoint(cg, xx, yy); + + wxMacSetCurrentTool(kPenTool); + CGContextStrokePath(cg); + wxMacSetCurrentTool(kNoTool); + + CGContextRestoreGState(cg); + + ReleaseCurrentDC(); + + return; + } + SetCurrentDC(); wxMacSetCurrentTool(kPenTool); wxMacDrawPoint(XLOG2DEV(x), YLOG2DEV(y)); From 8ccce66af7b96a141d661b8af36cb974be77a9d4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 Nov 2008 13:50:22 +0000 Subject: [PATCH 069/193] round out inlining and optimization of simple allocating primitives svn: r12539 --- collects/tests/mzscheme/optimize.ss | 41 +++++++++++++++++----- collects/texpict/utils.ss | 4 +-- src/mred/wxme/wx_mpbrd.cxx | 1 - src/mzscheme/src/eval.c | 30 ++++++++++++---- src/mzscheme/src/jit.c | 54 ++++++++++++++++++++++++----- src/mzscheme/src/list.c | 23 +++++++++--- src/mzscheme/src/read.c | 8 +++++ src/mzscheme/src/schpriv.h | 6 ++++ src/mzscheme/src/vector.c | 8 +++++ 9 files changed, 143 insertions(+), 32 deletions(-) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 0ed2853c66..98894a67c0 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -350,6 +350,9 @@ (un0 '(1) 'list 1) (bin0 '(1 2) 'list 1 2) (tri0 '(1 2 3) 'list (lambda () 1) 2 3 void) + (un0 '1 'list* 1) + (bin0 '(1 . 2) 'list* 1 2) + (tri0 '(1 2 . 3) 'list* (lambda () 1) 2 3 void) (un0 '#&1 'box 1) (let ([test-setter @@ -443,17 +446,19 @@ (list a b c d e f))]) 10)) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][j i]) j)) - (normalize-depth '(let* ([i (cons 0 1)]) i))) +;; We use nonsense `display' and `write' where we used to use `cons' and +;; `list', because the old ones now get optimized away: +(test-comp (normalize-depth '(let* ([i (display 0 1)][j i]) j)) + (normalize-depth '(let* ([i (display 0 1)]) i))) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)][g i]) g)) - (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)]) i))) +(test-comp (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)][g i]) g)) + (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)]) i))) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)][g i][h g]) h)) - (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)]) i))) +(test-comp (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)][g i][h g]) h)) + (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)]) i))) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][g i][h (car g)][m h]) m)) - (normalize-depth '(let* ([i (cons 0 1)][h (car i)]) h))) +(test-comp (normalize-depth '(let* ([i (display 0 1)][g i][h (car g)][m h]) m)) + (normalize-depth '(let* ([i (display 0 1)][h (car i)]) h))) ; (require #%kernel) ; @@ -685,6 +690,26 @@ (define (q x) (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10)))))))))))))) +(let ([test-dropped + (lambda (cons-name . args) + (test-comp `(let ([x 5]) + (let ([y (,cons-name ,@args)]) + x)) + 5))]) + (test-dropped 'cons 1 2) + (test-dropped 'mcons 1 2) + (test-dropped 'box 1) + (let ([test-multi + (lambda (cons-name) + (test-dropped cons-name 1 2) + (test-dropped cons-name 1 2 3) + (test-dropped cons-name 1) + (test-dropped cons-name))]) + (test-multi 'list) + (test-multi 'list*) + (test-multi 'vector) + (test-multi 'vector-immutable))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check bytecode verification of lifted functions diff --git a/collects/texpict/utils.ss b/collects/texpict/utils.ss index f787dd868f..ff0305dadc 100644 --- a/collects/texpict/utils.ss +++ b/collects/texpict/utils.ss @@ -286,9 +286,9 @@ w h)))) - (define (filled-rounded-rectangle w h [corner-radius 0.25] #:angle [angle 0]) + (define (filled-rounded-rectangle w h [corner-radius -0.25] #:angle [angle 0]) (let ([dc-path (new dc-path%)]) - (send dc-path rounded-rectangle 0 0 w h (- corner-radius)) + (send dc-path rounded-rectangle 0 0 w h corner-radius) (send dc-path rotate angle) (let-values ([(x y w h) (send dc-path get-bounding-box)]) (dc (λ (dc dx dy) diff --git a/src/mred/wxme/wx_mpbrd.cxx b/src/mred/wxme/wx_mpbrd.cxx index b038ab87f1..17f6bb9730 100644 --- a/src/mred/wxme/wx_mpbrd.cxx +++ b/src/mred/wxme/wx_mpbrd.cxx @@ -317,7 +317,6 @@ void wxMediaPasteboard::OnDefaultEvent(wxMouseEvent *event) if (!admin) return; - /* First, find clicked-on snip: */ x = event->x; y = event->y; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 1a169a3daa..1aff3b6e8a 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -889,8 +889,12 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 1; } } - /* (void ...) */ - if (SAME_OBJ(scheme_void_proc, app->args[0])) { + /* ({void,list,list*,vector,vector-immutable} ...) */ + if (SAME_OBJ(scheme_void_proc, app->args[0]) + || SAME_OBJ(scheme_list_proc, app->args[0]) + || SAME_OBJ(scheme_list_star_proc, app->args[0]) + || SAME_OBJ(scheme_vector_proc, app->args[0]) + || SAME_OBJ(scheme_vector_immutable_proc, app->args[0])) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { int i; @@ -905,10 +909,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, } if ((vtype == scheme_application2_type)) { - /* (values ) or (void ) */ + /* ({values,void,list,list*,vector,vector-immutable,box} ) */ Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; if (SAME_OBJ(scheme_values_func, app->rator) - || SAME_OBJ(scheme_void_proc, app->rator)) { + || SAME_OBJ(scheme_void_proc, app->rator) + || SAME_OBJ(scheme_list_proc, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator) + || SAME_OBJ(scheme_vector_proc, app->rator) + || SAME_OBJ(scheme_vector_immutable_proc, app->rator) + || SAME_OBJ(scheme_box_proc, app->rator)) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info)) @@ -928,8 +937,14 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 1; } } - /* (void ) */ - if (SAME_OBJ(scheme_void_proc, app->rator)) { + /* ({void,cons,list,list*,vector,vector-immutable) ) */ + if (SAME_OBJ(scheme_void_proc, app->rator) + || SAME_OBJ(scheme_cons_proc, app->rator) + || SAME_OBJ(scheme_mcons_proc, app->rator) + || SAME_OBJ(scheme_list_proc, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator) + || SAME_OBJ(scheme_vector_proc, app->rator) + || SAME_OBJ(scheme_vector_immutable_proc, app->rator)) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info) @@ -2507,7 +2522,8 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf } } - if (SAME_OBJ(scheme_values_func, app->rator) + if ((SAME_OBJ(scheme_values_func, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator)) && scheme_omittable_expr(app->rand, 1, -1, 0, info)) { info->preserves_marks = 1; info->single_result = 1; diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 0e04244bbe..3c4c239c2e 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -1256,8 +1256,7 @@ static void *malloc_double(void) #endif #ifdef CAN_INLINE_ALLOC -static void *make_list_code; -# define make_list make_list_code +static void *make_list_code, *make_list_star_code; #else static Scheme_Object *make_list(long n) { @@ -1270,6 +1269,17 @@ static Scheme_Object *make_list(long n) return l; } +static Scheme_Object *make_list_star(long n) +{ + GC_CAN_IGNORE Scheme_Object **rs = MZ_RUNSTACK; + GC_CAN_IGNORE Scheme_Object *l = rs[--n]; + + while (n--) { + l = cons(rs[n], l); + } + + return l; +} #endif #if !defined(CAN_INLINE_ALLOC) @@ -4077,6 +4087,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } else if (IS_NAMED_PRIM(rator, "vector-immutable") || IS_NAMED_PRIM(rator, "vector")) { return generate_vector_alloc(jitter, rator, NULL, app, NULL); + } else if (IS_NAMED_PRIM(rator, "list*")) { + /* on a single argument, `list*' is identity */ + mz_runstack_skipped(jitter, 1); + generate_non_tail(app->rand, jitter, 0, 1); + CHECK_LIMIT(); + mz_runstack_unskipped(jitter, 1); + return 1; } else if (IS_NAMED_PRIM(rator, "list")) { mz_runstack_skipped(jitter, 1); generate_non_tail(app->rand, jitter, 0, 1); @@ -4553,7 +4570,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i (void)jit_movi_p(JIT_R0, scheme_void); return 1; - } else if (IS_NAMED_PRIM(rator, "cons")) { + } else if (IS_NAMED_PRIM(rator, "cons") + || IS_NAMED_PRIM(rator, "list*")) { LOG_IT(("inlined cons\n")); generate_two_args(app->rand1, app->rand2, jitter, 1); @@ -4748,8 +4766,12 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } else if (IS_NAMED_PRIM(rator, "vector-immutable") || IS_NAMED_PRIM(rator, "vector")) { return generate_vector_alloc(jitter, rator, app, NULL, NULL); - } else if (IS_NAMED_PRIM(rator, "list")) { + } else if (IS_NAMED_PRIM(rator, "list") + || IS_NAMED_PRIM(rator, "list*")) { int c = app->num_args; + int star; + + star = IS_NAMED_PRIM(rator, "list*"); if (c) generate_app(app, NULL, c, jitter, 0, 0, 1); @@ -4757,13 +4779,19 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int #ifdef CAN_INLINE_ALLOC jit_movi_l(JIT_R2, c); - (void)jit_calli(make_list_code); + if (star) + (void)jit_calli(make_list_star_code); + else + (void)jit_calli(make_list_code); #else JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); jit_movi_l(JIT_R0, c); mz_prepare(1); jit_pusharg_l(JIT_R0); - (void)mz_finish(make_list); + if (star) + (void)mz_finish(make_list_star); + else + (void)mz_finish(make_list); jit_retval(JIT_R0); #endif @@ -7252,13 +7280,21 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) #ifdef CAN_INLINE_ALLOC /* *** make_list_code *** */ /* R2 has length, args are on runstack */ - { + for (i = 0; i < 2; i++) { jit_insn *ref, *refnext; - make_list_code = jit_get_ip().ptr; + if (i == 0) + make_list_code = jit_get_ip().ptr; + else + make_list_star_code = jit_get_ip().ptr; mz_prolog(JIT_R1); jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE); - (void)jit_movi_p(JIT_R0, &scheme_null); + if (i == 0) + (void)jit_movi_p(JIT_R0, &scheme_null); + else { + jit_subi_l(JIT_R2, JIT_R2, JIT_WORD_SIZE); + jit_ldxr_p(JIT_R0, JIT_RUNSTACK, JIT_R2); + } __START_SHORT_JUMPS__(1); ref = jit_beqi_l(jit_forward(), JIT_R2, 0); diff --git a/src/mzscheme/src/list.c b/src/mzscheme/src/list.c index 30254661a6..21d1d6d8df 100644 --- a/src/mzscheme/src/list.c +++ b/src/mzscheme/src/list.c @@ -27,7 +27,11 @@ /* globals */ Scheme_Object scheme_null[1]; +Scheme_Object *scheme_cons_proc; +Scheme_Object *scheme_mcons_proc; Scheme_Object *scheme_list_proc; +Scheme_Object *scheme_list_star_proc; +Scheme_Object *scheme_box_proc; /* locals */ static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]); @@ -155,7 +159,9 @@ scheme_init_list (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant ("mpair?", p, env); + REGISTER_SO(scheme_cons_proc); p = scheme_make_noncm_prim(cons_prim, "cons", 2, 2); + scheme_cons_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; scheme_add_global_constant ("cons", p, env); @@ -167,7 +173,9 @@ scheme_init_list (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant ("cdr", p, env); + REGISTER_SO(scheme_mcons_proc); p = scheme_make_noncm_prim(mcons_prim, "mcons", 2, 2); + scheme_mcons_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; scheme_add_global_constant ("mcons", p, env); @@ -205,11 +213,14 @@ scheme_init_list (Scheme_Env *env) | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant ("list", p, env); - scheme_add_global_constant ("list*", - scheme_make_immed_prim(list_star_prim, - "list*", - 1, -1), - env); + REGISTER_SO(scheme_list_star_proc); + p = scheme_make_immed_prim(list_star_prim, "list*", 1, -1); + scheme_list_star_proc = p; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); + scheme_add_global_constant ("list*", p, env); + scheme_add_global_constant("immutable?", scheme_make_folding_prim(immutablep, "immutable?", @@ -409,7 +420,9 @@ scheme_init_list (Scheme_Env *env) 1, 1, 1), env); + REGISTER_SO(scheme_box_proc); p = scheme_make_immed_prim(box, BOX, 1, 1); + scheme_box_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant(BOX, p, env); diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index f80452e61e..473c2b1f15 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -4371,6 +4371,8 @@ static Scheme_Object *read_compact_k(void) return read_compact(port, p->ku.k.i1); } +int dump_info = 0; + static Scheme_Object *read_compact(CPort *port, int use_stack) { #define BLK_BUF_SIZE 32 @@ -4396,6 +4398,9 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) ZO_CHECK(port->pos < port->size); ch = CP_GETC(port); + if (dump_info) + printf("%d %d %d\n", ch, port->pos, need_car); + switch(cpt_branch[ch]) { case CPT_ESCAPE: { @@ -4451,6 +4456,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) case CPT_SYMREF: l = read_compact_number(port); RANGE_CHECK(l, < port->symtab_size); + if (dump_info) + printf("%d\n", l); v = port->symtab[l]; if (!v) { long save_pos = port->pos; @@ -5261,6 +5268,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port, len = symtabsize; for (j = 1; j < len; j++) { if (!symtab[j]) { + if (dump_info) printf("at %ld %ld\n", j, rp->pos); v = read_compact(rp, 0); symtab[j] = v; } else { diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 1846ad86b3..9ea3f36d3a 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -260,7 +260,13 @@ void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym, extern Scheme_Object *scheme_values_func; extern Scheme_Object *scheme_procedure_p_proc; extern Scheme_Object *scheme_void_proc; +extern Scheme_Object *scheme_cons_proc; +extern Scheme_Object *scheme_mcons_proc; extern Scheme_Object *scheme_list_proc; +extern Scheme_Object *scheme_list_star_proc; +extern Scheme_Object *scheme_vector_proc; +extern Scheme_Object *scheme_vector_immutable_proc; +extern Scheme_Object *scheme_box_proc; extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_make_struct_type_proc; extern Scheme_Object *scheme_current_inspector_proc; diff --git a/src/mzscheme/src/vector.c b/src/mzscheme/src/vector.c index bf51aeae25..0d7ac3df36 100644 --- a/src/mzscheme/src/vector.c +++ b/src/mzscheme/src/vector.c @@ -25,6 +25,10 @@ #include "schpriv.h" +/* globals */ +Scheme_Object *scheme_vector_proc; +Scheme_Object *scheme_vector_immutable_proc; + /* locals */ static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]); static Scheme_Object *make_vector (int argc, Scheme_Object *argv[]); @@ -53,13 +57,17 @@ scheme_init_vector (Scheme_Env *env) 1, 2), env); + REGISTER_SO(scheme_vector_proc); p = scheme_make_immed_prim(vector, "vector", 0, -1); + scheme_vector_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("vector", p, env); + REGISTER_SO(scheme_vector_immutable_proc); p = scheme_make_immed_prim(vector_immutable, "vector-immutable", 0, -1); + scheme_vector_immutable_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED); From 0d902ddeafc4b0c1fa77bc68e40d4df28c0321bd Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 20 Nov 2008 15:57:42 +0000 Subject: [PATCH 070/193] Docs for r12526 svn: r12540 --- collects/web-server/scribblings/servlet-env.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 7b93592f84..1fa4cdcca7 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -82,7 +82,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, [#:launch-browser? launch-browser? boolean? (not command-line?)] [#:quit? quit? boolean? (not command-line?)] [#:banner? banner? boolean? (not command-line?)] - [#:listen-ip listen-ip string? "127.0.0.1"] + [#:listen-ip listen-ip (or/c false/c string?) "127.0.0.1"] [#:port port number? 8000] [#:servlet-path servlet-path string? "/servlets/standalone.ss"] From 333ec0dfc12414c7840e52931b680e317658133a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 20 Nov 2008 16:04:50 +0000 Subject: [PATCH 071/193] Docs for r12529 svn: r12541 --- .../web-server/scribblings/servlet-env.scrbl | 27 ++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 1fa4cdcca7..5f6a880934 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -6,6 +6,8 @@ @(require (for-label web-server/servlet-env web-server/http web-server/managers/lru + web-server/private/util + web-server/configuration/configuration-table web-server/configuration/responders scheme/list)) @@ -84,10 +86,14 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, [#:banner? banner? boolean? (not command-line?)] [#:listen-ip listen-ip (or/c false/c string?) "127.0.0.1"] [#:port port number? 8000] + [#:ssl? ssl? boolean? #f] [#:servlet-path servlet-path string? "/servlets/standalone.ss"] [#:servlet-regexp servlet-regexp regexp? - (regexp (format "^~a$" (regexp-quote servlet-path)))] + (regexp + (format + "^~a$" + (regexp-quote servlet-path)))] [#:stateless? stateless? boolean? #f] [#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))] [#:servlet-namespace servlet-namespace (listof module-path?) empty] @@ -96,9 +102,21 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, [#:servlets-root servlets-root path? (build-path server-root-path "htdocs")] [#:servlet-current-directory servlet-current-directory path? servlets-root] [#:file-not-found-responder file-not-found-responder - (gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))] + (gen-file-not-found-responder + (build-path + server-root-path + "conf" + "not-found.html"))] [#:mime-types-path mime-types-path path? - (build-path server-root-path "mime.types")]) + (let ([p (build-path + server-root-path + "mime.types")]) + (if (file-exists? p) + p + (build-path + (directory-part + default-configuration-table-path) + "mime.types")))]) void]{ This sets up and starts a fairly default server instance. @@ -115,6 +133,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, The server listens on @scheme[listen-ip] and port @scheme[port]. + If @scheme[ssl?] is true, then the server runs in HTTPS mode with @filepath{/server-cert.pem} + and @filepath{/private-key.pem} as the certificates and private keys + The servlet is loaded with @scheme[manager] as its continuation manager. (The default manager limits the amount of memory to 64 MB and deals with memory pressure as discussed in the @scheme[make-threshold-LRU-manager] documentation.) From 52a561fd3ebae729d8e4e3d391b55d51465fa2e1 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 20 Nov 2008 16:10:31 +0000 Subject: [PATCH 072/193] Adding docs and additional option for r12535 svn: r12542 --- collects/web-server/scribblings/servlet-env.scrbl | 9 ++++++++- collects/web-server/servlet-env.ss | 9 ++++----- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 5f6a880934..f4eda42536 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -9,6 +9,7 @@ web-server/private/util web-server/configuration/configuration-table web-server/configuration/responders + web-server/dispatchers/dispatch-log scheme/list)) @defmodule[web-server/servlet-env]{ @@ -102,6 +103,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, [#:servlets-root servlets-root path? (build-path server-root-path "htdocs")] [#:servlet-current-directory servlet-current-directory path? servlets-root] [#:file-not-found-responder file-not-found-responder + (request? . -> . response?) (gen-file-not-found-responder (build-path server-root-path @@ -116,7 +118,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, (build-path (directory-part default-configuration-table-path) - "mime.types")))]) + "mime.types")))] + [#:log-file log-file path? #f] + [#:log-format log-format symbol? 'apache-default]) void]{ This sets up and starts a fairly default server instance. @@ -154,6 +158,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, running from the command line, in which case the @scheme[command-line?] option controls similar options. MIME types are looked up at @scheme[mime-types-path]. + + If @scheme[log-file] is given, then it used to log requests using @scheme[log-format] as the format. Allowable formats + are those allowed by @scheme[log-format->format]. } } \ No newline at end of file diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 2e8fd2a751..17166d313c 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -128,7 +128,9 @@ "mime.types")))] #:log-file - [log-file #f]) + [log-file #f] + #:log-format + [log-format 'apache-default]) (define standalone-url (string-append (if ssl? "https" "http") "://localhost" @@ -141,10 +143,7 @@ (define servlet-box (box #f)) (define dispatcher (dispatcher-sequence - (and log-file (log:make #:format (log:log-format->format - ;; 'parenthesized-default - ;; 'extended - 'apache-default) + (and log-file (log:make #:format (log:log-format->format log-format) #:log-path log-file)) (and quit? (filter:make #rx"^/quit$" (quit-server sema))) (filter:make From 746184ef5ab97050ba0200347ec543d5a744f2cf Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 20 Nov 2008 20:41:59 +0000 Subject: [PATCH 073/193] Changing docs to have better explanation svn: r12544 --- .../web-server/scribblings/servlet-env.scrbl | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index f4eda42536..375ca2196a 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -110,15 +110,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, "conf" "not-found.html"))] [#:mime-types-path mime-types-path path? - (let ([p (build-path - server-root-path - "mime.types")]) - (if (file-exists? p) - p - (build-path - (directory-part - default-configuration-table-path) - "mime.types")))] + ...] [#:log-file log-file path? #f] [#:log-format log-format symbol? 'apache-default]) void]{ @@ -157,8 +149,10 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, If @scheme[banner?] is true, then an informative banner is printed. You may want to use this when running from the command line, in which case the @scheme[command-line?] option controls similar options. - MIME types are looked up at @scheme[mime-types-path]. - + MIME types are looked up at @scheme[mime-types-path]. By default the @filepath{mime.types} file in the + @scheme[server-root-path] is used, but if that file does not exist, then the file that ships with the + Web Server is used instead. Of course, if a path is given, then it overrides this behavior. + If @scheme[log-file] is given, then it used to log requests using @scheme[log-format] as the format. Allowable formats are those allowed by @scheme[log-format->format]. } From accd20a8ed18f23a34552b42d283845f0fd22990 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 Nov 2008 20:45:02 +0000 Subject: [PATCH 074/193] remove debugging code svn: r12545 --- src/mzscheme/src/read.c | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index 473c2b1f15..f80452e61e 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -4371,8 +4371,6 @@ static Scheme_Object *read_compact_k(void) return read_compact(port, p->ku.k.i1); } -int dump_info = 0; - static Scheme_Object *read_compact(CPort *port, int use_stack) { #define BLK_BUF_SIZE 32 @@ -4398,9 +4396,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) ZO_CHECK(port->pos < port->size); ch = CP_GETC(port); - if (dump_info) - printf("%d %d %d\n", ch, port->pos, need_car); - switch(cpt_branch[ch]) { case CPT_ESCAPE: { @@ -4456,8 +4451,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) case CPT_SYMREF: l = read_compact_number(port); RANGE_CHECK(l, < port->symtab_size); - if (dump_info) - printf("%d\n", l); v = port->symtab[l]; if (!v) { long save_pos = port->pos; @@ -5268,7 +5261,6 @@ static Scheme_Object *read_compiled(Scheme_Object *port, len = symtabsize; for (j = 1; j < len; j++) { if (!symtab[j]) { - if (dump_info) printf("at %ld %ld\n", j, rp->pos); v = read_compact(rp, 0); symtab[j] = v; } else { From f0b72082eb41971b65d08d1fed316fb05214a12a Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Thu, 20 Nov 2008 21:15:21 +0000 Subject: [PATCH 075/193] Fixed typos in Plugin docs: Many contracts had redundant @scheme[...] around them, which rendered as (scheme ...) in the final product. svn: r12546 --- collects/scribblings/tools/frame.scrbl | 6 +++--- collects/scribblings/tools/language.scrbl | 2 +- collects/scribblings/tools/rep.scrbl | 6 +++--- collects/scribblings/tools/unit.scrbl | 22 +++++++++++----------- 4 files changed, 18 insertions(+), 18 deletions(-) diff --git a/collects/scribblings/tools/frame.scrbl b/collects/scribblings/tools/frame.scrbl index d35029a89a..38e59531e4 100644 --- a/collects/scribblings/tools/frame.scrbl +++ b/collects/scribblings/tools/frame.scrbl @@ -60,7 +60,7 @@ if the } @defmethod[#:mode override - (file-menu:between-open-and-revert [file-menu (is-a?/c @scheme[menu%])]) + (file-menu:between-open-and-revert [file-menu (is-a?/c menu%)]) void?]{ Adds an ``Install .plt File...'' menu item, which @@ -72,7 +72,7 @@ method. } @defmethod[#:mode override - (file-menu:between-print-and-close [file-menu (is-a?/c @scheme[menu%])]) + (file-menu:between-print-and-close [file-menu (is-a?/c menu%)]) void?]{ Calls the super method. Then, creates a menu item for @@ -187,7 +187,7 @@ This interface is the result of the @scheme[drscheme:frame:basics-mixin] -@defmethod[(add-show-menu-items [show-menu (is-a?/c @scheme[menu%])]) +@defmethod[(add-show-menu-items [show-menu (is-a?/c menu%)]) void?]{ @methspec{ diff --git a/collects/scribblings/tools/language.scrbl b/collects/scribblings/tools/language.scrbl index f866ef30ed..57970c2498 100644 --- a/collects/scribblings/tools/language.scrbl +++ b/collects/scribblings/tools/language.scrbl @@ -415,7 +415,7 @@ for this language. } @defmethod[(get-transformer-module) - (or/c quoted-module-path @scheme[#f])]{ + (or/c quoted-module-path #f)]{ This method specifies the module that defines the transformation language. It is used to initialize the transformer portion of the user's namespace. diff --git a/collects/scribblings/tools/rep.scrbl b/collects/scribblings/tools/rep.scrbl index 357e1a9f3e..a5a53991ca 100644 --- a/collects/scribblings/tools/rep.scrbl +++ b/collects/scribblings/tools/rep.scrbl @@ -15,7 +15,7 @@ class affect the implementation that uses it. -@defconstructor/make[([context (implements @scheme[drscheme:rep:context<%>])])]{ +@defconstructor/make[([context (implements drscheme:rep:context<%>)])]{ } @defmethod[#:mode override @@ -155,7 +155,7 @@ for more information about parameters. } -@defmethod[(highlight-errors [locs (listof (list (instance (implements @scheme[text:basic<%>])) small-integer small-integer))]) +@defmethod[(highlight-errors [locs (listof (list (instance (implements text:basic<%>)) small-integer small-integer))]) void?]{ Call this method to highlight errors associated with this repl. See also @@ -382,7 +382,7 @@ See also } -@defmethod[(ensure-rep-shown [rep (is-a?/c @scheme[drscheme:rep:text<%>])]) +@defmethod[(ensure-rep-shown [rep (is-a?/c drscheme:rep:text<%>)]) void?]{ This method is called to force the rep window to be visible when, for diff --git a/collects/scribblings/tools/unit.scrbl b/collects/scribblings/tools/unit.scrbl index d0b0bd5bbf..7188b0f139 100644 --- a/collects/scribblings/tools/unit.scrbl +++ b/collects/scribblings/tools/unit.scrbl @@ -43,7 +43,7 @@ Enables the Run button, and the Run menu item and unlocks (values (or/c thread? false/c) (or/c custodian? false/c))]{} @defmethod[(get-defs) - (is-a?/c @scheme[drscheme:unit:definitions-text<%>])]{ + (is-a?/c drscheme:unit:definitions-text<%>)]{ This text is initially the top half of the drscheme window and contains the users program. @@ -73,13 +73,13 @@ is already running (in another thread). } @defmethod[(get-frame) - (is-a?/c @scheme[drscheme:unit:frame%])]{ + (is-a?/c drscheme:unit:frame%)]{ Returns the frame that this tab is inside. } @defmethod[(get-ints) - (is-a?/c @scheme[drscheme:rep:text%])]{ + (is-a?/c drscheme:rep:text%)]{ This text is initially the bottom half of the drscheme window and contains the users interactions with the REPL. @@ -216,7 +216,7 @@ Passes all arguments to @scheme[super-init]. } @defmethod[#:mode override - (add-show-menu-items [show-menu (is-a?/c @scheme[menu%])]) + (add-show-menu-items [show-menu (is-a?/c menu%)]) void?]{ Adds the ``Show Definitions'', ``Show Interactions'' and @@ -570,7 +570,7 @@ Shows the interactions window } @defmethod[(get-current-tab) - (is-a?/c @scheme[drscheme:unit:tab<%>])]{ + (is-a?/c drscheme:unit:tab<%>)]{ Returns the currently active tab. } @@ -607,7 +607,7 @@ Returns the Insert menu. }} @defmethod[(get-interactions-canvas) - (instanceof (derivedfrom @scheme[drscheme:unit:interactions-canvas%]))]{ + (instanceof (derivedfrom drscheme:unit:interactions-canvas%))]{ This canvas is the canvas containing the @method[drscheme:unit:frame<%> get-interactions-text]. It is initially the bottom half of the drscheme window. @@ -621,7 +621,7 @@ it will use the extended class to create the canvas. } @defmethod[(get-interactions-text) - (instanceof (derivedfrom @scheme[drscheme:rep:text%]))]{ + (instanceof (derivedfrom drscheme:rep:text%))]{ Calls result of @method[drscheme:unit:frame<%> get-current-tab]'s @@ -631,7 +631,7 @@ Calls result of } @defmethod[(get-tabs) - (listof @scheme[drscheme:unit:tab<%>])]{ + (listof drscheme:unit:tab<%>)]{ Returns the list of tabs in this frame. } @@ -656,7 +656,7 @@ The @scheme[from-tab] argument is the previously selected tab, and the }} @defmethod[(register-capability-menu-item [key symbol] - [menu (is-a? @scheme[menu%])]) + [menu (is-a? menu%)]) void?]{ Registers the menu item that was most recently added as being controlled by the capability @scheme[key]. This means @@ -773,7 +773,7 @@ the editor should be used.) } @defmethod[(get-tab) - (instanceof @scheme[drscheme:unit:tab%])]{ + (instanceof drscheme:unit:tab%)]{ Returns the editor's enclosing tab. } @@ -807,7 +807,7 @@ an interaction (unless the Runs first). }} @defmethod[(set-next-settings [language-settings language-settings] - [update-prefs? any/c @scheme[#t]]) + [update-prefs? any/c #t]) void?]{ Changes the language settings for this window. If From 2382712f3fe64b49485bf2de9af40216e4a48eae Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 20 Nov 2008 22:03:43 +0000 Subject: [PATCH 076/193] fixed exponential slowdown bug svn: r12547 --- collects/slideshow/pict.ss | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss index 9e2f3210a6..3a8e3c7250 100644 --- a/collects/slideshow/pict.ss +++ b/collects/slideshow/pict.ss @@ -44,9 +44,9 @@ #:line-width [lw #f] #:color [col #f] #:under? [under? #f]) - (finish-pin (t:pin-line (ghost p) - src find-src - dest find-dest) + (finish-pin (launder (t:pin-line (ghost p) + src find-src + dest find-dest)) p lw col under?)) (define (pin-arrow-line sz p src find-src dest find-dest @@ -54,10 +54,10 @@ #:color [col #f] #:under? [under? #f] #:solid? [solid? #t]) - (finish-pin (t:pin-arrow-line sz (ghost p) - src find-src - dest find-dest - #f #f #f solid?) + (finish-pin (launder (t:pin-arrow-line sz (ghost p) + src find-src + dest find-dest + #f #f #f solid?)) p lw col under?)) (define (pin-arrows-line sz p src find-src dest find-dest @@ -65,10 +65,10 @@ #:color [col #f] #:under? [under? #f] #:solid? [solid? #t]) - (finish-pin (t:pin-arrows-line sz (ghost p) - src find-src - dest find-dest - #f #f #f solid?) + (finish-pin (launder (t:pin-arrows-line sz (ghost p) + src find-src + dest find-dest + #f #f #f solid?)) p lw col under?)) (define (finish-pin l p lw col under?) From e27ae4d4577ee78df53fb6afee0152007112e244 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 20 Nov 2008 22:30:29 +0000 Subject: [PATCH 077/193] bindings for the rest of scheme/bool svn: r12548 --- collects/typed-scheme/private/base-env.ss | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 641376322e..a71c975708 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -3,6 +3,7 @@ (require scheme/list scheme/tcp + scheme (only-in rnrs/lists-6 fold-left) '#%paramz (only-in '#%kernel [apply kernel:apply]) @@ -493,4 +494,9 @@ [tcp-close (-TCP-Listener . -> . -Void )] [tcp-connect (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] [tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] -[tcp-listen (N . -> . -TCP-Listener)] \ No newline at end of file +[tcp-listen (N . -> . -TCP-Listener)] + +;; scheme/bool +[boolean=? (B B . -> . B)] +[symbol=? (Sym Sym . -> . B)] +[false? (make-pred-ty (-val #f))] \ No newline at end of file From bea22974216d0b8f26b3b79f6596ee3aaafd6329 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Thu, 20 Nov 2008 23:36:54 +0000 Subject: [PATCH 078/193] Make GC callbacks members of NewGC svn: r12549 --- src/mred/wxs/wxscheme.cxx | 6 ++--- src/mzscheme/gc/alloc.c | 16 ++++++++++++-- src/mzscheme/gc/include/gc.h | 6 +++-- src/mzscheme/gc2/gc2.h | 16 +++++++++----- src/mzscheme/gc2/newgc.c | 43 +++++++++++++++++++++++++++--------- src/mzscheme/gc2/newgc.h | 6 +++++ src/mzscheme/sgc/sgc.c | 19 ++++++++++++++-- src/mzscheme/src/port.c | 7 ++---- src/mzscheme/src/salloc.c | 2 +- src/mzscheme/src/thread.c | 16 +++++--------- 10 files changed, 94 insertions(+), 43 deletions(-) diff --git a/src/mred/wxs/wxscheme.cxx b/src/mred/wxs/wxscheme.cxx index 4b5372865a..4168f8f063 100644 --- a/src/mred/wxs/wxscheme.cxx +++ b/src/mred/wxs/wxscheme.cxx @@ -162,10 +162,8 @@ void wxsScheme_setup(Scheme_Env *env) get_ps_setup_from_user = scheme_false; message_box = scheme_false; - orig_collect_start_callback = GC_collect_start_callback; - GC_collect_start_callback = (GC_START_END_PTR)collect_start_callback; - orig_collect_end_callback = GC_collect_end_callback; - GC_collect_end_callback = (GC_START_END_PTR)collect_end_callback; + orig_collect_start_callback = GC_set_collect_start_callback(collect_start_callback); + orig_collect_end_callback = GC_set_collect_end_callback(collect_end_callback); } extern "C" { diff --git a/src/mzscheme/gc/alloc.c b/src/mzscheme/gc/alloc.c index 75db270553..1ef473e1ff 100644 --- a/src/mzscheme/gc/alloc.c +++ b/src/mzscheme/gc/alloc.c @@ -320,8 +320,20 @@ void GC_maybe_gc() } /* PLTSCHEME: notification callback for starting/ending a GC */ -void (*GC_collect_start_callback)(void) = NULL; -void (*GC_collect_end_callback)(void) = NULL; +GC_collect_start_callback_Proc GC_collect_start_callback = NULL; +GC_collect_end_callback_Proc GC_collect_end_callback = NULL; +GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc func) { + GC_collect_start_callback_Proc old; + old = GC_collect_start_callback; + GC_collect_start_callback = func; + return old; +} +GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc func) { + GC_collect_end_callback_Proc old; + old = GC_collect_end_callback; + GC_collect_end_callback = func; + return old; +} /* * Stop the world garbage collection. Assumes lock held, signals disabled. diff --git a/src/mzscheme/gc/include/gc.h b/src/mzscheme/gc/include/gc.h index dc61c1434a..3c482034a3 100644 --- a/src/mzscheme/gc/include/gc.h +++ b/src/mzscheme/gc/include/gc.h @@ -1017,13 +1017,15 @@ extern void GC_thr_init GC_PROTO((void));/* Needed for Solaris/X86 */ #if defined(GC_REDIRECT_TO_LOCAL) && !defined(GC_LOCAL_ALLOC_H) # include "gc_local_alloc.h" #endif +typedef void (*GC_collect_start_callback_Proc)(void); +typedef void (*GC_collect_end_callback_Proc)(void); /* PLTSCHEME: */ GC_API void (*GC_custom_finalize)(void); GC_API void (*GC_push_last_roots)(void); GC_API void (*GC_push_last_roots_again)(void); -GC_API void (*GC_collect_start_callback)(void); -GC_API void (*GC_collect_end_callback)(void); +GC_API GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc); +GC_API GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc); GC_API void (*GC_out_of_memory)(void); GC_API int GC_did_mark_stack_overflow(void); GC_API void GC_mark_from_mark_stack(void); diff --git a/src/mzscheme/gc2/gc2.h b/src/mzscheme/gc2/gc2.h index 807e869778..01d6503c46 100644 --- a/src/mzscheme/gc2/gc2.h +++ b/src/mzscheme/gc2/gc2.h @@ -21,6 +21,10 @@ typedef int (*Size_Proc)(void *obj); typedef int (*Mark_Proc)(void *obj); typedef int (*Fixup_Proc)(void *obj); +typedef void (*GC_collect_start_callback_Proc)(void); +typedef void (*GC_collect_end_callback_Proc)(void); +typedef void (*GC_collect_inform_callback_Proc)(int major_gc, long pre_used, long post_used); +typedef unsigned long (*GC_get_thread_stack_base_Proc)(void); /* Types of the traversal procs (supplied by MzScheme); see overview in README for information about traversals. The return value is the size of @@ -56,9 +60,9 @@ extern "C" { /* Administration */ /***************************************************************************/ -GC2_EXTERN unsigned long (*GC_get_thread_stack_base)(void); +GC2_EXTERN void GC_set_get_thread_stack_base(unsigned long (*)(void)); /* - Called by GC to get the base for stack traversal in the current + Sets callback called by GC to get the base for stack traversal in the current thread (see README). The returned address must not be in the middle of a variable-stack record. */ @@ -96,11 +100,11 @@ GC2_EXTERN void GC_register_thread(void *, void *); /* Indicates that a a thread record is owned by a particular custodian. */ -GC2_EXTERN void (*GC_collect_start_callback)(void); -GC2_EXTERN void (*GC_collect_end_callback)(void); -GC2_EXTERN void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used); +GC2_EXTERN GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc); +GC2_EXTERN GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc); +GC2_EXTERN void GC_set_collect_inform_callback(GC_collect_inform_callback_Proc); /* - Called by GC before/after performing a collection. Used by MzScheme + Sets callbacks called by GC before/after performing a collection. Used by MzScheme to zero out some data and record collection times. The end procedure should be called before finalizations are performed. */ diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 3d26e0214c..4b0ad4cb1d 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -130,15 +130,31 @@ static THREAD_LOCAL NewGC *GC; #define GENERATIONS 1 /* the externals */ -void (*GC_collect_start_callback)(void); -void (*GC_collect_end_callback)(void); -void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used); void (*GC_out_of_memory)(void); void (*GC_report_out_of_memory)(void); -unsigned long (*GC_get_thread_stack_base)(void); void (*GC_mark_xtagged)(void *obj); void (*GC_fixup_xtagged)(void *obj); +GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc func) { + NewGC *gc = GC_get_GC(); + GC_collect_start_callback_Proc old; + old = gc->GC_collect_start_callback; + gc->GC_collect_start_callback = func; + return old; +} +GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc func) { + NewGC *gc = GC_get_GC(); + GC_collect_end_callback_Proc old; + old = gc->GC_collect_end_callback; + gc->GC_collect_end_callback = func; + return old; +} +void GC_set_collect_inform_callback(void (*func)(int major_gc, long pre_used, long post_used)) { + NewGC *gc = GC_get_GC(); + gc->GC_collect_inform_callback = func; +} + + #include "my_qsort.c" /*****************************************************************************/ @@ -982,8 +998,13 @@ unsigned long GC_get_stack_base() return gc->stack_base; } +void GC_set_get_thread_stack_base(unsigned long (*func)(void)) { + NewGC *gc = GC_get_GC(); + gc->GC_get_thread_stack_base = func; +} + static inline void *get_stack_base(NewGC *gc) { - if (GC_get_thread_stack_base) return (void*) GC_get_thread_stack_base(); + if (gc->GC_get_thread_stack_base) return (void*) gc->GC_get_thread_stack_base(); return (void*) gc->stack_base; } @@ -2409,8 +2430,8 @@ static void garbage_collect(NewGC *gc, int force_full) TIME_INIT(); /* inform the system (if it wants us to) that we're starting collection */ - if(GC_collect_start_callback) - GC_collect_start_callback(); + if(gc->GC_collect_start_callback) + gc->GC_collect_start_callback(); TIME_STEP("started"); @@ -2530,10 +2551,10 @@ static void garbage_collect(NewGC *gc, int force_full) gc->last_full_mem_use = gc->memory_in_use; /* inform the system (if it wants us to) that we're done with collection */ - if (GC_collect_start_callback) - GC_collect_end_callback(); - if (GC_collect_inform_callback) - GC_collect_inform_callback(gc->gc_full, old_mem_use + old_gen0, gc->memory_in_use); + if (gc->GC_collect_start_callback) + gc->GC_collect_end_callback(); + if (gc->GC_collect_inform_callback) + gc->GC_collect_inform_callback(gc->gc_full, old_mem_use + old_gen0, gc->memory_in_use); TIME_STEP("ended"); diff --git a/src/mzscheme/gc2/newgc.h b/src/mzscheme/gc2/newgc.h index c5f05eeacc..2b6e087f5c 100644 --- a/src/mzscheme/gc2/newgc.h +++ b/src/mzscheme/gc2/newgc.h @@ -151,6 +151,12 @@ typedef struct NewGC { unsigned long num_minor_collects; unsigned long num_major_collects; + /* Callbacks */ + void (*GC_collect_start_callback)(void); + void (*GC_collect_end_callback)(void); + void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used); + unsigned long (*GC_get_thread_stack_base)(void); + GC_Immobile_Box *immobile_boxes; /* Common with CompactGC */ diff --git a/src/mzscheme/sgc/sgc.c b/src/mzscheme/sgc/sgc.c index fbc280d7db..31330e255c 100644 --- a/src/mzscheme/sgc/sgc.c +++ b/src/mzscheme/sgc/sgc.c @@ -776,10 +776,25 @@ static long mem_traced; static long num_chunks; static long num_blocks; -void (*GC_collect_start_callback)(void); -void (*GC_collect_end_callback)(void); +typedef void (*GC_collect_start_callback_Proc)(void); +typedef void (*GC_collect_end_callback_Proc)(void); +GC_collect_start_callback_Proc GC_collect_start_callback; +GC_collect_end_callback_Proc GC_collect_end_callback; void (*GC_custom_finalize)(void); +GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc) { + GC_collect_start_callback_Proc old; + old = GC_collect_start_callback; + GC_collect_start_callback = func; + return old +} +GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc) { + GC_collect_end_callback_Proc old + old = GC_collect_end_callback; + GC_collect_end_callback = func; + return old +} + static long roots_count; static long roots_size; static unsigned long *roots; diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 6eaba89dff..2d1fd56220 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -892,9 +892,6 @@ typedef struct Scheme_Thread_Memory { Scheme_Thread_Memory *tm_start, *tm_next; -extern MZ_DLLIMPORT void (*GC_collect_start_callback)(void); -extern MZ_DLLIMPORT void (*GC_collect_end_callback)(void); - void scheme_init_thread_memory() { #ifndef MZ_PRECISE_GC @@ -915,8 +912,8 @@ void scheme_init_thread_memory() #endif /* scheme_init_thread() will replace these: */ - GC_collect_start_callback = scheme_suspend_remembered_threads; - GC_collect_end_callback = scheme_resume_remembered_threads; + GC_set_collect_start_callback(scheme_suspend_remembered_threads); + GC_set_collect_end_callback(scheme_resume_remembered_threads); } Scheme_Thread_Memory *scheme_remember_thread(void *t, int autoclose) diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index 175f0748fc..db5e8a50a8 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -2053,7 +2053,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) scheme_console_printf(" swapped in\n"); var_stack = GC_variable_stack; delta = 0; - limit = (void *)GC_get_thread_stack_base(); + limit = (void *)scheme_get_current_thread_stack_start(); } else { scheme_console_printf(" swapped out\n"); var_stack = (void **)t->jmpup_buf.gc_var_stack; diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index ea2669aa44..adbc13f86d 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -200,10 +200,6 @@ Scheme_Object *scheme_break_enabled_key; long scheme_total_gc_time; static long start_this_gc_time, end_this_gc_time; -#ifndef MZ_PRECISE_GC -extern MZ_DLLIMPORT void (*GC_collect_start_callback)(void); -extern MZ_DLLIMPORT void (*GC_collect_end_callback)(void); -#endif static void get_ready_for_GC(void); static void done_with_GC(void); #ifdef MZ_PRECISE_GC @@ -437,7 +433,7 @@ extern BOOL WINAPI DllMain(HINSTANCE inst, ULONG reason, LPVOID reserved); #endif #ifdef MZ_PRECISE_GC -static unsigned long get_current_stack_start(void); +unsigned long scheme_get_current_thread_stack_start(void); #endif /*========================================================================*/ @@ -2106,10 +2102,10 @@ static Scheme_Thread *make_thread(Scheme_Config *config, thread_swap_callbacks = scheme_null; thread_swap_out_callbacks = scheme_null; - GC_collect_start_callback = get_ready_for_GC; - GC_collect_end_callback = done_with_GC; + GC_set_collect_start_callback(get_ready_for_GC); + GC_set_collect_end_callback(done_with_GC); #ifdef MZ_PRECISE_GC - GC_collect_inform_callback = inform_GC; + GC_set_collect_inform_callback(inform_GC); #endif #ifdef LINK_EXTENSIONS_BY_TABLE @@ -2118,7 +2114,7 @@ static Scheme_Thread *make_thread(Scheme_Config *config, #endif #if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC) - GC_get_thread_stack_base = get_current_stack_start; + GC_set_get_thread_stack_base(scheme_get_current_thread_stack_start); #endif process->stack_start = stack_base; @@ -7448,7 +7444,7 @@ Scheme_Jumpup_Buf_Holder *scheme_new_jmpupbuf_holder(void) } #ifdef MZ_PRECISE_GC -static unsigned long get_current_stack_start(void) +unsigned long scheme_get_current_thread_stack_start(void) { Scheme_Thread *p; p = scheme_current_thread; From daff0abe158ddf4b8ae1516ef1e08ae3c62a00c6 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 20 Nov 2008 23:57:32 +0000 Subject: [PATCH 079/193] Extended example svn: r12550 --- .../template/examples/blog-posted.html | 4 + .../template/examples/blog-posts.html | 16 + .../template/examples/blog-xexpr.ss | 93 ++++++ .../web-server/template/examples/blog.html | 32 ++ .../web-server/template/examples/blog.ss | 46 +++ .../web-server/scribblings/templates.scrbl | 296 +++++++++++++++++- 6 files changed, 475 insertions(+), 12 deletions(-) create mode 100644 collects/tests/web-server/template/examples/blog-posted.html create mode 100644 collects/tests/web-server/template/examples/blog-posts.html create mode 100644 collects/tests/web-server/template/examples/blog-xexpr.ss create mode 100644 collects/tests/web-server/template/examples/blog.html create mode 100644 collects/tests/web-server/template/examples/blog.ss diff --git a/collects/tests/web-server/template/examples/blog-posted.html b/collects/tests/web-server/template/examples/blog-posted.html new file mode 100644 index 0000000000..b3284cdd9e --- /dev/null +++ b/collects/tests/web-server/template/examples/blog-posted.html @@ -0,0 +1,4 @@ +

@|title|

+

@|body|

+ +

Continue

\ No newline at end of file diff --git a/collects/tests/web-server/template/examples/blog-posts.html b/collects/tests/web-server/template/examples/blog-posts.html new file mode 100644 index 0000000000..669399ac7c --- /dev/null +++ b/collects/tests/web-server/template/examples/blog-posts.html @@ -0,0 +1,16 @@ +@in[p posts]{ +

@(post-title p)

+

@(post-body p)

+
    + @in[c (post-comments p)]{ +
  • @|c|
    • + } +
+} + +

New Post

+
+ + + +
diff --git a/collects/tests/web-server/template/examples/blog-xexpr.ss b/collects/tests/web-server/template/examples/blog-xexpr.ss new file mode 100644 index 0000000000..807b7c4a62 --- /dev/null +++ b/collects/tests/web-server/template/examples/blog-xexpr.ss @@ -0,0 +1,93 @@ +#lang scheme +(require web-server/servlet + xml + web-server/servlet-env) + +(define-struct post (title body comments)) + +(define posts + (list + (make-post + "(Y Y) Works: The Why of Y" + "..." + (list + "First post! - A.T." + "Didn't I write this? - Matthias")) + (make-post + "Church and the States" + "As you may know, I grew up in DC, not technically a state..." + (list + "Finally, A Diet That Really Works! As Seen On TV")))) + +(define (template section body) + `(html + (head (title "Alonzo's Church: " ,section) + (style ([type "text/css"]) + ,(make-cdata #f #f " + body { + margin: 0px; + padding: 10px; + } + + #main { + background: #dddddd; + }"))) + (body + (script ([type "text/javascript"]) + ,(make-cdata #f #f " + var gaJsHost = ((\"https:\" == document.location.protocol) ? + \"https://ssl.\" : \"http://www.\"); + document.write(unescape(\"%3Cscript src='\" + gaJsHost + + \"google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E\")); +")) + (script ([type "text/javascript"]) + ,(make-cdata #f #f " + var pageTracker = _gat._getTracker(\"UA-YYYYYYY-Y\"); + pageTracker._trackPageview(); +")) + + (h1 "Alonzo's Church: " ,section) + (div ([id "main"]) + ,@body)))) + +(define (blog-posted title body k-url) + `((h2 ,title) + (p ,body) + (h1 (a ([href ,k-url]) "Continue")))) + +(define (extract-post req) + (define title (extract-binding/single 'title (request-bindings req))) + (define body (extract-binding/single 'body (request-bindings req))) + (set! posts + (list* (make-post title body empty) + posts)) + (send/suspend + (lambda (k-url) + (template "Posted" (blog-posted title body k-url)))) + (display-posts)) + +(define (blog-posts k-url) + (append + (apply append + (for/list ([p posts]) + `((h2 ,(post-title p)) + (p ,(post-body p)) + (ul + ,@(for/list ([c (post-comments p)]) + `(li ,c)))))) + `((h1 "New Post") + (form ([action ,k-url]) + (input ([name "title"])) + (input ([name "body"])) + (input ([type "submit"])))))) + +(define (display-posts) + (extract-post + (send/suspend + (lambda (k-url) + (template "Posts" (blog-posts k-url)))))) + +(define (start req) + (display-posts)) + +(serve/servlet start) diff --git a/collects/tests/web-server/template/examples/blog.html b/collects/tests/web-server/template/examples/blog.html new file mode 100644 index 0000000000..c5dc3f41bd --- /dev/null +++ b/collects/tests/web-server/template/examples/blog.html @@ -0,0 +1,32 @@ + + + Alonzo's Church: @|section| + + + + + + +

Alonzo's Church: @|section|

+
+ @body +
+ + diff --git a/collects/tests/web-server/template/examples/blog.ss b/collects/tests/web-server/template/examples/blog.ss new file mode 100644 index 0000000000..34e0c12a82 --- /dev/null +++ b/collects/tests/web-server/template/examples/blog.ss @@ -0,0 +1,46 @@ +#lang scheme +(require web-server/templates + web-server/servlet + web-server/servlet-env) + +(define-struct post (title body comments)) + +(define posts + (list + (make-post + "(Y Y) Works: The Why of Y" + "..." + (list + "First post! - A.T." + "Didn't I write this? - Matthias")) + (make-post + "Church and the States" + "As you may know, I grew up in DC, not technically a state..." + (list + "Finally, A Diet That Really Works! As Seen On TV")))) + +(define (template section body) + (list TEXT/HTML-MIME-TYPE + (include-template "blog.html"))) + +(define (extract-post req) + (define title (extract-binding/single 'title (request-bindings req))) + (define body (extract-binding/single 'body (request-bindings req))) + (set! posts + (list* (make-post title body empty) + posts)) + (send/suspend + (lambda (k-url) + (template "Posted" (include-template "blog-posted.html")))) + (display-posts)) + +(define (display-posts) + (extract-post + (send/suspend + (lambda (k-url) + (template "Posts" (include-template "blog-posts.html")))))) + +(define (start req) + (display-posts)) + +(serve/servlet start) diff --git a/collects/web-server/scribblings/templates.scrbl b/collects/web-server/scribblings/templates.scrbl index a42b233b04..f202eee7ad 100644 --- a/collects/web-server/scribblings/templates.scrbl +++ b/collects/web-server/scribblings/templates.scrbl @@ -2,11 +2,13 @@ @(require "web-server.ss") @(require (for-label web-server/servlet web-server/templates + scheme/promise scheme/list xml)) @(define xexpr @tech[#:doc '(lib "xml/xml.scrbl")]{X-expression}) @(define at-reader-ref @secref[#:doc '(lib "scribblings/scribble/scribble.scrbl")]{reader}) +@(define text-ref @secref[#:doc '(lib "scribblings/scribble/scribble.scrbl")]{preprocessor}) @title[#:tag "templates"]{Templates} @@ -15,6 +17,9 @@ The @web-server provides a powerful Web template system for separating the presentation logic of a Web application and enabling non-programmers to contribute to PLT-based Web applications. +@margin-note{Although all the examples here generate HTML, the template language and the @text-ref it is based on can + be used to generate any text-based format: C, SQL, form emails, reports, etc.} + @local-table-of-contents[] @section{Static} @@ -62,8 +67,8 @@ Then ] evaluates to the same content as the static example. -There is no constraints on the values, the way they are used, or the way they are defined, that are made accessible to the template. -For example, +There are no constraints on how the lexical context of the template is populated. For instance, you can built template abstractions +by wrapping the inclusion of a template in a function: @schemeblock[ (define (fast-template thing) (include-template "simple.html")) @@ -94,18 +99,71 @@ and }| +Furthermore, there are no constraints on the Scheme used by templates: they can use macros, structs, continuation marks, threads, etc. +However, Scheme values that are ultimately returned must be printable by the @text-ref@"." +For example, consider the following outputs of the +title line of different calls to @scheme[fast-template]: + +@itemize{ + +@item{ +@schemeblock[ + (fast-template 'Templates) +] +@verbatim[#:indent 2]|{ + Fastest Templates in the West! +}| +} + +@item{ +@schemeblock[ + (fast-template 42) +] +@verbatim[#:indent 2]|{ + Fastest 42 in the West! +}| +} + +@item{ +@schemeblock[ + (fast-template (list "Noo" "dles")) +] +@verbatim[#:indent 2]|{ + Fastest Noodles in the West! +}| +} + +@item{ +@schemeblock[ + (fast-template (lambda () "Thunks")) +] +@verbatim[#:indent 2]|{ + Fastest Thunks in the West! +}| +} + +@item{ +@schemeblock[ + (fast-template (delay "Laziness")) +] +@verbatim[#:indent 2]|{ + Fastest Laziness in the West! +}| +} +} + @section{Gotchas} -One of the most important things to remember about the @at-reader-ref syntax is that the @"@" symbol must be escaped in content: +To obtain an @"@" symbol in template output, you must escape the @"@" symbol, because it is the escape character of the @at-reader-ref syntax. +For example, to obtain: @verbatim[#:indent 2]|{ - - Fastest @"@"s in the West! - -

Bang!

-

Bang!

- - + Fastest @s in the West! }| +You must write: +@verbatim[#:indent 2]|{ + Fastest @"@"s in the West! +}| +as your template: literal @"@"s must be replaced with @"@\"@\"". The other gotcha is that since the template is compiled into a Scheme program, only its results will be printed. For example, suppose we have the template: @@ -117,7 +175,7 @@ we have the template: }| -If this is included in a lexical context with @scheme[clients] bound to @scheme[(list (cons "Young" "Brigham") (cons "Smith" "Joseph"))], +If this is included in a lexical context with @scheme[clients] bound to @schemeblock[(list (cons "Young" "Brigham") (cons "Smith" "Joseph"))] then the template will be printed as: @verbatim[#:indent 2]|{ @@ -225,4 +283,218 @@ the template to be unescaped, then create a @scheme[cdata] structure: (in c clients "") ] } - \ No newline at end of file + +@section{Conversion Example} + +Alonzo Church has been maintaining a blog with PLT Scheme for some years and would like to convert to @schememodname[web-server/templates]. + +Here's the code he starts off with: +@schememod[ + scheme +(require xml + web-server/servlet + web-server/servlet-env) + +(code:comment "He actually Church-encodes them, but we'll use structs.") +(define-struct post (title body comments)) + +(define posts + (list + (make-post + "(Y Y) Works: The Why of Y" + "..." + (list + "First post! - A.T." + "Didn't I write this? - Matthias")) + (make-post + "Church and the States" + "As you may know, I grew up in DC, not technically a state..." + (list + "Finally, A Diet That Really Works! As Seen On TV")))) + +(code:comment "A function that is the generic template for the site") +(define (template section body) + `(html + (head (title "Alonzo's Church: " ,section) + (style ([type "text/css"]) + (code:comment "CDATA objects were useful for returning raw data") + ,(make-cdata #f #f "\n body {\n margin: 0px;\n padding: 10px;\n }\n\n #main {\n background: #dddddd;\n }"))) + (body + (script ([type "text/javascript"]) + (code:comment "Which is particularly useful for JavaScript") + ,(make-cdata #f #f "\n var gaJsHost = ((\"https:\" == document.location.protocol) ?\n \"https://ssl.\" : \"http://www.\");\n document.write(unescape(\"%3Cscript src='\" + gaJsHost +\n \"google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E\"));\n")) + (script ([type "text/javascript"]) + ,(make-cdata #f #f "\n var pageTracker = _gat._getTracker(\"UA-YYYYYYY-Y\");\n pageTracker._trackPageview();\n")) + + (h1 "Alonzo's Church: " ,section) + (div ([id "main"]) + (code:comment "He had to be careful to use splicing here") + ,@body)))) + +(define (blog-posted title body k-url) + `((h2 ,title) + (p ,body) + (h1 (a ([href ,k-url]) "Continue")))) + +(define (extract-post req) + (define binds + (request-bindings req)) + (define title + (extract-binding/single 'title binds)) + (define body + (extract-binding/single 'body binds)) + (set! posts + (list* (make-post title body empty) + posts)) + (send/suspend + (lambda (k-url) + (template "Posted" (blog-posted title body k-url)))) + (display-posts)) + +(define (blog-posts k-url) + (code:comment "append or splicing is needed") + (append + (code:comment "Each element of the list is another list") + (apply append + (for/list ([p posts]) + `((h2 ,(post-title p)) + (p ,(post-body p)) + (ul + ,@(for/list ([c (post-comments p)]) + `(li ,c)))))) + `((h1 "New Post") + (form ([action ,k-url]) + (input ([name "title"])) + (input ([name "body"])) + (input ([type "submit"])))))) + +(define (display-posts) + (extract-post + (send/suspend + (lambda (k-url) + (template "Posts" (blog-posts k-url)))))) + +(define (start req) + (display-posts)) + +(serve/servlet start) +] + +Luckily, Alonzo has great software engineering skills, so he's already separated the presentation logic into the functions +@scheme[blog-posted], @scheme[blog-posts], and @scheme[template]. Each one of these will turn into a different +template. + +@filepath{blog.html}: +@verbatim[#:indent 2]|{ + + + Alonzo's Church: @|section| + + + + + + +

Alonzo's Church: @|section|

+
+ @body +
+ + +}| + +Notice that this part of the presentation is much simpler, because the CSS and JavaScript +can be included verbatim, without resorting to any special escape-escaping patterns. +Similarly, since the @scheme[body] is represented as a string, there is no need to +remember if splicing is necessary. + +@filepath{blog-posts.html}: +@verbatim[#:indent 2]|{ +@in[p posts]{ +

@(post-title p)

+

@(post-body p)

+
    + @in[c (post-comments p)]{ +
  • @|c|
    • + } +
+} + +

New Post

+ + + + + +}| + +This template is even simpler, because there is no list management whatsoever. The defaults "just work". +For completeness, we show the final template: + +@filepath{blog-posted.html}: +@verbatim[#:indent 2]|{ +

@|title|

+

@|body|

+ +

Continue

+}| + +The code associated with these templates is very simple as well: +@schememod[ + scheme +(require web-server/templates + web-server/servlet + web-server/servlet-env) + +(define-struct post (title body comments)) + +(define posts ...) + +(define (template section body) + (list TEXT/HTML-MIME-TYPE + (include-template "blog.html"))) + +(define (extract-post req) + (define binds + (request-bindings req)) + (define title + (extract-binding/single 'title binds)) + (define body + (extract-binding/single 'body binds)) + (set! posts + (list* (make-post title body empty) + posts)) + (send/suspend + (lambda (k-url) + (template "Posted" (include-template "blog-posted.html")))) + (display-posts)) + +(define (display-posts) + (extract-post + (send/suspend + (lambda (k-url) + (template "Posts" (include-template "blog-posts.html")))))) + +(define (start req) + (display-posts)) + +(serve/servlet start) +] \ No newline at end of file From 429e229ff7a3e02336fc49ae759e45c78429f376 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 21 Nov 2008 00:59:40 +0000 Subject: [PATCH 080/193] fixed a redrawing bug in the search bar svn: r12554 --- collects/framework/private/frame.ss | 4 ++-- collects/framework/private/text.ss | 8 +++++++- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index da655a13c2..0990485cdc 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1952,7 +1952,6 @@ (set! red? r?) (refresh))) (define/override (on-paint) - (super on-paint) (when red? (let ([dc (get-dc)]) (let-values ([(cw ch) (get-client-size)]) @@ -1962,7 +1961,8 @@ (send dc set-brush "pink" 'solid) (send dc draw-rectangle 0 0 cw ch) (send dc set-pen pen) - (send dc set-brush brush)))))) + (send dc set-brush brush))))) + (super on-paint)) (super-new))) (define-local-member-name diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index cce4a88ec9..e955212d88 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -857,7 +857,13 @@ WARNING: printf is rebound in the body of the unit to always normalize?))] [else (preferences:get 'framework:do-paste-normalization)])) - (define/public (string-normalize s) (string-normalize-nfkc s)) + (define/public (string-normalize s) + + (let ([ns (string-normalize-nfkc s)]) + (unless (equal? s ns) + (printf "normalized: ~s => ~s\n" s ns))) + + (string-normalize-nfkc s)) From d539020c42421a1b0f931079e8bbcd77f67978f5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 21 Nov 2008 01:00:36 +0000 Subject: [PATCH 081/193] oops, undoing mistake svn: r12555 --- collects/framework/private/text.ss | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index e955212d88..cce4a88ec9 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -857,13 +857,7 @@ WARNING: printf is rebound in the body of the unit to always normalize?))] [else (preferences:get 'framework:do-paste-normalization)])) - (define/public (string-normalize s) - - (let ([ns (string-normalize-nfkc s)]) - (unless (equal? s ns) - (printf "normalized: ~s => ~s\n" s ns))) - - (string-normalize-nfkc s)) + (define/public (string-normalize s) (string-normalize-nfkc s)) From cea8e15d2e855173f878551f08282bf77b48c1bd Mon Sep 17 00:00:00 2001 From: Greg Cooper Date: Fri, 21 Nov 2008 01:33:23 +0000 Subject: [PATCH 082/193] try to make the debug-button properly centered svn: r12556 --- collects/gui-debugger/debug-tool.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/gui-debugger/debug-tool.ss b/collects/gui-debugger/debug-tool.ss index 47a920e6b0..3efc59a2b9 100644 --- a/collects/gui-debugger/debug-tool.ss +++ b/collects/gui-debugger/debug-tool.ss @@ -1278,7 +1278,9 @@ (new switchable-button% (label (string-constant debug-tool-button-name)) (bitmap debug-bitmap) - (parent (make-object vertical-pane% (get-button-panel))) + (parent (new vertical-pane% + [parent (get-button-panel)] + [alignment '(center center)])) (callback (λ (button) (debug-callback))))) (inherit register-toolbar-button) (register-toolbar-button debug-button) From cacdcc55ac6054bebc8e616a61ad628f0e69eb73 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 21 Nov 2008 03:22:24 +0000 Subject: [PATCH 083/193] macro-debugger: fixed button alignment (PR 9932) svn: r12557 --- collects/macro-debugger/tool.ss | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index bd8ee29529..53cf67f2e9 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -99,7 +99,10 @@ get-definitions-text) (define macro-debug-panel - (new vertical-pane% (parent (get-button-panel)))) + (new horizontal-pane% + (parent (get-button-panel)) + (stretchable-height #f) + (stretchable-width #f))) (define macro-debug-button (new switchable-button% (label "Macro Stepper") From 370ec9b8e9fff394970c6c6bce681b7e07daa519 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 21 Nov 2008 08:27:14 +0000 Subject: [PATCH 084/193] show the client's ip in the apache-style log svn: r12558 --- collects/web-server/dispatchers/dispatch-log.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/dispatchers/dispatch-log.ss b/collects/web-server/dispatchers/dispatch-log.ss index adcd1ca585..6b32b72721 100644 --- a/collects/web-server/dispatchers/dispatch-log.ss +++ b/collects/web-server/dispatchers/dispatch-log.ss @@ -45,7 +45,7 @@ (define (apache-default-format req) (define request-time (srfi-date:current-date)) (format "~a - - [~a] \"~a\" ~a ~a~n" - (request-host-ip req) + (request-client-ip req) (srfi-date:date->string request-time "~d/~b/~Y:~T ~z") (request-line-raw req) 200 From 9bdd4603cf742b9b6ef860e39be75055b92bf013 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 21 Nov 2008 08:50:26 +0000 Subject: [PATCH 085/193] Welcome to a new PLT day. svn: r12559 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 925fa0040c..e3af7fca9e 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "20nov2008") +#lang scheme/base (provide stamp) (define stamp "21nov2008") From 344ef566045d6e7ef2ff00e0f893f42de474f3e6 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Fri, 21 Nov 2008 13:21:26 +0000 Subject: [PATCH 086/193] Changing coverage default svn: r12562 --- collects/profj/tool.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 88f34c72b3..0f436edd9c 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -506,7 +506,7 @@ ;default-settings: -> profj-settings (define/public (default-settings) (if (memq level `(beginner intermediate intermediate+access advanced)) - (make-profj-settings 'field #f #t #f #t #t null) + (make-profj-settings 'field #f #t #f #t #f null) (make-profj-settings 'type #f #t #t #f #f null))) ;default-settings? any -> bool (define/public (default-settings? s) (equal? s (default-settings))) From 937fd18b2a6b11ccb1b10ce6d47b7e3e87c225e4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 21 Nov 2008 13:49:10 +0000 Subject: [PATCH 087/193] change internal definition expansion, simplifying, fixing douplicate-id checking, and fixing binding resolution through extensible ribs svn: r12563 --- src/mzscheme/src/env.c | 25 +++++++- src/mzscheme/src/error.c | 2 +- src/mzscheme/src/eval.c | 26 ++++++-- src/mzscheme/src/module.c | 3 + src/mzscheme/src/schpriv.h | 2 + src/mzscheme/src/stxobj.c | 45 ++++++------- src/mzscheme/src/syntax.c | 126 +++++++++++++++++++++++-------------- 7 files changed, 152 insertions(+), 77 deletions(-) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 0e52f7223f..7c64c50239 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -2123,7 +2123,8 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env, } while (env != upto) { - if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))) { + if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME + | SCHEME_CAPTURE_LIFTED | SCHEME_INTDEF_SHADOW))) { int i, count; /* How many slots filled in the frame so far? This can change @@ -2311,6 +2312,26 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env, stx = scheme_add_rename(stx, l); } } + } else if (env->flags & SCHEME_INTDEF_SHADOW) { + /* Just extract existing uids from identifiers, and don't need to + add renames to syntax objects. */ + if (!env->uids) { + Scheme_Object **uids, *uid; + int i; + + uids = MALLOC_N(Scheme_Object *, env->num_bindings); + env->uids = uids; + + for (i = env->num_bindings; i--; ) { + uid = scheme_stx_moduleless_env(env->values[i]); + if (SCHEME_FALSEP(uid)) + scheme_signal_error("intdef shadow binding is #f for %d/%s", + SCHEME_TYPE(env->values[i]), + scheme_write_to_string(SCHEME_STX_VAL(env->values[i]), + NULL)); + env->uids[i] = uid; + } + } } env = env->next; @@ -2446,7 +2467,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, if (frame->values[i]) { if (frame->uids) uid = frame->uids[i]; - if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i])) + if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i])) && (scheme_stx_env_bound_eq(find_id, frame->values[i], uid, scheme_make_integer(phase)) || ((frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME) && scheme_stx_module_eq2(find_id, frame->values[i], scheme_make_integer(phase), find_id_sym)) diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 0fb36e3f88..bb4b052258 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -778,7 +778,7 @@ scheme_signal_error (const char *msg, ...) if (scheme_current_thread->current_local_env) { char *s2 = " [during expansion]"; strcpy(buffer + len, s2); - len = strlen(s2); + len += strlen(s2); } buffer[len] = 0; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 1aff3b6e8a..ad1973066c 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -4563,6 +4563,7 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, /* should be always NULL */ dest[i].observer = src[drec].observer; dest[i].pre_unwrapped = 0; + dest[i].env_already = 0; } } @@ -4581,6 +4582,7 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, dest[i].certs = src[drec].certs; dest[i].observer = src[drec].observer; dest[i].pre_unwrapped = 0; + dest[i].env_already = 0; } } @@ -4603,6 +4605,7 @@ void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec, lam[dlrec].certs = src[drec].certs; lam[dlrec].observer = src[drec].observer; lam[dlrec].pre_unwrapped = 0; + lam[dlrec].env_already = 0; } void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec, @@ -4850,6 +4853,7 @@ static void *compile_k(void) rec.certs = NULL; rec.observer = NULL; rec.pre_unwrapped = 0; + rec.env_already = 0; cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME); @@ -6289,7 +6293,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, if (!SCHEME_STX_SYMBOLP(var)) scheme_wrong_syntax(NULL, var, first, "name must be an identifier"); - scheme_dup_symbol_check(&r, "internal definition", var, "binding", first); + // scheme_dup_symbol_check(&r, "internal definition", var, "binding", first); vars = SCHEME_STX_CDR(vars); cnt++; } @@ -6359,6 +6363,16 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, scheme_set_local_syntax(cnt++, a, scheme_false, new_env); } + /* Extend shared rib with renamings */ + scheme_add_env_renames(rib, new_env, env); + + /* Check for duplicates after extending the rib with renamings, + since the renamings properly track marks. */ + for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + a = SCHEME_STX_CAR(l); + scheme_dup_symbol_check(&r, "internal definition", a, "binding", first); + } + if (!is_val) { /* Evaluate and bind syntaxes */ scheme_prepare_exp_env(new_env->genv); @@ -6371,9 +6385,6 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, &pos); } - /* Extend shared rib with renamings */ - scheme_add_env_renames(rib, new_env, env); - /* Remember extended environment */ SCHEME_PTR1_VAL(ctx) = new_env; env = new_env; @@ -6441,6 +6452,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, } if (!more) { + /* We've converted to a letrec or letrec-values+syntaxes */ + rec[drec].env_already = 1; + if (rec[drec].comp) { result = scheme_compile_expr(result, env, rec, drec); return scheme_make_pair(result, scheme_null); @@ -8720,6 +8734,7 @@ static void *expand_k(void) erec1.certs = certs; erec1.observer = observer; erec1.pre_unwrapped = 0; + erec1.env_already = 0; if (catch_lifts_key) scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key); @@ -9201,7 +9216,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in l = scheme_add_rename(l, renaming); if (for_expr) { - /* Package up expanded expr with the enviornment. */ + /* Package up expanded expr with the environment. */ while (1) { if (orig_env->flags & SCHEME_FOR_STOPS) orig_env = orig_env->next; @@ -9552,6 +9567,7 @@ local_eval(int argc, Scheme_Object **argv) rec.certs = certs; rec.observer = observer; rec.pre_unwrapped = 0; + rec.env_already = 0; /* Evaluate and bind syntaxes */ expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 360e0fa16c..77d3f168c4 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -5773,6 +5773,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, erec1.certs = rec[drec].certs; erec1.observer = rec[drec].observer; erec1.pre_unwrapped = 0; + erec1.env_already = 0; e = scheme_expand_expr(e, xenv, &erec1, 0); } @@ -5975,6 +5976,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, mrec.certs = rec[drec].certs; mrec.observer = NULL; mrec.pre_unwrapped = 0; + mrec.env_already = 0; if (!rec[drec].comp) { Scheme_Expand_Info erec1; @@ -5984,6 +5986,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, erec1.certs = rec[drec].certs; erec1.observer = rec[drec].observer; erec1.pre_unwrapped = 0; + erec1.env_already = 0; SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0); } diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 9ea3f36d3a..8cff95e5c6 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -1837,6 +1837,7 @@ typedef struct Scheme_Compile_Expand_Info char resolve_module_ids; char pre_unwrapped; int depth; + int env_already; } Scheme_Compile_Expand_Info; typedef Scheme_Compile_Expand_Info Scheme_Compile_Info; @@ -2301,6 +2302,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count); #define SCHEME_FOR_STOPS 128 #define SCHEME_FOR_INTDEF 256 #define SCHEME_CAPTURE_LIFTED 512 +#define SCHEME_INTDEF_SHADOW 1024 /* Flags used with scheme_static_distance */ #define SCHEME_ELIM_CONST 1 diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index a31ef7c2e1..e24d1a87dd 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -2982,12 +2982,14 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx) return scheme_false; } -XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, - Scheme_Object *barrier_env, Scheme_Object *ignore_rib) +XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env) /* Compares the marks in two wraps lists. A result of 2 means that the - result depended on a barrier env. Use #f for barrier_env - to treat no rib envs as barriers; we check for barrier_env only in ribs - because simpliciation eliminates the need for these checks(?). */ + result depended on a barrier env. For a rib-based renaming, we need + to check only up to the rib, and the barrier effect important for + when a rib-based renaming is layered with another renaming (such as + when an internal-definition-base local-expand is used to form a new + set of bindings, as in the unit form); simplification cleans up the + layers, so that we only need to check in ribs. */ { WRAP_POS awl; WRAP_POS bwl; @@ -3015,9 +3017,7 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, WRAP_POS_INC(awl); } } else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) { - if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(awl))) { - WRAP_POS_INC(awl); - } else if (SCHEME_FALSEP(barrier_env)) { + if (SCHEME_FALSEP(barrier_env)) { WRAP_POS_INC(awl); } else { /* See if the barrier environment is in this rib. */ @@ -3054,9 +3054,7 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, WRAP_POS_INC(bwl); } } else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) { - if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(bwl))) { - WRAP_POS_INC(bwl); - } else if (SCHEME_FALSEP(barrier_env)) { + if (SCHEME_FALSEP(barrier_env)) { WRAP_POS_INC(bwl); } else { /* See if the barrier environment is in this rib. */ @@ -3665,15 +3663,16 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, && !no_lexical)) { /* Lexical rename: */ Scheme_Object *rename, *renamed; - int ri, c, istart, iend, is_rib; + int ri, c, istart, iend; + Scheme_Lexical_Rib *is_rib; if (rib) { rename = rib->rename; + is_rib = rib; rib = rib->next; - is_rib = 1; } else { rename = WRAP_POS_FIRST(wraps); - is_rib = 0; + is_rib = NULL; } c = SCHEME_RENAME_LEN(rename); @@ -3735,7 +3734,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, { WRAP_POS w2; WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps); - same = same_marks(&w2, &wraps, other_env, WRAP_POS_FIRST(wraps)); + same = same_marks(&w2, &wraps, other_env); if (!same) EXPLAIN(printf("Different marks\n")); } @@ -3755,7 +3754,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, o_rename_stack = CONS(CONS(other_env, envname), o_rename_stack); } - rib = NULL; /* skip rest of rib (if any) */ + if (is_rib) { + /* skip rest of rib (if any) and future instances of the same rib */ + rib = NULL; + skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs); + } } break; @@ -4092,7 +4095,7 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u WRAP_POS bw; WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps); WRAP_POS_INIT(bw, ((Scheme_Stx *)b)->wraps); - if (!same_marks(&aw, &bw, ae, NULL)) + if (!same_marks(&aw, &bw, ae)) return 0; } @@ -4277,7 +4280,7 @@ Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *re WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps); WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps); - if (!same_marks(&aw, &bw, NULL, NULL)) { + if (!same_marks(&aw, &bw, scheme_false)) { Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps; if (uid) { /* Add a rename record: */ @@ -4647,7 +4650,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca /* Check marks (now that we have the correct barriers). */ WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); - if (!same_marks(&w2, &w, other_env, (Scheme_Object *)init_rib)) { + if (!same_marks(&w2, &w, other_env)) { other_env = NULL; } @@ -4699,7 +4702,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca } } else { WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); - if (same_marks(&w2, &w, scheme_false, (Scheme_Object *)init_rib)) + if (same_marks(&w2, &w, scheme_false)) ok = SCHEME_VEC_ELS(v)[0]; else ok = NULL; @@ -6759,7 +6762,7 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv) WRAP_POS_INIT(awl, stx->wraps); WRAP_POS_INIT_END(ewl); - if (same_marks(&awl, &ewl, scheme_false, NULL)) + if (same_marks(&awl, &ewl, scheme_false)) return scheme_true; else return scheme_false; diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index f3819089de..4a1e6a4546 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -4092,6 +4092,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, Scheme_Object *first = NULL; Scheme_Compiled_Let_Value *last = NULL, *lv; DupCheckRecord r; + int rec_env_already = rec[drec].env_already; i = scheme_stx_proper_list_length(form); if (i < 3) @@ -4160,8 +4161,14 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, names = MALLOC_N(Scheme_Object *, num_bindings); if (frame_already) frame = frame_already; - else - frame = scheme_new_compilation_frame(num_bindings, 0, origenv, rec[drec].certs); + else { + frame = scheme_new_compilation_frame(num_bindings, + (rec_env_already ? SCHEME_INTDEF_SHADOW : 0), + origenv, + rec[drec].certs); + if (rec_env_already) + frame_already = frame; + } env = frame; recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1)); @@ -4172,7 +4179,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, defname = scheme_check_name_property(form, defname); - if (!star) { + if (!star && !frame_already) { scheme_begin_dup_symbol_check(&r, env); } @@ -4216,7 +4223,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, names[k++] = name; } - if (!star) { + if (!star && !frame_already) { for (m = pre_k; m < k; m++) { scheme_dup_symbol_check(&r, NULL, names[m], "binding", form); } @@ -4319,6 +4326,7 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info Scheme_Comp_Env *use_env, *env; Scheme_Expand_Info erec1; DupCheckRecord r; + int rec_env_already = erec[drec].env_already; vars = SCHEME_STX_CDR(form); @@ -4385,8 +4393,8 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info } /* Note: no more letstar handling needed after this point */ - - scheme_begin_dup_symbol_check(&r, origenv); + if (!env_already && !rec_env_already) + scheme_begin_dup_symbol_check(&r, origenv); vlist = scheme_null; vs = vars; @@ -4405,15 +4413,18 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info { DupCheckRecord r2; Scheme_Object *names = name; - scheme_begin_dup_symbol_check(&r2, origenv); + if (!env_already && !rec_env_already) + scheme_begin_dup_symbol_check(&r2, origenv); while (SCHEME_STX_PAIRP(names)) { name = SCHEME_STX_CAR(names); scheme_check_identifier(NULL, name, NULL, origenv, form); vlist = cons(name, vlist); - scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form); - scheme_dup_symbol_check(&r, NULL, name, "binding", form); + if (!env_already && !rec_env_already) { + scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form); + scheme_dup_symbol_check(&r, NULL, name, "binding", form); + } names = SCHEME_STX_CDR(names); } @@ -4430,7 +4441,10 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info if (env_already) env = env_already; else - env = scheme_add_compilation_frame(vlist, origenv, 0, erec[drec].certs); + env = scheme_add_compilation_frame(vlist, + origenv, + (rec_env_already ? SCHEME_INTDEF_SHADOW : 0), + erec[drec].certs); if (letrec) use_env = env; @@ -5526,6 +5540,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, rec1.certs = rec[drec].certs; rec1.observer = NULL; rec1.pre_unwrapped = 0; + rec1.env_already = 0; if (for_stx) { names = defn_targets_syntax(names, exp_env, &rec1, 0); @@ -5717,6 +5732,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object mrec.certs = certs; mrec.observer = NULL; mrec.pre_unwrapped = 0; + mrec.env_already = 0; a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0); @@ -5805,9 +5821,11 @@ do_letrec_syntaxes(const char *where, Scheme_Object *form, *bindings, *var_bindings, *body, *v; Scheme_Object *names_to_disappear; Scheme_Comp_Env *stx_env, *var_env, *rhs_env; - int cnt, stx_cnt, var_cnt, i, j, depth, saw_var; + int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already; DupCheckRecord r; + env_already = rec[drec].env_already; + form = SCHEME_STX_CDR(forms); if (!SCHEME_STX_PAIRP(form)) scheme_wrong_syntax(NULL, NULL, forms, NULL); @@ -5823,7 +5841,10 @@ do_letrec_syntaxes(const char *where, scheme_rec_add_certs(rec, drec, forms); - stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs); + if (env_already) + stx_env = origenv; + else + stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs); rhs_env = stx_env; @@ -5846,8 +5867,8 @@ do_letrec_syntaxes(const char *where, else names_to_disappear = NULL; - - scheme_begin_dup_symbol_check(&r, stx_env); + if (!env_already) + scheme_begin_dup_symbol_check(&r, stx_env); /* Pass 1: Check and Rename */ @@ -5881,8 +5902,10 @@ do_letrec_syntaxes(const char *where, for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { a = SCHEME_STX_CAR(l); - scheme_check_identifier(where, a, NULL, stx_env, forms); - scheme_dup_symbol_check(&r, where, a, "binding", forms); + if (!env_already) { + scheme_check_identifier(where, a, NULL, stx_env, forms); + scheme_dup_symbol_check(&r, where, a, "binding", forms); + } cnt++; } if (i) @@ -5895,30 +5918,35 @@ do_letrec_syntaxes(const char *where, var_cnt = cnt - stx_cnt; } - scheme_add_local_syntax(stx_cnt, stx_env); - if (saw_var) - var_env = scheme_new_compilation_frame(var_cnt, 0, stx_env, rec[drec].certs); - else + if (!env_already) + scheme_add_local_syntax(stx_cnt, stx_env); + + if (saw_var) { + var_env = scheme_new_compilation_frame(var_cnt, + (env_already ? SCHEME_INTDEF_SHADOW : 0), + stx_env, + rec[drec].certs); + } else var_env = NULL; - for (i = 0; i < (var_env ? 2 : 1) ; i++) { + for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) { cnt = (i ? var_cnt : stx_cnt); if (cnt > 0) { - /* Add new syntax names to the environment: */ + /* Add new syntax/variable names to the environment: */ j = 0; for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *l; + Scheme_Object *a, *l; - a = SCHEME_STX_CAR(v); - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (i) { - /* In compile mode, this will get re-written by the letrec compiler. - But that's ok. We need it now for env_renames. */ - scheme_add_compilation_binding(j++, a, var_env); - } else - scheme_set_local_syntax(j++, a, NULL, stx_env); - } + a = SCHEME_STX_CAR(v); + for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + a = SCHEME_STX_CAR(l); + if (i) { + /* In compile mode, this will get re-written by the letrec compiler. + But that's ok. We need it now for env_renames. */ + scheme_add_compilation_binding(j++, a, var_env); + } else + scheme_set_local_syntax(j++, a, NULL, stx_env); + } } } } @@ -5949,29 +5977,31 @@ do_letrec_syntaxes(const char *where, scheme_prepare_exp_env(stx_env->genv); - i = 0; + if (!env_already) { + i = 0; - for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *names; + for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { + Scheme_Object *a, *names; - SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); + SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); - a = SCHEME_STX_CAR(v); - names = SCHEME_STX_CAR(a); - a = SCHEME_STX_CDR(a); - a = SCHEME_STX_CAR(a); + a = SCHEME_STX_CAR(v); + names = SCHEME_STX_CAR(a); + a = SCHEME_STX_CDR(a); + a = SCHEME_STX_CAR(a); - scheme_bind_syntaxes(where, names, a, - stx_env->genv->exp_env, - stx_env->insp, - rec, drec, - stx_env, rhs_env, - &i); + scheme_bind_syntaxes(where, names, a, + stx_env->genv->exp_env, + stx_env->insp, + rec, drec, + stx_env, rhs_env, + &i); + } } SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer); - if (names_to_disappear) { + if (!env_already && names_to_disappear) { /* Need to add renaming for disappeared bindings. If they originated for internal definitions, then we need both pre-renamed and renamed, since some might have been From 58f9e0251375bfb25a6d89d01d33248d096ad627 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 21 Nov 2008 13:52:20 +0000 Subject: [PATCH 088/193] fix (mostly) expand tests suite svn: r12564 --- collects/tests/mzscheme/expand.ss | 53 +++++++++++++++---------------- collects/tests/mzscheme/module.ss | 4 +++ collects/tests/mzscheme/syntax.ss | 2 ++ 3 files changed, 31 insertions(+), 28 deletions(-) diff --git a/collects/tests/mzscheme/expand.ss b/collects/tests/mzscheme/expand.ss index ef00b03c8e..2ccfd4ab7f 100644 --- a/collects/tests/mzscheme/expand.ss +++ b/collects/tests/mzscheme/expand.ss @@ -55,8 +55,8 @@ ;; really idempotent, on the structure. Assume that ;; the test case is broken, not expand. (define (ensure-good-test-case o1 o2) - (let ([d1 (syntax-object->datum o1)] - [d2 (syntax-object->datum o2)]) + (let ([d1 (syntax->datum o1)] + [d2 (syntax->datum o2)]) (unless (equal? d1 d2) (error 'compare-objs "bad test case: ~e ~e" d1 d2)))) @@ -64,19 +64,16 @@ (define (both? p? o1 o2) (and (p? o1) (p? o2))) (compare-expansion #''()) - (compare-expansion #'(#%datum . 1)) - (compare-expansion #'(#%datum . #t)) (compare-expansion #'(quote 1)) (compare-expansion #'(#%top . x)) (compare-expansion #'(if (#%top . a) (#%top . b) (#%top . c))) - (compare-expansion #'(if (#%top . a) (#%top . b))) - (compare-expansion #'(lambda () (#%top . x))) - (compare-expansion #'(lambda (x) x)) - (compare-expansion #'(lambda (x y z) x)) - (compare-expansion #'(lambda (x) x x x)) + (compare-expansion #'(#%plain-lambda () (#%top . x))) + (compare-expansion #'(#%plain-lambda (x) x)) + (compare-expansion #'(#%plain-lambda (x y z) x)) + (compare-expansion #'(#%plain-lambda (x) x x x)) (compare-expansion #'(case-lambda)) - (compare-expansion #'(case-lambda [() (#%datum . 1)])) - (compare-expansion #'(case-lambda [() (#%datum . 1)] [(x) x])) + (compare-expansion #'(case-lambda [() (quote 1)])) + (compare-expansion #'(case-lambda [() (quote 1)] [(x) x])) (compare-expansion #'(case-lambda [(x y) x])) (compare-expansion #'(define-values () (#%top . x))) (compare-expansion #'(define-values (x) (#%top . x))) @@ -84,37 +81,37 @@ (compare-expansion #'(define-syntaxes () (#%top . x))) (compare-expansion #'(define-syntaxes (s) (#%top . x))) (compare-expansion #'(define-syntaxes (s x y) (#%top . x))) - (compare-expansion #'(require mzscheme)) - (compare-expansion #'(require (lib "list.ss"))) - (compare-expansion #'(require (lib "list.ss") mzscheme)) - (compare-expansion #'(require-for-syntax mzscheme)) - (compare-expansion #'(require-for-syntax (lib "list.ss"))) - (compare-expansion #'(require-for-syntax (lib "list.ss") mzscheme)) + (compare-expansion #'(#%require mzscheme)) + (compare-expansion #'(#%require (lib "list.ss"))) + (compare-expansion #'(#%require (lib "list.ss") mzscheme)) + (compare-expansion #'(#%require (for-syntax mzscheme))) + (compare-expansion #'(#%require (for-syntax (lib "list.ss")))) + (compare-expansion #'(#%require (for-syntax (lib "list.ss") mzscheme))) (compare-expansion #'(begin)) (compare-expansion #'(begin (#%top . x))) - (compare-expansion #'(begin (#%top . x) (#%datum . 2))) + (compare-expansion #'(begin (#%top . x) (quote 2))) (compare-expansion #'(begin0 (#%top . x))) - (compare-expansion #'(begin0 (#%top . x) (#%datum . 2))) - (compare-expansion #'(begin0 (#%top . x) (#%datum . 2) (#%datum . 2))) + (compare-expansion #'(begin0 (#%top . x) (quote 2))) + (compare-expansion #'(begin0 (#%top . x) (quote 2) (quote 2))) (compare-expansion #'(let-values () (#%top . q))) (compare-expansion #'(let-values (((x y) (#%top . p))) (#%top . q))) - (compare-expansion #'(let-values (((x y) (#%top . p)) ((z) (#%datum . 12))) (#%top . q))) + (compare-expansion #'(let-values (((x y) (#%top . p)) ((z) (quote 12))) (#%top . q))) (compare-expansion #'(let-values (((x y) (#%top . p))) (#%top . q) (#%top . p))) (compare-expansion #'(letrec-values () (#%top . q))) (compare-expansion #'(letrec-values (((x y) (#%top . p))) (#%top . q))) - (compare-expansion #'(letrec-values (((x y) (#%top . p)) ((z) (#%datum . 12))) (#%top . q))) + (compare-expansion #'(letrec-values (((x y) (#%top . p)) ((z) (quote 12))) (#%top . q))) (compare-expansion #'(letrec-values (((x y) (#%top . p))) (#%top . q) (#%top . p))) (compare-expansion #'(set! x (#%top . y))) (compare-expansion #'(quote-syntax x)) (compare-expansion #'(with-continuation-mark (#%top . x) (#%top . x) (#%top . x))) - (compare-expansion #'(#%app (#%top . f))) - (compare-expansion #'(#%app (#%top . f) (#%datum . 1)))) + (compare-expansion #'(#%plain-app (#%top . f))) + (compare-expansion #'(#%plain-app (#%top . f) (quote 1)))) (define expand-test-use-toplevel? #f) -(define datum->top-level-syntax-object +(define datum->top-level-syntax (lambda (v) - (namespace-syntax-introduce (datum->syntax-object #f v)))) + (namespace-syntax-introduce (datum->syntax #f v)))) (define now-expanding (make-parameter #f)) @@ -139,13 +136,13 @@ (let ([x (if (or (compiled-expression? x) (and (syntax? x) (compiled-expression? (syntax-e x)))) x - (parameterize ([current-module-name-prefix #f] + (parameterize ([current-module-declare-name #f] [now-expanding expand-test-use-toplevel?]) (expand-syntax ((if expand-test-use-toplevel? expand-top-level-with-compile-time-evals expand-syntax) - ((if (syntax? x) values datum->top-level-syntax-object) x)))))]) + ((if (syntax? x) values datum->top-level-syntax) x)))))]) (set! mz-test-syntax-errors-allowed? #f) (orig x))))))) (lambda () diff --git a/collects/tests/mzscheme/module.ss b/collects/tests/mzscheme/module.ss index 3cd2d93fa2..e3550e034e 100644 --- a/collects/tests/mzscheme/module.ss +++ b/collects/tests/mzscheme/module.ss @@ -239,6 +239,8 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Test proper bindings for `#%module-begin' +(define expand-test-use-toplevel? #t) + (test (void) eval '(begin (module mod_beg2 mzscheme @@ -282,6 +284,8 @@ (module m 'mod_beg2 3))) +(define expand-test-use-toplevel? #f) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ([f1 "tmp1.ss"] diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index b3cf53c677..219256cefe 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -1156,9 +1156,11 @@ [(_) (+ 2 (abcdefg 9))] [(_ ?) 77])]) (abcdefg)))) +(define expand-test-use-toplevel? #t) (splicing-let-syntax ([abcdefg (syntax-rules () [(_) 8])]) (define hijklmn (abcdefg))) +(define expand-test-use-toplevel? #f) (test 8 'hijklmn hijklmn) (test 30 'local-hijklmn (let () (splicing-let-syntax ([abcdefg (syntax-rules () From 2480a1c4e8e94e623267ea0b332bb58a922ecd37 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 21 Nov 2008 14:01:32 +0000 Subject: [PATCH 089/193] extra int-def tests svn: r12565 --- collects/tests/mzscheme/macro.ss | 61 +++++++++++++++++++++++++++++++ collects/tests/units/test-unit.ss | 12 ++++++ 2 files changed, 73 insertions(+) diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss index c035e1ee6c..4080b105b7 100644 --- a/collects/tests/mzscheme/macro.ss +++ b/collects/tests/mzscheme/macro.ss @@ -339,4 +339,65 @@ ;; ---------------------------------------- +(require (only-in mzlib/etc begin-with-definitions)) + +(define-syntax (def stx) + (syntax-case stx () + [(_ id) + (with-syntax ([x:id (datum->syntax #'id 'x)]) + #'(begin + (define x:id 50) + (define-syntax id #'x:id)))])) +(define-syntax (look stx) + (syntax-case stx () + [(_ id) (syntax-local-value #'id)])) + +(test 50 'look + (let () + (def foo) + (look foo))) + +(test 50 'look + (begin-with-definitions + (def foo) + (look foo))) + +(test #t 'bwd-struct + (let () + (begin-with-definitions + (define-struct a (x y)) + (define-struct (b a) (z)) + (b? (make-b 1 2 3))))) + +(test 5 'intdef + (let () + (define-syntax foo + (syntax-rules () + [(_ id) (begin + (define x 5) + (define id x))])) + (foo x) + x)) + +(test 6 'intdef-values + (let () + (define-syntax foo + (syntax-rules () + [(_ id) (define-values (x id) + (values 6 (lambda () x)))])) + (foo x) + (x))) + +(test 75 'bwd + (begin-with-definitions + (define-syntax foo + (syntax-rules () + [(_ id) (begin + (define x 75) + (define id x))])) + (foo x) + x)) + +;; ---------------------------------------- + (report-errs) diff --git a/collects/tests/units/test-unit.ss b/collects/tests/units/test-unit.ss index 061e142937..e7cb92bc2c 100644 --- a/collects/tests/units/test-unit.ss +++ b/collects/tests/units/test-unit.ss @@ -1677,3 +1677,15 @@ (use-unit-badly1 u-a)) (test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a" (use-unit-badly2 sig^)) + +(test 12 + (let () + (define-signature s^ (x)) + (define-unit u@ + (import) + (export s^) + (define x 12)) + (define-values/invoke-unit u@ (import) (export s^)) + x)) + + From 115f34a1e722fd483d6eb649879f5bc250b2f7d8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 21 Nov 2008 16:08:24 +0000 Subject: [PATCH 090/193] Using .... svn: r12568 --- collects/web-server/scribblings/servlet-env.scrbl | 2 +- collects/web-server/scribblings/templates.scrbl | 2 +- collects/web-server/scribblings/web.scrbl | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 375ca2196a..c4c6fd557c 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -110,7 +110,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, "conf" "not-found.html"))] [#:mime-types-path mime-types-path path? - ...] + ....] [#:log-file log-file path? #f] [#:log-format log-format symbol? 'apache-default]) void]{ diff --git a/collects/web-server/scribblings/templates.scrbl b/collects/web-server/scribblings/templates.scrbl index f202eee7ad..f7f0f701e0 100644 --- a/collects/web-server/scribblings/templates.scrbl +++ b/collects/web-server/scribblings/templates.scrbl @@ -466,7 +466,7 @@ The code associated with these templates is very simple as well: (define-struct post (title body comments)) -(define posts ...) +(define posts ....) (define (template section body) (list TEXT/HTML-MIME-TYPE diff --git a/collects/web-server/scribblings/web.scrbl b/collects/web-server/scribblings/web.scrbl index 7b5358d893..d6509ffb52 100644 --- a/collects/web-server/scribblings/web.scrbl +++ b/collects/web-server/scribblings/web.scrbl @@ -128,7 +128,7 @@ functions of interest for the servlet developer. (lambda (req) `(html (head (title "Custom Expiration!"))))]) (send/suspend - ...)) + ....)) ] } From 65d3d41096ab5a642a369587a30b60cd15ef4d29 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 21 Nov 2008 16:15:39 +0000 Subject: [PATCH 091/193] Using begin/collect svn: r12569 --- collects/web-server/scribblings/templates.scrbl | 2 +- collects/web-server/templates.ss | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/web-server/scribblings/templates.scrbl b/collects/web-server/scribblings/templates.scrbl index f7f0f701e0..e04d3dbd06 100644 --- a/collects/web-server/scribblings/templates.scrbl +++ b/collects/web-server/scribblings/templates.scrbl @@ -268,7 +268,7 @@ the template to be unescaped, then create a @scheme[cdata] structure: Expands into @schemeblock[ (for/list ([x xs]) - (list e ...)) + (begin/text e ...)) ] Template Example: diff --git a/collects/web-server/templates.ss b/collects/web-server/templates.ss index 5ee1b8798f..7a7edb0cd9 100644 --- a/collects/web-server/templates.ss +++ b/collects/web-server/templates.ss @@ -25,7 +25,7 @@ (syntax-rules () [(_ x xs e ...) (for/list ([x xs]) - (list e ...))])) + (begin/text e ...))])) (provide include-template in) \ No newline at end of file From d2a98721741b9f5e7f57b8c96a3ebc144307012a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 21 Nov 2008 17:59:08 +0000 Subject: [PATCH 092/193] Using path-string? rather than path? in many places svn: r12570 --- collects/web-server/dispatchers/dispatch-files.ss | 2 +- .../web-server/dispatchers/dispatch-passwords.ss | 2 +- collects/web-server/dispatchers/filesystem-map.ss | 2 +- collects/web-server/http/response.ss | 2 +- collects/web-server/insta/insta.ss | 5 +---- collects/web-server/lang/file-box.ss | 2 +- collects/web-server/private/configure.ss | 2 +- collects/web-server/private/md5-store.ss | 2 +- collects/web-server/private/servlet.ss | 2 +- collects/web-server/private/util.ss | 8 ++++---- collects/web-server/scribblings/dispatchers.scrbl | 2 +- collects/web-server/scribblings/private.scrbl | 14 +++++++------- collects/web-server/scribblings/running.scrbl | 2 +- collects/web-server/scribblings/servlet-env.scrbl | 12 ++++++------ .../web-server/scribblings/servlet-setup.scrbl | 8 ++++---- .../web-server/scribblings/tutorial/continue.scrbl | 2 +- .../web-server/scribblings/web-config-unit.scrbl | 8 +++++--- collects/web-server/scribblings/writing.scrbl | 2 +- collects/web-server/servlet-env.ss | 10 +++++----- collects/web-server/servlet/setup.ss | 6 +++--- 20 files changed, 47 insertions(+), 48 deletions(-) diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index ce375617ab..f73631a9be 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -15,7 +15,7 @@ [read-range-header (-> (listof header?) (or/c (listof pair?) false/c))] [make (->* (#:url->path url->path/c) - (#:path->mime-type (path? . -> . bytes?) + (#:path->mime-type (path-string? . -> . bytes?) #:indices (listof path-string?)) dispatcher/c)]) diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index 6cda02c90c..e00c6df832 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/collects/web-server/dispatchers/dispatch-passwords.ss @@ -22,7 +22,7 @@ [make-basic-denied?/path (authorized?/c . -> . denied?/c)] [password-file->authorized? - (path? . -> . (values (-> void) + (path-string? . -> . (values (-> void) authorized?/c))]) (define interface-version 'v1) diff --git a/collects/web-server/dispatchers/filesystem-map.ss b/collects/web-server/dispatchers/filesystem-map.ss index 346733be88..7db88bcab2 100644 --- a/collects/web-server/dispatchers/filesystem-map.ss +++ b/collects/web-server/dispatchers/filesystem-map.ss @@ -8,7 +8,7 @@ (provide/contract [url->path/c contract?] - [make-url->path (path? . -> . url->path/c)] + [make-url->path (path-string? . -> . url->path/c)] [make-url->valid-path (url->path/c . -> . url->path/c)] [filter-url->path (regexp? url->path/c . -> . url->path/c)]) diff --git a/collects/web-server/http/response.ss b/collects/web-server/http/response.ss index 14f7e50d8b..e48de3f692 100644 --- a/collects/web-server/http/response.ss +++ b/collects/web-server/http/response.ss @@ -15,7 +15,7 @@ (provide/contract [rename ext:output-response output-response (connection? response? . -> . void)] [rename ext:output-response/method output-response/method (connection? response? symbol? . -> . void)] - [rename ext:output-file output-file (connection? path? symbol? bytes? (or/c pair? false/c) . -> . void)]) + [rename ext:output-file output-file (connection? path-string? symbol? bytes? (or/c pair? false/c) . -> . void)]) ;; Table 1. head responses: ; ------------------------------------------------------------------------------ diff --git a/collects/web-server/insta/insta.ss b/collects/web-server/insta/insta.ss index 13059eb40d..49ac1ca2cd 100644 --- a/collects/web-server/insta/insta.ss +++ b/collects/web-server/insta/insta.ss @@ -15,10 +15,7 @@ (provide/contract [static-files-path (path-string? . -> . void?)]) (define (static-files-path path) - (set! extra-files-path - (if (path? path) - path - (string->path path)))) + (set! extra-files-path path)) (provide/contract [no-web-browser (-> void)]) diff --git a/collects/web-server/lang/file-box.ss b/collects/web-server/lang/file-box.ss index 7b2eb7c058..6ec9c4841b 100644 --- a/collects/web-server/lang/file-box.ss +++ b/collects/web-server/lang/file-box.ss @@ -24,7 +24,7 @@ (provide/contract [file-box? (any/c . -> . boolean?)] - [file-box (path? serializable? . -> . file-box?)] + [file-box (path-string? serializable? . -> . file-box?)] [file-unbox (file-box? . -> . serializable?)] [file-box-set? (file-box? . -> . boolean?)] [file-box-set! (file-box? serializable? . -> . void)]) diff --git a/collects/web-server/private/configure.ss b/collects/web-server/private/configure.ss index 627adc0f5e..4a014ba06d 100644 --- a/collects/web-server/private/configure.ss +++ b/collects/web-server/private/configure.ss @@ -742,7 +742,7 @@ [copy-conf (lambda (from to) (let ([to-path (build-path-unless-absolute conf to)]) - ; more here - check existance of from path? + ; more here - check existance of from path (copy-file* (build-path from-conf from) to-path)))]) (copy-conf "passwords-refresh.html" (messages-passwords-refreshed messages)) (copy-conf "servlet-refresh.html" (messages-servlets-refreshed messages)) diff --git a/collects/web-server/private/md5-store.ss b/collects/web-server/private/md5-store.ss index c15a66ac92..b7381f062e 100644 --- a/collects/web-server/private/md5-store.ss +++ b/collects/web-server/private/md5-store.ss @@ -2,7 +2,7 @@ (require file/md5) (provide/contract - [md5-home (parameter/c path?)] + [md5-home (parameter/c path-string?)] [md5-store (bytes? . -> . bytes?)] [md5-lookup (bytes? . -> . bytes?)]) diff --git a/collects/web-server/private/servlet.ss b/collects/web-server/private/servlet.ss index 482f394fff..74946f8111 100644 --- a/collects/web-server/private/servlet.ss +++ b/collects/web-server/private/servlet.ss @@ -21,7 +21,7 @@ ([custodian custodian?] [namespace namespace?] [manager manager?] - [directory path?] + [directory path-string?] [handler (request? . -> . response?)])] [struct execution-context ([request request?])] diff --git a/collects/web-server/private/util.ss b/collects/web-server/private/util.ss index 0594e71877..8d03dcd060 100644 --- a/collects/web-server/private/util.ss +++ b/collects/web-server/private/util.ss @@ -7,7 +7,7 @@ xml/xml net/url) (define path-element? - (or/c string? path? (symbols 'up 'same))) + (or/c path-string? (symbols 'up 'same))) (define port-number? (between/c 1 65535)) @@ -16,13 +16,13 @@ [port-number? contract?] [pretty-print-invalid-xexpr (exn:invalid-xexpr? any/c . -> . void)] [url-replace-path (((listof path/param?) . -> . (listof path/param?)) url? . -> . url?)] - [explode-path* (path? . -> . (listof path-element?))] - [path-without-base (path? path? . -> . (listof path-element?))] + [explode-path* (path-string? . -> . (listof path-element?))] + [path-without-base (path-string? path-string? . -> . (listof path-element?))] [list-prefix? (list? list? . -> . boolean?)] [strip-prefix-ups ((listof path-element?) . -> . (listof path-element?))] [url-path->string ((listof path/param?) . -> . string?)] [network-error ((symbol? string?) (listof any/c) . ->* . (void))] - [directory-part (path? . -> . path?)] + [directory-part (path-string? . -> . path?)] [lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)] [exn->string ((or/c exn? any/c) . -> . string?)] [build-path-unless-absolute (path-string? path-string? . -> . path?)] diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index 1f7ffe3c0d..7c95ea93be 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -99,7 +99,7 @@ URLs to paths on the filesystem. The returned @scheme[path?] is the path on disk. The list is the list of path elements that correspond to the path of the URL.} -@defproc[(make-url->path (base path?)) +@defproc[(make-url->path (base path-string?)) url->path/c]{ The @scheme[url-path/c] returned by this procedure considers the root URL to be @scheme[base]. It ensures that @scheme[".."]s in the URL diff --git a/collects/web-server/scribblings/private.scrbl b/collects/web-server/scribblings/private.scrbl index 7e84ba30a8..aea6a5ef29 100644 --- a/collects/web-server/scribblings/private.scrbl +++ b/collects/web-server/scribblings/private.scrbl @@ -293,13 +293,13 @@ functions. @filepath{private/mime-types.ss} provides function for dealing with @filepath{mime.types} files. -@defproc[(read-mime-types [p path?]) +@defproc[(read-mime-types [p path-string?]) (hash-table/c symbol? bytes?)]{ Reads the @filepath{mime.types} file from @scheme[p] and constructs a hash table mapping extensions to MIME types. } -@defproc[(make-path->mime-type [p path?]) +@defproc[(make-path->mime-type [p path-string?]) (path? . -> . bytes?)]{ Uses a @scheme[read-mime-types] with @scheme[p] and constructs a function from paths to their MIME type. @@ -371,7 +371,7 @@ needs. They are provided by @filepath{private/util.ss}. @subsection{Contracts} @defthing[port-number? contract?]{Equivalent to @scheme[(between/c 1 65535)].} -@defthing[path-element? contract?]{Equivalent to @scheme[(or/c string? path? (symbols 'up 'same))].} +@defthing[path-element? contract?]{Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].} @subsection{Lists} @defproc[(list-prefix? [l list?] @@ -395,19 +395,19 @@ needs. They are provided by @filepath{private/util.ss}. } @subsection{Paths} -@defproc[(explode-path* [p path?]) +@defproc[(explode-path* [p path-string?]) (listof path-element?)]{ Like @scheme[normalize-path], but does not resolve symlinks. } -@defproc[(path-without-base [base path?] - [p path?]) +@defproc[(path-without-base [base path-string?] + [p path-string?]) (listof path-element?)]{ Returns, as a list, the portion of @scheme[p] after @scheme[base], assuming @scheme[base] is a prefix of @scheme[p]. } -@defproc[(directory-part [p path?]) +@defproc[(directory-part [p path-string?]) path?]{ Returns the directory part of @scheme[p], returning @scheme[(current-directory)] if it is relative. diff --git a/collects/web-server/scribblings/running.scrbl b/collects/web-server/scribblings/running.scrbl index 89c95c415b..89be17510a 100644 --- a/collects/web-server/scribblings/running.scrbl +++ b/collects/web-server/scribblings/running.scrbl @@ -43,7 +43,7 @@ The following API is provided to customize the server instance: @onscreen["Run"]. } -@defproc[(static-files-path [path path?]) void]{ +@defproc[(static-files-path [path path-string?]) void]{ This instructs the Web server to serve static files, such as stylesheet and images, from @scheme[path]. } diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index c4c6fd557c..f17a0f8794 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -98,10 +98,10 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, [#:stateless? stateless? boolean? #f] [#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))] [#:servlet-namespace servlet-namespace (listof module-path?) empty] - [#:server-root-path server-root-path path? default-server-root-path] - [#:extra-files-paths extra-files-paths (listof path?) (list (build-path server-root-path "htdocs"))] - [#:servlets-root servlets-root path? (build-path server-root-path "htdocs")] - [#:servlet-current-directory servlet-current-directory path? servlets-root] + [#:server-root-path server-root-path path-string? default-server-root-path] + [#:extra-files-paths extra-files-paths (listof path-string?) (list (build-path server-root-path "htdocs"))] + [#:servlets-root servlets-root path-string? (build-path server-root-path "htdocs")] + [#:servlet-current-directory servlet-current-directory path-string? servlets-root] [#:file-not-found-responder file-not-found-responder (request? . -> . response?) (gen-file-not-found-responder @@ -109,9 +109,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, server-root-path "conf" "not-found.html"))] - [#:mime-types-path mime-types-path path? + [#:mime-types-path mime-types-path path-string? ....] - [#:log-file log-file path? #f] + [#:log-file log-file (or/c false/c path-string?) #f] [#:log-format log-format symbol? 'apache-default]) void]{ This sets up and starts a fairly default server instance. diff --git a/collects/web-server/scribblings/servlet-setup.scrbl b/collects/web-server/scribblings/servlet-setup.scrbl index c227d33150..796042c500 100644 --- a/collects/web-server/scribblings/servlet-setup.scrbl +++ b/collects/web-server/scribblings/servlet-setup.scrbl @@ -12,21 +12,21 @@ This module is used internally to build and load servlets. It may be useful to those who are trying to extend the server. -@defproc[(make-v1.servlet [directory path?] +@defproc[(make-v1.servlet [directory path-string?] [timeout integer?] [start (request? . -> . response?)]) servlet?]{ Creates a version 1 servlet that uses @scheme[directory] as its current directory, a timeout manager with a @scheme[timeout] timeout, and @scheme[start] as the request handler. } -@defproc[(make-v2.servlet [directory path?] +@defproc[(make-v2.servlet [directory path-string?] [manager manager?] [start (request? . -> . response?)]) servlet?]{ Creates a version 2 servlet that uses @scheme[directory] as its current directory, a @scheme[manager] as the continuation manager, and @scheme[start] as the request handler. } -@defproc[(make-stateless.servlet [directory path?] +@defproc[(make-stateless.servlet [directory path-string?] [start (request? . -> . response?)]) servlet?]{ Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory and @scheme[start] as the request handler. @@ -62,7 +62,7 @@ Equivalent to @scheme[(path? . -> . servlet?)]. @defstruct[servlet ([custodian custodian?] [namespace namespace?] [manager manager?] - [directory path?] + [directory path-string?] [handler (request? . -> . response?)]) #:mutable]{ Instances of this structure hold the necessary parts of a servlet: diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index 789b0609ee..f8a0619234 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -615,7 +615,7 @@ To do this, we set aside a path to store these files, and then tell the web server where that directory is. The function @scheme[static-files-path], -@defthing[static-files-path (path? -> void)] +@defthing[static-files-path (path-string? -> void)] tells the web server to look in the given path when it receives a URL that looks like a static resource request. diff --git a/collects/web-server/scribblings/web-config-unit.scrbl b/collects/web-server/scribblings/web-config-unit.scrbl index 4aa33691df..72f96cd87a 100644 --- a/collects/web-server/scribblings/web-config-unit.scrbl +++ b/collects/web-server/scribblings/web-config-unit.scrbl @@ -58,7 +58,7 @@ Provides contains the following identifiers. @defmodule[web-server/web-config-unit]{ -@defproc[(configuration-table->web-config@ [path path?] +@defproc[(configuration-table->web-config@ [path path-string?] [#:port port (or/c false/c port-number?) #f] [#:listen-ip listen-ip (or/c false/c string?) #f] [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)]) @@ -68,10 +68,12 @@ Provides contains the following identifiers. } @defproc[(configuration-table-sexpr->web-config@ [sexpr list?] - [#:web-server-root web-server-root path? (directory-part default-configuration-table-path)] + [#:web-server-root web-server-root path-string? + (directory-part default-configuration-table-path)] [#:port port (or/c false/c port-number?) #f] [#:listen-ip listen-ip (or/c false/c string?) #f] - [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)]) + [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c + (make-make-servlet-namespace)]) (unit? web-config^)]{ Parses @scheme[sexpr] as a configuration-table and constructs a @scheme[web-config^] unit. } diff --git a/collects/web-server/scribblings/writing.scrbl b/collects/web-server/scribblings/writing.scrbl index 2f3de6e8ef..57baa51dc2 100644 --- a/collects/web-server/scribblings/writing.scrbl +++ b/collects/web-server/scribblings/writing.scrbl @@ -104,7 +104,7 @@ boxes in a safe way. @defproc[(file-box? [v any/c]) boolean?]{Checks if @scheme[v] is a file-box.} -@defproc[(file-box [p path?] +@defproc[(file-box [p path-string?] [v serializable?]) file-box?]{ Creates a file-box that is stored at @scheme[p], with the default diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 17166d313c..baf6eca6bc 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -52,15 +52,15 @@ #:ssl? boolean? #:manager manager? #:servlet-namespace (listof module-path?) - #:server-root-path path? + #:server-root-path path-string? #:stateless? boolean? - #:extra-files-paths (listof path?) - #:servlets-root path? + #:extra-files-paths (listof path-string?) + #:servlets-root path-string? #:file-not-found-responder (request? . -> . response?) - #:mime-types-path path? + #:mime-types-path path-string? #:servlet-path string? #:servlet-regexp regexp? - #:log-file (or/c false/c path?)) + #:log-file (or/c false/c path-string?)) . ->* . void)]) diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss index b3d85f1451..077cda3c00 100644 --- a/collects/web-server/servlet/setup.ss +++ b/collects/web-server/servlet/setup.ss @@ -97,9 +97,9 @@ servlet-module-specs lang-module-specs)) (provide/contract - [make-v1.servlet (path? integer? (request? . -> . response?) . -> . servlet?)] - [make-v2.servlet (path? manager? (request? . -> . response?) . -> . servlet?)] - [make-stateless.servlet (path? (request? . -> . response?) . -> . servlet?)] + [make-v1.servlet (path-string? integer? (request? . -> . response?) . -> . servlet?)] + [make-v2.servlet (path-string? manager? (request? . -> . response?) . -> . servlet?)] + [make-stateless.servlet (path-string? (request? . -> . response?) . -> . servlet?)] [default-module-specs (listof module-path?)]) (define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] From f485ad3e8ab94fdec394376381219c10023045fa Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 21 Nov 2008 18:13:34 +0000 Subject: [PATCH 093/193] Implementation note svn: r12571 --- collects/web-server/scribblings/private.scrbl | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/collects/web-server/scribblings/private.scrbl b/collects/web-server/scribblings/private.scrbl index aea6a5ef29..4140d285a0 100644 --- a/collects/web-server/scribblings/private.scrbl +++ b/collects/web-server/scribblings/private.scrbl @@ -181,6 +181,13 @@ provides the unit that actually implements a dispatching server. } +@subsection{Threads and Custodians} + +The dispatching server runs in a dedicated thread. Every time a connection is initiated, a new thread is started to handle it. +Connection threads are created inside a dedicated custodian that is a child of the server's custodian. When the server is used to +provide servlets, each servlet also receives a new custodian that is a child of the server's custodian @bold{not} the connection +custodian. + @; ------------------------------------------------------------ @section[#:tag "closure.ss"]{Serializable Closures} @(require (for-label web-server/private/closure) From 62a8873198de52132aec131212ed0f23b55b8aa9 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 22 Nov 2008 08:50:19 +0000 Subject: [PATCH 094/193] Welcome to a new PLT day. svn: r12572 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index e3af7fca9e..cc3e3c71d6 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "21nov2008") +#lang scheme/base (provide stamp) (define stamp "22nov2008") From ecb39eedee5cc1cefbe9dcddb318bd6a8402e389 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 23 Nov 2008 00:17:39 +0000 Subject: [PATCH 095/193] added make-regexp-tweaker (not used yet), and some code reorganization svn: r12573 --- collects/scheme/private/string.ss | 344 ++++++++++++++++-------------- 1 file changed, 183 insertions(+), 161 deletions(-) diff --git a/collects/scheme/private/string.ss b/collects/scheme/private/string.ss index d50236b433..2ec85b8de4 100644 --- a/collects/scheme/private/string.ss +++ b/collects/scheme/private/string.ss @@ -32,21 +32,7 @@ s))))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Regexp helpers - - (define (bstring-length s) - (if (bytes? s) (bytes-length s) (string-length s))) - - (define (bstring->regexp name pattern) - (cond [(regexp? pattern) pattern] - [(byte-regexp? pattern) pattern] - [(string? pattern) (regexp pattern)] - [(bytes? pattern) (byte-regexp pattern)] - [else (raise-type-error - name "regexp, byte regexp, string, or byte string" pattern)])) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Regexp helpers + ;; Regexp utilities (define regexp-quote-chars:s #rx"[][.*?+|(){}\\$^]") (define regexp-quote-chars:b #rx#"[][.*?+|(){}\\$^]") @@ -69,6 +55,33 @@ [else (raise-type-error 'regexp-replace-quote "string or byte string" s)])) + (define (make-regexp-tweaker tweaker) + (let ([t (make-weak-hasheq)]) + (lambda (rx) + (define-syntax-rule (->str x) (if (bytes? x) (bytes->string/utf-8 x) x)) + (define-syntax-rule (->bts x) (if (bytes? x) x (string->bytes/utf-8 x))) + (define-syntax-rule (tweak unwrap wrap convert) + (let ([tweaked (tweaker (unwrap rx))]) + ;; the tweaker is allowed to return a regexp + (if (or (regexp? tweaked) (byte-regexp? tweaked)) + tweaked + (wrap (convert tweaked))))) + (define (run-tweak) + (cond [(pregexp? rx) (tweak object-name pregexp ->str)] + [(regexp? rx) (tweak object-name regexp ->str)] + [(byte-pregexp? rx) (tweak object-name byte-pregexp ->bts)] + [(byte-regexp? rx) (tweak object-name byte-regexp ->bts)] + ;; allow getting a string, so if someone needs to go + ;; from a string to a regexp, there's no penalty + ;; because of the intermediate regexp being recreated + [(string? rx) (tweak (lambda (x) x) regexp ->str)] + [(bytes? rx) (tweak (lambda (x) x) byte-regexp ->bts)] + [else (raise-type-error 'regexp-tweaker + "regexp of any kind, string, or bytes" + rx)])) + (or (hash-ref t rx #f) + (let ([rx* (run-tweak)]) (hash-set! t rx rx*) rx*))))) + (define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f]) (unless (input-port? input-port) (raise-type-error 'regexp-try-match @@ -91,156 +104,164 @@ (and p (subbytes s (- (car p) drop) (- (cdr p) drop)))) (cdr m)))))))) - ;; Helper macro for the regexp functions below. - (define-syntax regexp-loop - (syntax-rules () - [(regexp-loop name loop start end rx string - success-choose failure-k - port-success-k port-success-choose port-failure-k - need-leftover? peek?) - (let ([len (cond [(string? string) (string-length string)] - [(bytes? string) (bytes-length string)] - [else #f])]) - (if peek? - (unless (input-port? string) - (raise-type-error 'name "input port" string)) - (unless (or len (input-port? string)) - (raise-type-error - 'name "string, byte string or input port" string))) - (unless (and (number? start) (exact? start) (integer? start) - (start . >= . 0)) - (raise-type-error 'name "non-negative exact integer" start)) - (unless (or (not end) - (and (number? end) (exact? end) (integer? end) - (end . >= . 0))) - (raise-type-error 'name "non-negative exact integer or false" end)) - (unless (or (input-port? string) (and len (start . <= . len))) - (raise-mismatch-error - 'name - (format "starting offset index out of range [0,~a]: " len) - start)) - (unless (or (not end) - (and (start . <= . end) - (or (input-port? string) - (and len (end . <= . len))))) - (raise-mismatch-error - 'name - (format "ending offset index out of range [~a,~a]: " start len) - end)) - (reverse - (let loop ([acc '()] [start start] [end end]) + ;; Helper macro for the regexp functions below, with some utilities. + (define (bstring-length s) + (if (bytes? s) (bytes-length s) (string-length s))) + (define (bstring->regexp name pattern) + (cond [(regexp? pattern) pattern] + [(byte-regexp? pattern) pattern] + [(string? pattern) (regexp pattern)] + [(bytes? pattern) (byte-regexp pattern)] + [else (raise-type-error + name "regexp, byte regexp, string, or byte string" pattern)])) + (define-syntax-rule (regexp-loop + name loop start end rx string + success-choose failure-k + port-success-k port-success-choose port-failure-k + need-leftover? peek?) + (let ([len (cond [(string? string) (string-length string)] + [(bytes? string) (bytes-length string)] + [else #f])]) + (if peek? + (unless (input-port? string) + (raise-type-error 'name "input port" string)) + (unless (or len (input-port? string)) + (raise-type-error + 'name "string, byte string or input port" string))) + (unless (and (number? start) (exact? start) (integer? start) + (start . >= . 0)) + (raise-type-error 'name "non-negative exact integer" start)) + (unless (or (not end) + (and (number? end) (exact? end) (integer? end) + (end . >= . 0))) + (raise-type-error 'name "non-negative exact integer or false" end)) + (unless (or (input-port? string) (and len (start . <= . len))) + (raise-mismatch-error + 'name + (format "starting offset index out of range [0,~a]: " len) + start)) + (unless (or (not end) + (and (start . <= . end) + (or (input-port? string) (and len (end . <= . len))))) + (raise-mismatch-error + 'name + (format "ending offset index out of range [~a,~a]: " start len) + end)) + (reverse + (let loop ([acc '()] [start start] [end end]) - (if (and port-success-choose (input-port? string)) + (if (and port-success-choose (input-port? string)) - ;; Input port match, get string - (let* ([_ (when (positive? start) - ;; Skip start chars: - (let ([s (make-bytes 4096)]) - (let loop ([n 0]) - (unless (= n start) - (let ([m (read-bytes-avail! - s string 0 (min (- start n) 4096))]) - (unless (eof-object? m) (loop (+ n m))))))))] - [discarded/leftovers (if need-leftover? #f 0)] - [spitout (if need-leftover? - (open-output-bytes) - (make-output-port - 'counter always-evt - (lambda (s start end flush? breakable?) - (let ([c (- end start)]) - (set! discarded/leftovers - (+ c discarded/leftovers)) - c)) - void))] - [end (and end (- end start))] - [m (regexp-match rx string 0 end spitout)] - ;; re-match if we get a zero-length match at the - ;; beginning - [m (if (and m ; we have a match - ;; and it's an empty one - (zero? (bstring-length (car m))) - ;; and it's at the beginning - (zero? (if need-leftover? - (file-position spitout) - discarded/leftovers)) - ;; and we still have stuff to match - (if end - (< 0 end) - (not (eof-object? (peek-byte string))))) - (regexp-match rx string 1 end spitout) - m)] - [m (and m (car m))] - [discarded/leftovers (if need-leftover? - (get-output-bytes spitout) - discarded/leftovers)] - [end (and end m - (- end (if need-leftover? - (bstring-length discarded/leftovers) - discarded/leftovers) - (bstring-length m)))]) - ;; drop matches that are both empty and at the end - (if (and m (or (< 0 (bstring-length m)) - (if end - (< 0 end) - (not (eof-object? (peek-byte string)))))) - (loop (cons (port-success-choose m discarded/leftovers) acc) - 0 end) - (port-failure-k acc discarded/leftovers))) + ;; Input port match, get string + (let* ([_ (when (positive? start) + ;; Skip start chars: + (let ([s (make-bytes 4096)]) + (let loop ([n 0]) + (unless (= n start) + (let ([m (read-bytes-avail! + s string 0 (min (- start n) 4096))]) + (unless (eof-object? m) (loop (+ n m))))))))] + [discarded/leftovers (if need-leftover? #f 0)] + [spitout (if need-leftover? + (open-output-bytes) + (make-output-port + 'counter always-evt + (lambda (s start end flush? breakable?) + (let ([c (- end start)]) + (set! discarded/leftovers + (+ c discarded/leftovers)) + c)) + void))] + [end (and end (- end start))] + [m (regexp-match rx string 0 end spitout)] + ;; re-match if we get a zero-length match at the + ;; beginning + [m (if (and m ; we have a match + ;; and it's an empty one + (zero? (bstring-length (car m))) + ;; and it's at the beginning + (zero? (if need-leftover? + (file-position spitout) + discarded/leftovers)) + ;; and we still have stuff to match + (if end + (< 0 end) + (not (eof-object? (peek-byte string))))) + (regexp-match rx string 1 end spitout) + m)] + [m (and m (car m))] + [discarded/leftovers (if need-leftover? + (get-output-bytes spitout) + discarded/leftovers)] + [end (and end m + (- end (if need-leftover? + (bstring-length discarded/leftovers) + discarded/leftovers) + (bstring-length m)))]) + ;; drop matches that are both empty and at the end + (if (and m (or (< 0 (bstring-length m)) + (if end + (< 0 end) + (not (eof-object? (peek-byte string)))))) + (loop (cons (port-success-choose m discarded/leftovers) acc) + 0 end) + (port-failure-k acc discarded/leftovers))) - ;; String/port match, get positions - (let* ([match (if peek? - regexp-match-peek-positions - regexp-match-positions)] - [m (match rx string start end)]) - (if (not m) - (failure-k acc start end) - (let* ([mstart (caar m)] - [mend (cdar m)] - ;; re-match if we get a zero-length match at the - ;; beginning, and we can continue - [m (if (and (= mstart mend start) - (cond - [end (< start end)] - [len (< start len)] - [(input-port? string) - (not (eof-object? (peek-byte string)))] - [else (error "internal error (str)")])) - (if (or peek? (not (input-port? string))) - (match rx string (add1 start) end) - ;; rematching on a port requires adding `start' - ;; offsets - (let ([m (match rx string 1 end)]) - (if (and m (positive? start)) - (list (cons (+ start (caar m)) - (+ start (cdar m)))) - m))) - m)]) - ;; fail if rematch failed - (if (not m) - (failure-k acc start end) - (let ([mstart (caar m)] - [mend (cdar m)]) - ;; or if we have a zero-length match at the end - (if (and (= mstart mend) - (cond [end (= mend end)] - [len (= mend len)] - [(input-port? string) - (eof-object? - (peek-byte string (if peek? mend 0)))] - [else (error "internal error (str)")])) - (failure-k acc start end) - (if port-success-k - (port-success-k - (lambda (acc new-start new-end) - (loop acc new-start new-end)) - acc start end mstart mend) - (loop (cons (success-choose start mstart mend) acc) - mend end))))))))))))])) + ;; String/port match, get positions + (let* ([match (if peek? + regexp-match-peek-positions + regexp-match-positions)] + [m (match rx string start end)]) + (if (not m) + (failure-k acc start end) + (let* ([mstart (caar m)] + [mend (cdar m)] + ;; re-match if we get a zero-length match at the + ;; beginning, and we can continue + [m (if (and (= mstart mend start) + (cond + [end (< start end)] + [len (< start len)] + [(input-port? string) + (not (eof-object? (peek-byte string)))] + [else (error "internal error (str)")])) + (if (or peek? (not (input-port? string))) + (match rx string (add1 start) end) + ;; rematching on a port requires adding `start' + ;; offsets + (let ([m (match rx string 1 end)]) + (if (and m (positive? start)) + (list (cons (+ start (caar m)) + (+ start (cdar m)))) + m))) + m)]) + ;; fail if rematch failed + (if (not m) + (failure-k acc start end) + (let ([mstart (caar m)] + [mend (cdar m)]) + ;; or if we have a zero-length match at the end + (if (and (= mstart mend) + (cond [end (= mend end)] + [len (= mend len)] + [(input-port? string) + (eof-object? + (peek-byte string (if peek? mend 0)))] + [else (error "internal error (str)")])) + (failure-k acc start end) + (if port-success-k + (port-success-k + (lambda (acc new-start new-end) + (loop acc new-start new-end)) + acc start end mstart mend) + (loop (cons (success-choose start mstart mend) acc) + mend end))))))))))))) ;; Returns all the positions at which the pattern matched. (define (regexp-match-positions* pattern string [start 0] [end #f]) - (define rx (bstring->regexp 'regexp-match-positions* pattern)) - (regexp-loop regexp-match-positions* loop start end rx string + (regexp-loop + regexp-match-positions* loop start end + (bstring->regexp 'regexp-match-positions* pattern) string ;; success-choose: (lambda (start mstart mend) (cons mstart mend)) ;; failure-k: @@ -262,8 +283,9 @@ ;; Returns all the positions at which the pattern matched. (define (regexp-match-peek-positions* pattern string [start 0] [end #f]) - (define rx (bstring->regexp 'regexp-match-peek-positions* pattern)) - (regexp-loop regexp-match-peek-positions* loop start end rx string + (regexp-loop + regexp-match-peek-positions* loop start end + (bstring->regexp 'regexp-match-peek-positions* pattern) string ;; success-choose: (lambda (start mstart mend) (cons mstart mend)) ;; failure-k: From 70e85a62a94c8da6c822893d37cb86944499c67b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 23 Nov 2008 02:39:36 +0000 Subject: [PATCH 096/193] svn: r12574 --- collects/scribblings/tools/tools.scrbl | 28 ++++++++++++-------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index 476870f32b..cda543796f 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -165,21 +165,19 @@ setup/infotab ] then the same collection would be expected to contain a @File{tool.ss} file. It might contain something like this: -@schemeblock[ -(module tool mzscheme - (require (lib "tool.ss" "drscheme") - mred - mzlib/unit) - - (provide tool@) - - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - (define (phase1) (message-box "tool example" "phase1")) - (define (phase2) (message-box "tool example" "phase2")) - (message-box "tool example" "unit invoked")))) +@schememod[ +scheme/gui +(require drscheme/tool) + +(provide tool@) + +(define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + (define (phase1) (message-box "tool example" "phase1")) + (define (phase2) (message-box "tool example" "phase2")) + (message-box "tool example" "unit invoked"))) ] This tool just opens a few windows to indicate that it has been loaded and that the @scheme[phase1] and @scheme[phase2] From 5b9f0aa322b54aa6d6c7b6a00cde3967b925b534 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 23 Nov 2008 05:40:54 +0000 Subject: [PATCH 097/193] Implemented a `no-empty-edge-matches' function using the new `make-regexp-tweaker', which produces a regexp that cannot match an empty string at the beginning or the end of the input. This: * simplies a whole bunch of messy and fragile code * makes `regexp-split' and friends usable with a pattern like #px"\\b" (which previously would match in every position, making it explode the string to 1-character strings) * makes it even closer to what perl does, the only way that we produce a different result from perl now is that we don't blindly drop empty matches at the end like perl (it *does* keep empty matches in the beginning though) The two tests that demonstrated the difference are now changed, and a bunch of other tests added. svn: r12575 --- collects/scheme/private/string.ss | 108 ++++++++---------------------- collects/tests/mzscheme/string.ss | 73 ++++++++++---------- 2 files changed, 67 insertions(+), 114 deletions(-) diff --git a/collects/scheme/private/string.ss b/collects/scheme/private/string.ss index 2ec85b8de4..51cad2399d 100644 --- a/collects/scheme/private/string.ss +++ b/collects/scheme/private/string.ss @@ -76,9 +76,10 @@ ;; because of the intermediate regexp being recreated [(string? rx) (tweak (lambda (x) x) regexp ->str)] [(bytes? rx) (tweak (lambda (x) x) byte-regexp ->bts)] - [else (raise-type-error 'regexp-tweaker - "regexp of any kind, string, or bytes" - rx)])) + [else (raise-type-error + 'regexp-tweaker + "regexp, byte regexp, string, or byte string" + rx)])) (or (hash-ref t rx #f) (let ([rx* (run-tweak)]) (hash-set! t rx rx*) rx*))))) @@ -107,13 +108,14 @@ ;; Helper macro for the regexp functions below, with some utilities. (define (bstring-length s) (if (bytes? s) (bytes-length s) (string-length s))) - (define (bstring->regexp name pattern) - (cond [(regexp? pattern) pattern] - [(byte-regexp? pattern) pattern] - [(string? pattern) (regexp pattern)] - [(bytes? pattern) (byte-regexp pattern)] - [else (raise-type-error - name "regexp, byte regexp, string, or byte string" pattern)])) + (define no-empty-edge-matches + (make-regexp-tweaker (lambda (rx) (format "(?=.)(?:~a)(?<=.)" rx)))) + (define (bstring->no-edge-regexp name pattern) + (if (or (regexp? pattern) (byte-regexp? pattern) + (string? pattern) (bytes? pattern)) + (no-empty-edge-matches pattern) + (raise-type-error + name "regexp, byte regexp, string, or byte string" pattern))) (define-syntax-rule (regexp-loop name loop start end rx string success-choose failure-k @@ -174,21 +176,6 @@ void))] [end (and end (- end start))] [m (regexp-match rx string 0 end spitout)] - ;; re-match if we get a zero-length match at the - ;; beginning - [m (if (and m ; we have a match - ;; and it's an empty one - (zero? (bstring-length (car m))) - ;; and it's at the beginning - (zero? (if need-leftover? - (file-position spitout) - discarded/leftovers)) - ;; and we still have stuff to match - (if end - (< 0 end) - (not (eof-object? (peek-byte string))))) - (regexp-match rx string 1 end spitout) - m)] [m (and m (car m))] [discarded/leftovers (if need-leftover? (get-output-bytes spitout) @@ -198,70 +185,31 @@ (bstring-length discarded/leftovers) discarded/leftovers) (bstring-length m)))]) - ;; drop matches that are both empty and at the end - (if (and m (or (< 0 (bstring-length m)) - (if end - (< 0 end) - (not (eof-object? (peek-byte string)))))) + (if m (loop (cons (port-success-choose m discarded/leftovers) acc) 0 end) (port-failure-k acc discarded/leftovers))) ;; String/port match, get positions - (let* ([match (if peek? - regexp-match-peek-positions - regexp-match-positions)] - [m (match rx string start end)]) + (let ([m (if peek? + (regexp-match-peek-positions rx string start end) + (regexp-match-positions rx string start end))]) (if (not m) (failure-k acc start end) - (let* ([mstart (caar m)] - [mend (cdar m)] - ;; re-match if we get a zero-length match at the - ;; beginning, and we can continue - [m (if (and (= mstart mend start) - (cond - [end (< start end)] - [len (< start len)] - [(input-port? string) - (not (eof-object? (peek-byte string)))] - [else (error "internal error (str)")])) - (if (or peek? (not (input-port? string))) - (match rx string (add1 start) end) - ;; rematching on a port requires adding `start' - ;; offsets - (let ([m (match rx string 1 end)]) - (if (and m (positive? start)) - (list (cons (+ start (caar m)) - (+ start (cdar m)))) - m))) - m)]) - ;; fail if rematch failed - (if (not m) - (failure-k acc start end) - (let ([mstart (caar m)] - [mend (cdar m)]) - ;; or if we have a zero-length match at the end - (if (and (= mstart mend) - (cond [end (= mend end)] - [len (= mend len)] - [(input-port? string) - (eof-object? - (peek-byte string (if peek? mend 0)))] - [else (error "internal error (str)")])) - (failure-k acc start end) - (if port-success-k - (port-success-k - (lambda (acc new-start new-end) - (loop acc new-start new-end)) - acc start end mstart mend) - (loop (cons (success-choose start mstart mend) acc) - mend end))))))))))))) + (let ([mstart (caar m)] [mend (cdar m)]) + (if port-success-k + (port-success-k + (lambda (acc new-start new-end) + (loop acc new-start new-end)) + acc start end mstart mend) + (loop (cons (success-choose start mstart mend) acc) + mend end)))))))))) ;; Returns all the positions at which the pattern matched. (define (regexp-match-positions* pattern string [start 0] [end #f]) (regexp-loop regexp-match-positions* loop start end - (bstring->regexp 'regexp-match-positions* pattern) string + (bstring->no-edge-regexp 'regexp-match-positions* pattern) string ;; success-choose: (lambda (start mstart mend) (cons mstart mend)) ;; failure-k: @@ -285,7 +233,7 @@ (define (regexp-match-peek-positions* pattern string [start 0] [end #f]) (regexp-loop regexp-match-peek-positions* loop start end - (bstring->regexp 'regexp-match-peek-positions* pattern) string + (bstring->no-edge-regexp 'regexp-match-peek-positions* pattern) string ;; success-choose: (lambda (start mstart mend) (cons mstart mend)) ;; failure-k: @@ -300,7 +248,7 @@ ;; Splits a string into a list by removing any piece which matches ;; the pattern. (define (regexp-split pattern string [start 0] [end #f]) - (define rx (bstring->regexp 'regexp-split pattern)) + (define rx (bstring->no-edge-regexp 'regexp-split pattern)) (define buf (if (and (string? string) (byte-regexp? rx)) (string->bytes/utf-8 string (char->integer #\?)) string)) @@ -322,7 +270,7 @@ ;; Returns all the matches for the pattern in the string. (define (regexp-match* pattern string [start 0] [end #f]) - (define rx (bstring->regexp 'regexp-match* pattern)) + (define rx (bstring->no-edge-regexp 'regexp-match* pattern)) (define buf (if (and (string? string) (byte-regexp? rx)) (string->bytes/utf-8 string (char->integer #\?)) string)) diff --git a/collects/tests/mzscheme/string.ss b/collects/tests/mzscheme/string.ss index 55f00ed806..8f4314bbac 100644 --- a/collects/tests/mzscheme/string.ss +++ b/collects/tests/mzscheme/string.ss @@ -39,6 +39,7 @@ (define (->b x) (cond [(list? x) (map ->b x)] [(string? x) (string->bytes/utf-8 x)] + [(pregexp? x) (byte-pregexp (->b (object-name x)))] [else x])) (define fun* #f) (define t @@ -126,8 +127,8 @@ (t '((0 . 1) (2 . 3) (4 . 5)) "a b c" "[abc]" "a b c" 0 #f) (t '((0 . 1) (2 . 3) (4 . 5)) "a b c" "[abc]" "a b c" 0 5) ;; ---------- tests with zero-length matches ---------- - ;; Many of these tests can be repeated with Perl. To try something - ;; in Perl, put this code in a file: + ;; Many of these tests can be repeated with Perl. To try something in Perl, + ;; put this code in a file: ;; #!/usr/bin/perl ;; sub test { ;; my ($rx,$str) = @_; @words = split /$rx/, $str; @@ -136,15 +137,16 @@ ;; print ") eof \"$rx\" \"$str\")\n"; ;; }; ;; test("[abc]","1a2b3"); - ;; and it will print a test that does what perl is doing. Tests - ;; that differ from Perl have explanations. + ;; and it will print a test that does what perl is doing. Tests that differ + ;; from Perl have explanations. ;; (t regexp-split) ;; test("a","a"); ;; (t '() eof "a" "a") - ;; perl returns an empty list, we return '("" ""), and this is a - ;; difference that is unrelated to dealing with empty matches, - ;; just the way that perl's split throws out some empty matches. + ;; perl returns an empty list, we return '("" ""), and this is a difference + ;; that is unrelated to dealing with empty matches, just the way that + ;; perl's split throws out some empty matches (it throws empty matches at + ;; the end (but not at the beginning for some reason...)) (t '("" "") eof "a" "a") ;; test("3","123"); ;; (t '("12") eof "3" "123") @@ -162,49 +164,51 @@ (t '("1" "2" "3" "4") eof " *" "12 34") ;; test(" *"," 12 34 "); ;; (t '("" "1" "2" "3" "4") eof " *" " 12 34 ") - ;; perl drops the last empty string, we don't -- unrelated to - ;; empty matches (same as the <"a","a"> case above) + ;; again, perl drops the last empty string but we don't (t '("" "1" "2" "3" "4" "") eof " *" " 12 34 ") ;; test("2|", "1234"); (t '("1" "3" "4") eof "2|" "1234") ;; test("1|", "1234"); (t '("" "2" "3" "4") eof "1|" "1234") ;; test("4|", "1234"); - ;; perl drops the last empty string, we don't, same as above + ;; (t '("1" "2" "3") eof "4|" "1234") + ;; perl perl drops the last empty string again (t '("1" "2" "3" "") eof "4|" "1234") ;; test("|2", "1234"); - ;; (t '("1" "" "3" "4") eof "|2" "1234") - ;; perl will find the "2", we can't do that since we'll always - ;; find the empty match first, so it's just like using "" (to do - ;; the perl thing, we'll need a hook into the matcher's C code, or - ;; some way of saying `match this pattern but prefer a non-empty - ;; match if possible') - (t '("1" "2" "3" "4") eof "|2" "1234") + (t '("1" "" "3" "4") eof "|2" "1234") ;; test("2|3", "1234"); (t '("1" "" "4") eof "2|3" "1234") + ;; test("2|3|4", "12345"); + (t '("1" "" "" "5") eof "2|3|4" "12345") ;; test("1|2", "1234"); (t '("" "" "34") eof "1|2" "1234") ;; test("3|4", "1234"); ;; (t '("12") eof "3|4" "1234") - ;; again, perl dumps empty matches at the end, even two + ;; perl perl drops the last empty string again -- even two here (t '("12" "" "") eof "3|4" "1234") + ;; test("2|3|4", "1234"); + ;; (t '("1") eof "2|3|4" "1234") + ;; ...and even three in this example + (t '("1" "" "" "") eof "2|3|4" "1234") ;; test('$',"123"); (t '("123") eof "$" "123") ;; test('^',"123"); ;; (t '("123") eof "^" "123") - ;; this is a technicality: perl matches "^" once, but mzscheme - ;; matches on whatever `start' may be; perl is treating it as a - ;; beginning-of-line instead of a ...-of-string behind your back - ;; "since it isn't much use otherwise" - ;; (http://perldoc.perl.org/functions/split.html); so our correct - ;; test is: - (t '("1" "2" "3") eof "^" "123") - ;; and we can get the same with "(m?:^)": - (t '("123") eof "(m?:^)" "123") + ;; this is a technicality: perl matches "^" once, but mzscheme matches on + ;; whatever `start' may be; perl is treating it as a beginning-of-line + ;; instead of a beginning-of-string behind your back "since it isn't much + ;; use otherwise" (http://perldoc.perl.org/functions/split.html); but we + ;; don't allow empty matches at the beginning, so a `^' will never match, + ;; and we get the same behavior anyway: + (t '("123") eof "^" "123") + ;; test('^',"123\n456"); + ;; (t '("123\n" "456") eof "^" "123\n456") + ;; we can get the same behavior as perl's with "(m?:^)": + (t '("123\n" "456") eof "(?m:^)" "123\n456") + ;; test("\\b", "123 456"); + (t '("123" " " "456") eof #px"\\b" "123 456") ;; test("^|a", "abc"); - ;; (t '("" "bc") eof "^|a" "abc") - ;; same deal here, use "(m?:^)": - (t '("" "bc") eof "(m?:^|a)" "abc") + (t '("" "bc") eof "^|a" "abc") ;; some tests with bounds (these have no perl equivalences) (t '("1" "2" " " "3" "4") eof "" "12 34" 0) (t '("1" "2" " " "3" "4") eof "" "12 34" 0 #f) @@ -244,12 +248,13 @@ (apply (if (string? (car s)) string-append bytes-append) (car s) (append-map list m (cdr s))))))) - (t "12 34" #f " " "12 34") + (t "12 34" #f " " "12 34") (t " 12 34 " #f " " " 12 34 ") - (t "12 34" #f " *" "12 34") + (t "12 34" #f " *" "12 34") (t " 12 34 " #f " *" " 12 34 ") - (t "12 34" #f "" "12 34") - (t " 12 34 " #f "" " 12 34 ")) + (t "12 34" #f "" "12 34") + (t " 12 34 " #f "" " 12 34 ") + ) ;; ---------- string-append* ---------- (let () From a15933979a86eeb69340cf782ced2e6611026d3c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 23 Nov 2008 08:50:10 +0000 Subject: [PATCH 098/193] Welcome to a new PLT day. svn: r12576 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index cc3e3c71d6..a8afd5fec9 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "22nov2008") +#lang scheme/base (provide stamp) (define stamp "23nov2008") From a9e05befe2b57c287beb4a8ca1359a923af9af97 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 24 Nov 2008 08:50:14 +0000 Subject: [PATCH 099/193] Welcome to a new PLT day. svn: r12577 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index a8afd5fec9..537431549d 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "23nov2008") +#lang scheme/base (provide stamp) (define stamp "24nov2008") From a0f91d905e78288ac9ee252f24e8157f5cbea3f9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 24 Nov 2008 19:52:41 +0000 Subject: [PATCH 100/193] revised internal-definitions context and a basic 'define-package' form svn: r12579 --- collects/honu/main.ss | 62 +- collects/mzlib/etc.ss | 1 + collects/mzlib/private/sigutil.ss | 1 + collects/mzlib/private/unit-compiletime.ss | 65 +- collects/mzlib/unit.ss | 2 + collects/mzlib/unit200.ss | 3 + collects/r5rs/main.ss | 1 + collects/scheme/package.ss | 252 +++++++ collects/scheme/private/class-internal.ss | 2 + collects/scheme/splicing.ss | 1 + .../scribblings/reference/stx-trans.scrbl | 121 +++- .../scribblings/reference/syntax-model.scrbl | 5 +- collects/tests/mzscheme/macro.ss | 34 +- collects/tests/units/test-unit.ss | 22 +- doc/release-notes/mzscheme/HISTORY.txt | 9 + src/mzscheme/src/cstartup.inc | 394 +++++------ src/mzscheme/src/env.c | 181 ++++- src/mzscheme/src/eval.c | 8 + src/mzscheme/src/mzmark.c | 4 + src/mzscheme/src/mzmarksrc.c | 2 + src/mzscheme/src/schminc.h | 2 +- src/mzscheme/src/schpriv.h | 5 + src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/stxobj.c | 629 +++++++++++++----- src/mzscheme/src/type.c | 2 +- 25 files changed, 1339 insertions(+), 473 deletions(-) create mode 100644 collects/scheme/package.ss diff --git a/collects/honu/main.ss b/collects/honu/main.ss index e410ba8448..e3d65b245e 100644 --- a/collects/honu/main.ss +++ b/collects/honu/main.ss @@ -1295,36 +1295,38 @@ [exprs (let ([def-ctx (syntax-local-make-definition-context)] [ctx (generate-expand-context)]) - (let loop ([exprs (cddddr (cdr (syntax->list stx)))]) - (apply - append - (map (lambda (expr) - (let ([expr (local-expand - expr - ctx - block-expand-stop-forms - def-ctx)]) - (syntax-case expr (begin define-values define-syntaxes) - [(begin . rest) - (loop (syntax->list #'rest))] - [(define-syntaxes (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (with-syntax ([rhs (local-transformer-expand - #'rhs - 'expression - null)]) - (syntax-local-bind-syntaxes - (syntax->list #'(id ...)) - #'rhs def-ctx) - (list #'(define-syntaxes (id ...) rhs)))] - [(define-values (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (let ([ids (syntax->list #'(id ...))]) - (syntax-local-bind-syntaxes ids #f def-ctx) - (list expr))] - [else - (list expr)]))) - exprs))))]) + (begin0 + (let loop ([exprs (cddddr (cdr (syntax->list stx)))]) + (apply + append + (map (lambda (expr) + (let ([expr (local-expand + expr + ctx + block-expand-stop-forms + def-ctx)]) + (syntax-case expr (begin define-values define-syntaxes) + [(begin . rest) + (loop (syntax->list #'rest))] + [(define-syntaxes (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([rhs (local-transformer-expand + #'rhs + 'expression + null)]) + (syntax-local-bind-syntaxes + (syntax->list #'(id ...)) + #'rhs def-ctx) + (list #'(define-syntaxes (id ...) rhs)))] + [(define-values (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (let ([ids (syntax->list #'(id ...))]) + (syntax-local-bind-syntaxes ids #f def-ctx) + (list expr))] + [else + (list expr)]))) + exprs))) + (internal-definition-context-seal def-ctx)))]) #`(let () #,@(let loop ([exprs exprs][prev-defns null][prev-exprs null]) (cond diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 1e72899af5..c9b28bb194 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -386,6 +386,7 @@ [else (list expr)]))) exprs)))]) + (internal-definition-context-seal def-ctx) (let loop ([exprs exprs] [prev-stx-defns null] [prev-defns null] diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index a99eedf6b5..cf507a4e3f 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -667,6 +667,7 @@ (let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null]) (cond [(and (null? pre-lines) (not port) (null? lines)) + (internal-definition-context-seal def-ctx) (make-parsed-unit imports renames vars diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index 29443d50ca..f05c7f8691 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -18,7 +18,7 @@ (provide (rename build-siginfo make-siginfo) siginfo-names siginfo-ctime-ids siginfo-rtime-ids siginfo-subtype unprocess-link-record-bind unprocess-link-record-use - set!-trans-extract do-identifier + set!-trans-extract process-tagged-import process-tagged-export lookup-signature lookup-def-unit make-id-mapper make-id-mappers sig-names sig-int-names sig-ext-names map-sig split-requires apply-mac complete-exports complete-imports check-duplicate-subs @@ -186,20 +186,17 @@ (lambda (x) x) sig))) - ;; do-prefix : sig syntax-object -> sig + ;; do-prefix : id id -> id ;; ensures that pid is an identifier - (define (do-prefix sig pid) - (check-id pid) - (let ((p (syntax-e pid))) - (map-sig - (lambda (id) - (datum->syntax-object - id - (string->symbol (format "~a~a" p (syntax-e id))))) - (lambda (x) x) - sig))) + (define (do-prefix stx pid) + (if (identifier? stx) + (datum->syntax-object + stx + (string->symbol (format "~a~a" (syntax-e pid) (syntax-e stx))) + stx) + stx)) - ;; do-only : sig (listof identifier) -> sig + ;; do-only/except : sig (listof identifier) -> sig ;; ensures that only-ids are identifiers and are mentioned in the signature (define (do-only/except sig only/except-ids put get) (check-module-id-subset only/except-ids @@ -217,22 +214,22 @@ sig))) ;; do-identifier : identifier (box (cons identifier siginfo)) -> sig - (define (do-identifier spec res bind?) + (define (do-identifier spec res bind? add-prefix) (let* ((sig (lookup-signature spec)) (vars (signature-vars sig)) (vals (signature-val-defs sig)) (stxs (signature-stx-defs sig)) (delta-introduce (if bind? - (let ([f (make-syntax-delta-introducer - spec - (signature-orig-binder sig))]) + (let ([f (syntax-local-make-delta-introducer + spec)]) (lambda (id) (syntax-local-introduce (f id)))) values))) (set-box! res (cons spec (signature-siginfo sig))) (map-sig (lambda (id) (syntax-local-introduce (syntax-local-get-shadower - (delta-introduce id)))) + (add-prefix + (delta-introduce id))))) syntax-local-introduce (list (map cons vars vars) (map @@ -301,43 +298,47 @@ (check-tagged-spec-syntax spec import? identifier?) (syntax-case spec (tag) ((tag sym spec) - (let ([s (process-import/export #'spec res bind?)]) + (let ([s (process-import/export #'spec res bind? values)]) (list (cons (syntax-e #'sym) (cdr (unbox res))) (cons (syntax-e #'sym) (car (unbox res))) s))) ((tag . _) (raise-stx-err "expected (tag symbol )" spec)) - (_ (let ([s (process-import/export spec res bind?)]) + (_ (let ([s (process-import/export spec res bind? values)]) (list (cons #f (cdr (unbox res))) (cons #f (car (unbox res))) s))))) + (define (add-prefixes add-prefix l) + (map add-prefix (syntax->list l))) ;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig - (define (process-import/export spec res bind?) + (define (process-import/export spec res bind? add-prefix) (syntax-case spec (only except prefix rename) (_ (identifier? spec) - (do-identifier spec res bind?)) + (do-identifier spec res bind? add-prefix)) ((only sub-spec id ...) - (do-only/except (process-import/export #'sub-spec res bind?) - (syntax->list #'(id ...)) - (lambda (x) x) + (do-only/except (process-import/export #'sub-spec res bind? add-prefix) + (add-prefixes add-prefix #'(id ...)) + (lambda (id) id) (lambda (id) (car (generate-temporaries #`(#,id)))))) ((except sub-spec id ...) - (do-only/except (process-import/export #'sub-spec res bind?) - (syntax->list #'(id ...)) + (do-only/except (process-import/export #'sub-spec res bind? add-prefix) + (add-prefixes add-prefix #'(id ...)) (lambda (id) (car (generate-temporaries #`(#,id)))) - (lambda (x) x))) + (lambda (id) id))) ((prefix pid sub-spec) - (do-prefix (process-import/export #'sub-spec res bind?) #'pid)) + (process-import/export #'sub-spec res bind? + (lambda (id) + (do-prefix (add-prefix id) #'pid)))) ((rename sub-spec (internal external) ...) (let* ((sig-res - (do-rename (process-import/export #'sub-spec res bind?) + (do-rename (process-import/export #'sub-spec res bind? add-prefix) #'(internal ...) - #'(external ...))) + (datum->syntax-object #f (add-prefixes add-prefix #'(external ...))))) (dup (check-duplicate-identifier (sig-int-names sig-res)))) (when dup (raise-stx-err @@ -353,7 +354,7 @@ ;; process-spec : syntax-object -> sig (define (process-spec spec) (check-tagged-spec-syntax spec #f identifier?) - (process-import/export spec (box #f) #t)) + (process-import/export spec (box #f) #t values)) ; ;; extract-siginfo : (union import-spec export-spec) -> ??? diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 60072b633c..698092ee6f 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -333,6 +333,7 @@ (define-for-syntax (add-context-to-sig sig) (let ((def-ctx (syntax-local-make-definition-context))) (syntax-local-bind-syntaxes (sig-ext-names sig) #f def-ctx) + (internal-definition-context-seal def-ctx) (map-sig (lambda (x) x) (lambda (x) (localify x def-ctx)) sig))) @@ -619,6 +620,7 @@ [_ (void)])) expanded-body) table)]) + (internal-definition-context-seal def-ctx) ;; Mark exported names and ;; check that all exported names are defined (as var): diff --git a/collects/mzlib/unit200.ss b/collects/mzlib/unit200.ss index 9952cebe62..c3cdbb6d0a 100644 --- a/collects/mzlib/unit200.ss +++ b/collects/mzlib/unit200.ss @@ -158,7 +158,10 @@ [else (list defn-or-expr)]))) defns&exprs))) values)]) + (let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))]) + (when def-ctx + (internal-definition-context-seal def-ctx)) ;; Get all the defined names, sorting out variable definitions ;; from syntax definitions. (let* ([definition? diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index ec3205135a..8c166179c2 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -410,6 +410,7 @@ (cdr exprs))) (reverse idss) (reverse rhss) (reverse stx-idss) (reverse stx-rhss))]))))]) + (internal-definition-context-seal def-ctx) (if (and (null? (syntax-e #'(stx-rhs ...))) (andmap (lambda (ids) (= 1 (length (syntax->list ids)))) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss new file mode 100644 index 0000000000..41827b90bb --- /dev/null +++ b/collects/scheme/package.ss @@ -0,0 +1,252 @@ +#lang scheme/base +(require (for-syntax scheme/base + syntax/kerncase + syntax/boundmap)) + +(provide define-package + open-package) + +(begin-for-syntax + (define-struct package (exports hidden) + #:omit-define-syntaxes + #:property prop:procedure (lambda (r stx) + (raise-syntax-error + #f + "misuse of a package name" + stx))) + + (define (reverse-mapping id exports hidden) + (or (ormap (lambda (m) + (and (free-identifier=? id (cdr m)) + (car m))) + exports) + (ormap (lambda (h) + (and (free-identifier=? id h) + ;; Name is inaccessible. Generate a temporary to + ;; avoid potential duplicate-definition errors + ;; when the name is bound in the same context as + ;; the package. + (car (generate-temporaries (list id))))) + hidden) + id))) + +(define-syntax (define-package stx) + (syntax-case stx () + [(_ pack-id exports form ...) + (let ([id #'pack-id] + [exports #'exports]) + (unless (identifier? id) + (raise-syntax-error #f + "expected an identifier" + stx + id)) + (let ([exports + (cond + [(eq? (syntax-e exports) 'all-defined) #f] + [(syntax->list exports) + => (lambda (l) + (for-each (lambda (i) + (unless (identifier? i) + (raise-syntax-error #f + "expected identifier to export" + stx + i))) + l) + (let ([dup-id (check-duplicate-identifier l)]) + (when dup-id + (raise-syntax-error + #f + "duplicate export" + stx + dup-id))) + l)] + [else (raise-syntax-error #f + "expected a parenthesized sequence of identifiers to export" + stx + exports)])]) + (let* ([def-ctx (syntax-local-make-definition-context)] + [ctx (cons (gensym 'intdef) + (let ([orig-ctx (syntax-local-context)]) + (if (pair? orig-ctx) + orig-ctx + null)))] + [pre-package-id (lambda (id) + (identifier-remove-from-definition-context + id + def-ctx))] + [kernel-forms (kernel-form-identifier-list)] + [init-exprs (syntax->list #'(form ...))] + [new-bindings (make-bound-identifier-mapping)] + [fixup-sub-package (lambda (renamed-exports renamed-defines) + (lambda (stx) + (syntax-case* stx (define-syntaxes #%plain-app make-package quote-syntax + list cons #%plain-lambda) + free-transformer-identifier=? + [(define-syntaxes (pack-id) + (#%plain-app + make-package + (#%plain-lambda () + (#%plain-app list + (#%plain-app cons + (quote-syntax export) + (quote-syntax renamed)) + ...)) + hidden)) + (with-syntax ([(export ...) + (map (lambda (id) + (if (or (ormap (lambda (e-id) + (bound-identifier=? id e-id)) + renamed-exports) + (not (ormap (lambda (e-id) + (bound-identifier=? id e-id)) + renamed-defines))) + ;; Need to preserve the original + (pre-package-id id) + ;; It's not accessible, so just hide the name + ;; to avoid re-binding errors. + (car (generate-temporaries (list id))))) + (syntax->list #'(export ...)))]) + (syntax/loc stx + (define-syntaxes (pack-id) + (make-package + (lambda () + (list (cons (quote-syntax export) + (quote-syntax renamed)) + ...)) + hidden))))] + [_ stx])))]) + (let ([register-bindings! + (lambda (ids) + (for-each (lambda (id) + (when (bound-identifier-mapping-get new-bindings id (lambda () #f)) + (raise-syntax-error #f + "duplicate binding" + stx + id)) + (bound-identifier-mapping-put! new-bindings + id + #t)) + ids))] + [add-package-context (lambda (stx) + (let ([q (local-expand #`(quote #,stx) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ stx) #'stx])))]) + (let loop ([exprs init-exprs] + [rev-forms null] + [defined null]) + (cond + [(null? exprs) + (internal-definition-context-seal def-ctx) + (let ([exports-renamed (map add-package-context (or exports null))] + [defined-renamed (bound-identifier-mapping-map new-bindings + (lambda (k v) k))]) + (for-each (lambda (ex renamed) + (unless (bound-identifier-mapping-get new-bindings + renamed + (lambda () #f)) + (raise-syntax-error #f + "no definition for exported identifier" + stx + ex))) + (or exports null) + exports-renamed) + (with-syntax ([(export ...) exports] + [(renamed ...) exports-renamed] + [(hidden ...) + (begin + (for-each (lambda (ex) + (bound-identifier-mapping-put! new-bindings ex #f)) + exports-renamed) + (filter + values + (bound-identifier-mapping-map new-bindings + (lambda (k v) (and v k)))))]) + #`(begin + #,@(map (fixup-sub-package exports-renamed defined-renamed) (reverse rev-forms)) + (define-syntax pack-id + (make-package + (lambda () + (list (cons (quote-syntax export) + (quote-syntax renamed)) + ...)) + (lambda () + (list (quote-syntax hidden) ...)))))))] + [else + (let ([expr (local-expand (car exprs) ctx kernel-forms def-ctx)]) + (syntax-case expr (begin define-syntaxes define-values) + [(begin . rest) + (loop (append (syntax->list #'rest) (cdr exprs)) + rev-forms + defined)] + [(define-syntaxes (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([rhs (local-transformer-expand + #'rhs + 'expression + null)]) + (let ([ids (syntax->list #'(id ...))]) + (syntax-local-bind-syntaxes ids #'rhs def-ctx) + (register-bindings! ids) + (loop (cdr exprs) + (cons #'(define-syntaxes (id ...) rhs) + rev-forms) + (cons ids defined))))] + [(define-values (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (let ([ids (syntax->list #'(id ...))]) + (syntax-local-bind-syntaxes ids #f def-ctx) + (register-bindings! ids) + (loop (cdr exprs) + (cons expr rev-forms) + (cons ids defined)))] + [else + (loop (cdr exprs) + (cons #`(define-values () (begin #,expr (values))) + rev-forms) + defined)]))]))))))])) + +(define-syntax (open-package stx) + (syntax-case stx () + [(_ pack-id) + (let ([id #'pack-id]) + (unless (identifier? id) + (raise-syntax-error #f + "expected an identifier for a package" + stx + id)) + (let ([v (syntax-local-value id (lambda () #f))]) + (unless (package? v) + (raise-syntax-error #f + "identifier is not bound to a package" + stx + id)) + (let ([introduce (syntax-local-make-delta-introducer + (syntax-local-introduce id))]) + (with-syntax ([(intro ...) + (map (lambda (i) + (syntax-local-introduce + (syntax-local-get-shadower + (introduce i)))) + (map car ((package-exports v))))] + [(defined ...) + (map (lambda (v) (syntax-local-introduce (cdr v))) + ((package-exports v)))] + [((a . b) ...) (map (lambda (p) + (cons (syntax-local-introduce (car p)) + (syntax-local-introduce (cdr p)))) + ((package-exports v)))] + [(h ...) (map syntax-local-introduce ((package-hidden v)))]) + #'(begin + (define-syntaxes (intro ...) + (let ([rev-map (lambda (x) + (reverse-mapping + x + (list (cons (quote-syntax a) + (quote-syntax b)) + ...) + (list (quote-syntax h) ...)))]) + (values (make-rename-transformer #'defined rev-map) + ...))))))))])) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 36356c5413..37006a569d 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -1214,6 +1214,8 @@ proc)))))) methods)))] [lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))]) + + (internal-definition-context-seal def-ctx) ;; ---- build final result ---- (with-syntax ([public-names (map lookup-localize-cdr publics)] diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index 7124f054be..23eb987652 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -52,6 +52,7 @@ (let ([def-ctx (syntax-local-make-definition-context)] [ctx (list (gensym 'intdef))]) (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) + (internal-definition-context-seal def-ctx) (let* ([add-context (lambda (expr) (let ([q (local-expand #`(quote #,expr) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 4ef99b1666..eb0ced966b 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -58,15 +58,19 @@ Returns the procedure that was passed to @scheme[make-set!-transformer] to create @scheme[transformer].} -@defproc[(make-rename-transformer [id-stx syntax?]) +@defproc[(make-rename-transformer [id-stx syntax?] + [delta-introduce (identifier? . -> . identifier?) + (lambda (id) id)]) rename-transformer?]{ -Creates a value that, when used as a @tech{transformer binding}, -inserts the identifier @scheme[id-stx] in place of whatever identifier -binds the transformer, including in non-application positions, and in +Creates a @tech{rename transformer} that, when used as a +@tech{transformer binding}, acts as a transformer that insert the +identifier @scheme[id-stx] in place of whatever identifier binds the +transformer, including in non-application positions, and in @scheme[set!] expressions. Such a transformer could be written manually, but the one created by @scheme[make-rename-transformer] -cooperates specially with @scheme[syntax-local-value] (see below).} +cooperates specially with @scheme[syntax-local-value] and +@scheme[syntax-local-make-delta-introducer].} @defproc[(rename-transformer? [v any/c]) boolean?]{ @@ -184,15 +188,25 @@ expressions are reported as @scheme[define-values] forms (in the transformer environment).} +@defproc[(internal-definition-context? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is an @tech{internal-definition +context}, @scheme[#f] otherwise.} + + @defproc[(syntax-local-make-definition-context) internal-definition-context?]{ -Creates an opaque internal-definition context value to be used with -@scheme[local-expand] and other functions. A transformer should create -one context for each set of internal definitions to be expanded, and -use it when expanding any form whose lexical context should include -the definitions. After discovering an internal @scheme[define-values] -or @scheme[define-syntaxes] form, use +Creates an opaque @tech{internal-definition context} value to be used +with @scheme[local-expand] and other functions. A transformer should +create one context for each set of internal definitions to be +expanded, and use it when expanding any form whose lexical context +should include the definitions. After discovering an internal +@scheme[define-values] or @scheme[define-syntaxes] form, use @scheme[syntax-local-bind-syntaxes] to add bindings to the context. +Finally, the transformer must call +@scheme[internal-definition-context-seal] after all bindings have been +added; if an unsealed @tech{internal-definition context} is detected +in a fully expanded expression, the @exnraise[exn:fail:contract]. @transform-time[]} @@ -203,7 +217,7 @@ or @scheme[define-syntaxes] form, use void?]{ Binds each identifier in @scheme[id-list] within the -internal-definition context represented by @scheme[intdef-ctx], where +@tech{internal-definition context} represented by @scheme[intdef-ctx], where @scheme[intdef-ctx] is the result of @scheme[syntax-local-make-definition-context]. Supply @scheme[#f] for @scheme[expr] when the identifiers correspond to @@ -216,6 +230,24 @@ match the number of identifiers, otherwise the @transform-time[]} +@defproc[(internal-definition-context-seal [intdef-ctx internal-definition-context?]) + void?]{ + +Indicates that no further bindings will be added to +@scheme[intdef-ctx], which must not be sealed already. See also +@scheme[syntax-local-make-definition-context].} + + +@defproc[(identifier-remove-from-defininition-context [id-stx identifier?] + [intdef-ctx internal-definition-context?]) + identifier?]{ + +Removes @scheme[intdef-ctx] from the @tech{lexical information} of +@scheme[id-stx]. This operation is useful for correlating a identifier +that is bound in an internal-definition context with its binding +before the internal-definition context was created.} + + @defproc[(syntax-local-value [id-stx syntax?] [failure-thunk (or/c (-> any) #f) #f] @@ -225,16 +257,16 @@ match the number of identifiers, otherwise the any]{ Returns the @tech{transformer binding} value of @scheme[id-stx] in -either the context asscoiated with @scheme[intdef-ctx] (if not +either the context associated with @scheme[intdef-ctx] (if not @scheme[#f]) or the context of the expression being expanded (if @scheme[indef-ctx] is @scheme[#f]). If @scheme[intdef-ctx] is provided, it must be an extension of the context of the expression being expanded. -If @scheme[id-stx] is bound to a rename transformer created with -@scheme[make-rename-transformer], @scheme[syntax-local-value] +If @scheme[id-stx] is bound to a @tech{rename transformer} created +with @scheme[make-rename-transformer], @scheme[syntax-local-value] effectively calls itself with the target of the rename and returns -that result, instead of the rename transformer. +that result, instead of the @tech{rename transformer}. If @scheme[id-stx] has no @tech{transformer binding} (via @scheme[define-syntax], @scheme[let-syntax], etc.) in that @@ -333,8 +365,8 @@ context}. The identity of the lists's first element (i.e., its @scheme[eq?]ness) reflects the identity of the internal-definition context; in particular two transformer expansions receive the same first value if and only if they are invoked for the same -internal-definition context. Later values in the list similarly -identify internal-definition contexts that are still being expanded, +@tech{internal-definition context}. Later values in the list similarly +identify @tech{internal-definition contexts} that are still being expanded, and that required the expansion of nested internal-definition contexts. @@ -440,20 +472,53 @@ mark}. Multiple applications of the same @scheme[make-syntax-introducer] result procedure use the same mark, and different result procedures use distinct marks.} -@defproc[(make-syntax-delta-introducer [ext-stx syntax?] [base-stx syntax?]) +@defproc[(make-syntax-delta-introducer [ext-stx syntax?] + [base-stx syntax?] + [phase-level (or/c #f exact-integer?) + (syntax-local-phase-level)]) (syntax? . -> . syntax?)]{ Produces a procedure that behaves like -@scheme[syntax-local-introduce], but using the @tech{syntax -marks} of @scheme[ext-stx] that are not shared with @scheme[base-stx]. +@scheme[syntax-local-introduce], but using the @tech{syntax marks} of +@scheme[ext-stx] that are not shared with @scheme[base-stx]. If +@scheme[ext-stx] does not extend the set of marks in @scheme[base-stx] +but @scheme[ext-stx] has a module binding in the @tech{phase level} +indicated by @scheme[phase-level], then any marks of @scheme[ext-stx] +that would be needed to preserve its binding are not transferred in an +introduction. -This procedure is useful when @scheme[_m-id] has a transformer binding -that records some @scheme[_orig-id], and a use of @scheme[_m-id] -introduces a binding of @scheme[_orig-id]. In that case, the -@tech{syntax marks} in the use of @scheme[_m-id] since the binding of -@scheme[_m-id] should be transferred to the binding instance of -@scheme[_orig-id], so that it captures uses with the same lexical -context as the use of @scheme[_m-id].} +This procedure is potentially useful when @scheme[_m-id] has a +transformer binding that records some @scheme[_orig-id], and a use of +@scheme[_m-id] introduces a binding of @scheme[_orig-id]. In that +case, the @tech{syntax marks} in the use of @scheme[_m-id] since the +binding of @scheme[_m-id] should be transferred to the binding +instance of @scheme[_orig-id], so that it captures uses with the same +lexical context as the use of @scheme[_m-id]. + +More typically, however, @scheme[syntax-local-make-delta-introducer] +should be used, since it cooperates with @tech{rename transformers}.} + +@defproc[(syntax-local-make-delta-introducer [id identifier?]) + (identifier? . -> . identifier?)]{ + +Determines the binding of @scheme[id]. If the binding is not a +@tech{rename transformer}, the result is an introducer as created by +@scheme[make-syntax-delta-introducer] using @scheme[id] and the +binding of @scheme[id] in the environment of expansion. If the binding +is a @tech{rename transformer}, then the introducer is one composed +with the target of the @tech{rename transformer} and its +binding. Furthermore, the @scheme[_delta-introduce] functions +associated with the @tech{rename transformers} (supplied as the second +argument to @scheme[make-rename-transformer]) are composed (in +first-to-last order) before the introducers created with +@scheme[make-syntax-delta-introducer] (which are composed +last-to-first). + +The @exnraise[exn:fail:contract] if @scheme[id] or any identifier in +its rename-transformer chain has no binding. + +@transform-time[]} + @defproc[(syntax-local-transforming-module-provides?) boolean?]{ diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index 79220ca738..dfa0d2bf55 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/collects/scribblings/reference/syntax-model.scrbl @@ -543,8 +543,9 @@ transformer binding's value. When @scheme[_id] is bound to a @deftech{rename transformer} produced by @scheme[make-rename-transformer], it is replaced with the identifier passed to @scheme[make-rename-transformer]. Furthermore, the binding -is also specially handled by @scheme[syntax-local-value] as used by -@tech{syntax transformer}s. +is also specially handled by @scheme[syntax-local-value] and +@scheme[syntax-local-make-delta-introducer] as used by @tech{syntax +transformer}s. In addition to using marks to track introduced identifiers, the expander tracks the expansion history of a form through @tech{syntax diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss index 4080b105b7..5c9b022a05 100644 --- a/collects/tests/mzscheme/macro.ss +++ b/collects/tests/mzscheme/macro.ss @@ -214,7 +214,7 @@ (arity-test make-set!-transformer 1 1) (arity-test set!-transformer? 1 1) -(arity-test make-rename-transformer 1 1) +(arity-test make-rename-transformer 1 2) (arity-test rename-transformer? 1 1) ;; Test inheritance of context when . is used in a pattern @@ -400,4 +400,36 @@ ;; ---------------------------------------- +(define-syntax (bind stx) + (syntax-case stx () + [(_ handle def) + (let ([def-ctx (syntax-local-make-definition-context)] + [ctx (cons (gensym 'intdef) + (let ([orig-ctx (syntax-local-context)]) + (if (pair? orig-ctx) + orig-ctx + null)))] + [kernel-forms (list #'define-values)]) + (let ([def (local-expand #'def ctx kernel-forms def-ctx)]) + (syntax-case def () + [(define-values (id) rhs) + (begin + (syntax-local-bind-syntaxes (list #'id) #f def-ctx) + #'(begin + (define-values (id) rhs) + (define-syntax handle (quote-syntax id))))] + [_ (error "no")])))])) + +(define-syntax (nab stx) + (syntax-case stx () + [(_ handle) + (syntax-local-value #'handle)])) + +(let () + (bind h (define q 5)) + (define q 8) + (nab h)) + +;; ---------------------------------------- + (report-errs) diff --git a/collects/tests/units/test-unit.ss b/collects/tests/units/test-unit.ss index e7cb92bc2c..2dd639d3b2 100644 --- a/collects/tests/units/test-unit.ss +++ b/collects/tests/units/test-unit.ss @@ -1644,12 +1644,16 @@ (define-signature sig^ (u-a)) -(define unit@ - (unit - (import) - (export sig^) +(define-unit unit@ + (import) + (export sig^) + + (define u-a 'zero)) - (define u-a 'zero))) +(test 'zero + (let ([q:u-a 5]) + (define-values/invoke-unit unit@ (import) (export (prefix q: sig^))) + q:u-a)) (define-syntax (use-unit stx) (syntax-case stx () @@ -1658,6 +1662,13 @@ (define-values/invoke-unit unit@ (import) (export sig^)) u-a)])) +(define-syntax (use-unit2 stx) + (syntax-case stx () + [(_) + #'(let () + (define-values/invoke-unit/infer unit@) + u-a)])) + (define-syntax (use-unit-badly1 stx) (syntax-case stx () [(_ u-a) @@ -1673,6 +1684,7 @@ u-a)])) (test 'zero (use-unit)) +(test 'zero (use-unit2)) (test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a" (use-unit-badly1 u-a)) (test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a" diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index dcedcf7591..3f2e2654cb 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,12 @@ +Version 4.1.3.2 +Added internal-definition-context-seal, which must be used on an + internal-definition context before it's part of a fully expanded form +Added syntax-local-make-delta-introducer +Changed make-rename-transformer to accept an introducer argument that + cooperates with syntax-local-make-delta-introducer +Added internal-defininition-context? +Added identifier-remove-from-defininition-context + Version 4.1.3, November 2008 Changed scheme to re-export scheme/port In scheme/port: added diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index e91cdcf96c..9e6dc1fde0 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,5 +1,5 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,50,46,52,50,0,0,0,1,0,0,6,0,9,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,50,50,0,0,0,1,0,0,6,0,9,0, 13,0,26,0,29,0,34,0,41,0,46,0,51,0,58,0,65,0,69,0,78, 0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, 177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,68,1,107,1,146, @@ -14,11 +14,11 @@ 115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109, 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, 45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,98, -10,35,11,8,188,227,94,159,2,16,35,35,159,2,15,35,35,16,20,2,3, +10,35,11,8,174,227,94,159,2,16,35,35,159,2,15,35,35,16,20,2,3, 2,2,2,4,2,2,2,10,2,2,2,5,2,2,2,6,2,2,2,7,2, 2,2,8,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97,36,11,8, -188,227,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2, -13,97,10,11,11,8,188,227,16,0,97,10,37,11,8,188,227,16,0,13,16, +174,227,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2, +13,97,10,11,11,8,174,227,16,0,97,10,37,11,8,174,227,16,0,13,16, 4,35,29,11,11,2,2,11,18,98,64,104,101,114,101,8,31,8,30,8,29, 8,28,8,27,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251, 22,74,2,17,248,22,89,23,200,2,12,249,22,64,2,1,248,22,91,23,202, @@ -28,14 +28,14 @@ 36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158, 38,35,251,22,74,2,17,248,22,65,23,200,2,249,22,64,2,12,248,22,66, 23,202,1,11,18,100,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11, -2,18,3,1,7,101,110,118,57,57,53,57,16,4,11,11,2,19,3,1,7, -101,110,118,57,57,54,48,27,248,22,66,248,22,133,4,23,197,1,28,248,22, +2,18,3,1,7,101,110,118,57,55,50,53,16,4,11,11,2,19,3,1,7, +101,110,118,57,55,50,54,27,248,22,66,248,22,133,4,23,197,1,28,248,22, 72,23,194,2,20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248, 22,65,193,249,22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22, 74,248,22,74,2,21,248,22,65,23,202,2,251,22,74,2,17,2,21,2,21, 249,22,64,2,5,248,22,66,23,205,1,18,100,11,8,31,8,30,8,29,8, -28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,57,54,50,16,4, -11,11,2,19,3,1,7,101,110,118,57,57,54,51,248,22,133,4,193,27,248, +28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,50,56,16,4, +11,11,2,19,3,1,7,101,110,118,57,55,50,57,248,22,133,4,193,27,248, 22,133,4,194,249,22,64,248,22,74,248,22,65,196,248,22,66,195,27,248,22, 66,248,22,133,4,23,197,1,249,22,190,3,80,158,38,35,28,248,22,52,248, 22,191,3,248,22,65,23,198,2,27,249,22,2,32,0,89,162,8,44,36,42, @@ -65,8 +65,8 @@ 251,22,74,2,17,28,249,22,162,8,248,22,191,3,248,22,65,23,201,2,64, 101,108,115,101,10,248,22,65,23,198,2,250,22,75,2,20,9,248,22,66,23, 201,1,249,22,64,2,8,248,22,66,23,203,1,99,8,31,8,30,8,29,8, -28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,57,56,53,16,4, -11,11,2,19,3,1,7,101,110,118,57,57,56,54,18,158,94,10,64,118,111, +28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,53,49,16,4, +11,11,2,19,3,1,7,101,110,118,57,55,53,50,18,158,94,10,64,118,111, 105,100,8,47,27,248,22,66,248,22,133,4,196,249,22,190,3,80,158,38,35, 28,248,22,52,248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248, 22,65,199,248,22,89,198,27,248,22,191,3,248,22,65,197,250,22,74,2,26, @@ -99,7 +99,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2032); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,50,46,52,60,0,0,0,1,0,0,3,0,16,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,50,60,0,0,0,1,0,0,3,0,16,0, 21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0,200, 0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112,1, 157,1,202,1,226,1,9,2,11,2,68,2,158,3,199,3,33,5,137,5,241, @@ -344,12 +344,12 @@ EVAL_ONE_SIZED_STR((char *)expr, 5068); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,50,46,52,8,0,0,0,1,0,0,6,0,19,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,50,8,0,0,0,1,0,0,6,0,19,0, 34,0,48,0,62,0,76,0,111,0,0,0,255,0,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35, -37,107,101,114,110,101,108,11,98,10,35,11,8,190,229,97,159,2,2,35,35, +37,107,101,114,110,101,108,11,98,10,35,11,8,176,229,97,159,2,2,35,35, 159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16, 0,159,35,20,103,159,35,16,1,65,98,101,103,105,110,16,0,83,158,41,20, 100,138,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11, @@ -361,40 +361,41 @@ EVAL_ONE_SIZED_STR((char *)expr, 292); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,50,46,52,52,0,0,0,1,0,0,3,0,14,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,50,53,0,0,0,1,0,0,3,0,14,0, 41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0,200, -0,223,0,3,1,8,1,13,1,18,1,23,1,54,1,58,1,66,1,74,1, -82,1,185,1,230,1,250,1,29,2,64,2,98,2,108,2,155,2,165,2,172, -2,71,4,84,4,103,4,222,4,234,4,130,5,144,5,8,6,14,6,28,6, -55,6,140,6,142,6,207,6,142,12,201,12,233,12,0,0,157,15,0,0,29, -11,11,70,100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,117,108, -116,45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,65,113, -117,111,116,101,29,94,2,4,67,35,37,117,116,105,108,115,11,29,94,2,4, -68,35,37,112,97,114,97,109,122,11,1,20,100,101,102,97,117,108,116,45,114, -101,97,100,101,114,45,103,117,97,114,100,1,24,45,109,111,100,117,108,101,45, -104,97,115,104,45,116,97,98,108,101,45,116,97,98,108,101,71,45,112,97,116, -104,45,99,97,99,104,101,77,45,108,111,97,100,105,110,103,45,102,105,108,101, -110,97,109,101,79,45,108,111,97,100,105,110,103,45,112,114,111,109,112,116,45, -116,97,103,71,45,112,114,101,118,45,114,101,108,116,111,75,45,112,114,101,118, -45,114,101,108,116,111,45,100,105,114,1,21,115,112,108,105,116,45,114,101,108, -97,116,105,118,101,45,115,116,114,105,110,103,1,34,109,97,107,101,45,115,116, -97,110,100,97,114,100,45,109,111,100,117,108,101,45,110,97,109,101,45,114,101, -115,111,108,118,101,114,64,98,111,111,116,64,115,97,109,101,5,3,46,122,111, -64,108,111,111,112,1,29,115,116,97,110,100,97,114,100,45,109,111,100,117,108, -101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,63,108,105,98,67,105, -103,110,111,114,101,100,249,22,14,195,80,158,37,45,249,80,159,37,48,36,195, -10,27,28,23,195,2,28,249,22,162,8,23,197,2,80,158,38,46,87,94,23, -195,1,80,158,36,47,27,248,22,171,4,23,197,2,28,248,22,135,13,23,194, -2,91,159,38,11,90,161,38,35,11,248,22,156,13,23,197,1,87,95,83,160, -37,11,80,158,40,46,198,83,160,37,11,80,158,40,47,192,192,11,11,28,23, -193,2,192,87,94,23,193,1,27,247,22,189,4,28,192,192,247,22,175,13,20, -14,159,80,158,35,39,250,80,158,38,40,249,22,27,11,80,158,40,39,22,189, -4,28,248,22,135,13,23,198,2,23,197,1,87,94,23,197,1,247,22,175,13, -247,194,250,22,153,13,23,197,1,23,199,1,249,80,158,42,38,23,198,1,2, -18,252,22,153,13,23,199,1,23,201,1,6,6,6,110,97,116,105,118,101,247, -22,177,7,249,80,158,44,38,23,200,1,80,158,44,35,87,94,23,194,1,27, +0,223,0,3,1,8,1,13,1,18,1,27,1,32,1,63,1,67,1,75,1, +83,1,91,1,194,1,239,1,3,2,31,2,62,2,117,2,127,2,174,2,184, +2,191,2,78,4,91,4,110,4,229,4,241,4,137,5,151,5,15,6,21,6, +35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,164,15,0, +0,29,11,11,70,100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97, +117,108,116,45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100, +65,113,117,111,116,101,29,94,2,4,67,35,37,117,116,105,108,115,11,29,94, +2,4,68,35,37,112,97,114,97,109,122,11,1,20,100,101,102,97,117,108,116, +45,114,101,97,100,101,114,45,103,117,97,114,100,1,24,45,109,111,100,117,108, +101,45,104,97,115,104,45,116,97,98,108,101,45,116,97,98,108,101,71,45,112, +97,116,104,45,99,97,99,104,101,77,45,108,111,97,100,105,110,103,45,102,105, +108,101,110,97,109,101,79,45,108,111,97,100,105,110,103,45,112,114,111,109,112, +116,45,116,97,103,71,45,112,114,101,118,45,114,101,108,116,111,75,45,112,114, +101,118,45,114,101,108,116,111,45,100,105,114,1,21,115,112,108,105,116,45,114, +101,108,97,116,105,118,101,45,115,116,114,105,110,103,1,34,109,97,107,101,45, +115,116,97,110,100,97,114,100,45,109,111,100,117,108,101,45,110,97,109,101,45, +114,101,115,111,108,118,101,114,64,98,111,111,116,64,115,97,109,101,5,3,46, +122,111,6,6,6,110,97,116,105,118,101,64,108,111,111,112,1,29,115,116,97, +110,100,97,114,100,45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115, +111,108,118,101,114,63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195, +80,158,37,45,249,80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,162, +8,23,197,2,80,158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,171, +4,23,197,2,28,248,22,135,13,23,194,2,91,159,38,11,90,161,38,35,11, +248,22,156,13,23,197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37, +11,80,158,40,47,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247, +22,189,4,28,192,192,247,22,175,13,20,14,159,80,158,35,39,250,80,158,38, +40,249,22,27,11,80,158,40,39,22,189,4,28,248,22,135,13,23,198,2,23, +197,1,87,94,23,197,1,247,22,175,13,247,194,250,22,153,13,23,197,1,23, +199,1,249,80,158,42,38,23,198,1,2,18,252,22,153,13,23,199,1,23,201, +1,2,19,247,22,177,7,249,80,158,44,38,23,200,1,80,158,44,35,87,94, 23,194,1,27,250,22,170,13,196,11,32,0,89,162,8,44,35,40,9,222,11, -28,192,249,22,64,195,194,11,27,248,23,195,1,23,196,1,27,250,22,170,13, +28,192,249,22,64,195,194,11,27,252,22,153,13,23,200,1,23,202,1,2,19, +247,22,177,7,249,80,158,45,38,23,201,1,80,158,45,35,27,250,22,170,13, 196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,64,195,194,11, 249,247,22,180,13,248,22,65,195,195,27,250,22,153,13,23,198,1,23,200,1, 249,80,158,43,38,23,199,1,2,18,27,250,22,170,13,196,11,32,0,89,162, @@ -407,156 +408,155 @@ 249,22,160,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,156,13,23, 194,2,87,94,23,196,1,90,161,36,39,11,28,249,22,162,8,23,196,2,68, 114,101,108,97,116,105,118,101,87,94,23,194,1,2,17,23,194,1,90,161,36, -40,11,247,22,177,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27, -27,89,162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162,8,44, -36,47,9,223,5,33,29,23,203,2,27,28,23,195,2,27,249,22,5,83,158, -39,20,97,94,89,162,8,44,36,47,9,223,5,33,30,23,198,1,23,205,2, -27,28,23,196,2,11,193,28,192,192,28,193,28,23,196,2,28,249,22,166,3, -248,22,66,196,248,22,66,23,199,2,193,11,11,11,87,94,23,195,1,11,28, -23,193,2,249,80,159,47,54,36,202,89,162,43,35,45,9,224,14,2,33,31, -87,94,23,193,1,27,28,23,197,1,27,249,22,5,83,158,39,20,97,94,89, -162,8,44,36,50,9,225,14,12,10,33,32,23,203,1,23,206,1,27,28,196, -11,193,28,192,192,28,193,28,196,28,249,22,166,3,248,22,66,196,248,22,66, -199,193,11,11,11,11,28,192,249,80,159,48,54,36,203,89,162,43,35,45,9, -224,15,2,33,33,249,80,159,48,54,36,203,89,162,43,35,44,9,224,15,7, -33,34,32,36,89,162,8,44,36,54,2,19,222,33,38,0,17,35,114,120,34, -94,40,46,42,63,41,47,40,46,42,41,36,34,27,249,22,185,13,2,37,23, -196,2,28,23,193,2,87,94,23,194,1,249,22,64,248,22,89,23,196,2,27, -248,22,98,23,197,1,27,249,22,185,13,2,37,23,196,2,28,23,193,2,87, -94,23,194,1,249,22,64,248,22,89,23,196,2,27,248,22,98,23,197,1,27, -249,22,185,13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,64, -248,22,89,23,196,2,248,2,36,248,22,98,23,197,1,248,22,74,194,248,22, -74,194,248,22,74,194,32,39,89,162,43,36,54,2,19,222,33,40,28,248,22, -72,248,22,66,23,195,2,249,22,7,9,248,22,65,195,91,159,37,11,90,161, -37,35,11,27,248,22,66,23,197,2,28,248,22,72,248,22,66,23,195,2,249, -22,7,9,248,22,65,195,91,159,37,11,90,161,37,35,11,27,248,22,66,23, -197,2,28,248,22,72,248,22,66,23,195,2,249,22,7,9,248,22,65,195,91, -159,37,11,90,161,37,35,11,248,2,39,248,22,66,23,197,2,249,22,7,249, -22,64,248,22,65,23,200,1,23,197,1,195,249,22,7,249,22,64,248,22,65, -23,200,1,23,197,1,195,249,22,7,249,22,64,248,22,65,23,200,1,23,197, -1,195,27,248,2,36,23,195,1,28,194,192,248,2,39,193,87,95,28,248,22, -169,4,195,12,250,22,128,9,2,20,6,20,20,114,101,115,111,108,118,101,100, -45,109,111,100,117,108,101,45,112,97,116,104,197,28,24,193,2,248,24,194,1, -195,87,94,23,193,1,12,27,27,250,22,138,2,80,158,41,42,248,22,141,14, -247,22,182,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,122,87,94, -250,22,136,2,80,158,42,42,248,22,141,14,247,22,182,11,195,192,250,22,136, -2,195,198,66,97,116,116,97,99,104,251,211,197,198,199,10,28,192,250,22,191, -8,11,196,195,248,22,189,8,194,28,249,22,163,6,194,6,1,1,46,2,17, -28,249,22,163,6,194,6,2,2,46,46,62,117,112,192,28,249,22,164,8,248, -22,66,23,200,2,23,197,1,28,249,22,162,8,248,22,65,23,200,2,23,196, -1,251,22,189,8,2,20,6,26,26,99,121,99,108,101,32,105,110,32,108,111, -97,100,105,110,103,32,97,116,32,126,101,58,32,126,101,23,200,1,249,22,2, -22,66,248,22,79,249,22,64,23,206,1,23,202,1,12,12,247,192,20,14,159, -80,158,39,44,249,22,64,248,22,141,14,247,22,182,11,23,197,1,20,14,159, -80,158,39,39,250,80,158,42,40,249,22,27,11,80,158,44,39,22,151,4,23, -196,1,249,247,22,188,4,23,198,1,248,22,53,248,22,139,13,23,198,1,87, -94,28,28,248,22,135,13,23,197,2,10,248,22,175,4,23,197,2,12,28,23, -198,2,250,22,191,8,11,6,15,15,98,97,100,32,109,111,100,117,108,101,32, -112,97,116,104,23,201,2,250,22,128,9,2,20,6,19,19,109,111,100,117,108, -101,45,112,97,116,104,32,111,114,32,112,97,116,104,23,199,2,28,28,248,22, -62,23,197,2,249,22,162,8,248,22,65,23,199,2,2,4,11,248,22,170,4, -248,22,89,197,28,28,248,22,62,23,197,2,249,22,162,8,248,22,65,23,199, -2,66,112,108,97,110,101,116,11,87,94,28,207,12,20,14,159,80,158,37,39, -250,80,158,40,40,249,22,27,11,80,158,42,39,22,182,11,23,197,1,90,161, -36,35,10,249,22,152,4,21,94,2,21,6,18,18,112,108,97,110,101,116,47, -114,101,115,111,108,118,101,114,46,115,115,1,27,112,108,97,110,101,116,45,109, -111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,12,251, -211,199,200,201,202,87,94,23,193,1,27,89,162,8,44,36,45,79,115,104,111, -119,45,99,111,108,108,101,99,116,105,111,110,45,101,114,114,223,6,33,44,27, -28,248,22,52,23,199,2,27,250,22,138,2,80,158,43,43,249,22,64,23,204, -2,247,22,176,13,11,28,23,193,2,192,87,94,23,193,1,91,159,37,11,90, -161,37,35,11,249,80,159,44,48,36,248,22,55,23,204,2,11,27,251,80,158, -47,50,2,20,23,202,1,28,248,22,72,23,199,2,23,199,2,248,22,65,23, -199,2,28,248,22,72,23,199,2,9,248,22,66,23,199,2,249,22,153,13,23, -195,1,28,248,22,72,23,197,1,87,94,23,197,1,6,7,7,109,97,105,110, -46,115,115,249,22,180,6,23,199,1,6,3,3,46,115,115,28,248,22,157,6, -23,199,2,87,94,23,194,1,27,248,80,159,41,55,36,23,201,2,27,250,22, -138,2,80,158,44,43,249,22,64,23,205,2,23,199,2,11,28,23,193,2,192, -87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,45,48,36,23, -204,2,11,250,22,1,22,153,13,23,199,1,249,22,78,249,22,2,32,0,89, -162,8,44,36,43,9,222,33,45,23,200,1,248,22,74,23,200,1,28,248,22, -135,13,23,199,2,87,94,23,194,1,28,248,22,158,13,23,199,2,23,198,2, -248,22,74,6,26,26,32,40,97,32,112,97,116,104,32,109,117,115,116,32,98, -101,32,97,98,115,111,108,117,116,101,41,28,249,22,162,8,248,22,65,23,201, -2,2,21,27,250,22,138,2,80,158,43,43,249,22,64,23,204,2,247,22,176, -13,11,28,23,193,2,192,87,94,23,193,1,91,159,38,11,90,161,37,35,11, -249,80,159,45,48,36,248,22,89,23,205,2,11,90,161,36,37,11,28,248,22, -72,248,22,91,23,204,2,28,248,22,72,23,194,2,249,22,187,13,0,8,35, -114,120,34,91,46,93,34,23,196,2,11,10,27,27,28,23,197,2,249,22,78, -28,248,22,72,248,22,91,23,208,2,21,93,6,5,5,109,122,108,105,98,249, -22,1,22,78,249,22,2,80,159,51,56,36,248,22,91,23,211,2,23,197,2, -28,248,22,72,23,196,2,248,22,74,23,197,2,23,195,2,251,80,158,49,50, -2,20,23,204,1,248,22,65,23,198,2,248,22,66,23,198,1,249,22,153,13, -23,195,1,28,23,198,1,87,94,23,196,1,23,197,1,28,248,22,72,23,197, -1,87,94,23,197,1,6,7,7,109,97,105,110,46,115,115,28,249,22,187,13, -0,8,35,114,120,34,91,46,93,34,23,199,2,23,197,1,249,22,180,6,23, -199,1,6,3,3,46,115,115,28,249,22,162,8,248,22,65,23,201,2,64,102, -105,108,101,249,22,160,13,248,22,164,13,248,22,89,23,202,2,248,80,159,42, -55,36,23,202,2,12,87,94,28,28,248,22,135,13,23,194,2,10,248,22,179, -7,23,194,2,87,94,23,200,1,12,28,23,200,2,250,22,191,8,67,114,101, -113,117,105,114,101,249,22,141,7,6,17,17,98,97,100,32,109,111,100,117,108, -101,32,112,97,116,104,126,97,28,23,198,2,248,22,65,23,199,2,6,0,0, -23,203,1,87,94,23,200,1,250,22,128,9,2,20,249,22,141,7,6,13,13, -109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,65,23, -199,2,6,0,0,23,201,2,27,28,248,22,179,7,23,195,2,249,22,184,7, -23,196,2,35,249,22,162,13,248,22,163,13,23,197,2,11,27,28,248,22,179, -7,23,196,2,249,22,184,7,23,197,2,36,248,80,158,42,51,23,195,2,91, -159,38,11,90,161,38,35,11,28,248,22,179,7,23,199,2,250,22,7,2,22, -249,22,184,7,23,203,2,37,2,22,248,22,156,13,23,198,2,87,95,23,195, -1,23,193,1,27,28,248,22,179,7,23,200,2,249,22,184,7,23,201,2,38, -249,80,158,47,52,23,197,2,5,0,27,28,248,22,179,7,23,201,2,249,22, -184,7,23,202,2,39,248,22,170,4,23,200,2,27,27,250,22,138,2,80,158, -51,42,248,22,141,14,247,22,182,11,11,28,23,193,2,192,87,94,23,193,1, -27,247,22,122,87,94,250,22,136,2,80,158,52,42,248,22,141,14,247,22,182, -11,195,192,87,95,28,23,209,1,27,250,22,138,2,23,197,2,197,11,28,23, -193,1,12,87,95,27,27,28,248,22,17,80,158,51,45,80,158,50,45,247,22, -19,250,22,25,248,22,23,23,197,2,80,158,53,44,23,196,1,27,248,22,141, -14,247,22,182,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,9, -226,12,11,2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,158,50, -45,32,0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162,43,35, -50,9,227,14,9,8,4,3,33,48,250,22,136,2,23,197,1,197,10,12,28, -28,248,22,179,7,23,202,1,11,27,248,22,157,6,23,208,2,28,192,192,28, -248,22,62,23,208,2,249,22,162,8,248,22,65,23,210,2,2,21,11,250,22, -136,2,80,158,50,43,28,248,22,157,6,23,210,2,249,22,64,23,211,1,248, -80,159,53,55,36,23,213,1,87,94,23,210,1,249,22,64,23,211,1,247,22, -176,13,252,22,181,7,23,208,1,23,207,1,23,205,1,23,203,1,201,12,193, -91,159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,38,20,96,96, -2,20,89,162,8,44,36,50,9,224,2,0,33,42,89,162,43,38,48,9,223, -1,33,43,89,162,43,39,8,30,9,225,2,3,0,33,49,208,87,95,248,22, -150,4,248,80,158,37,49,247,22,182,11,248,22,188,4,80,158,36,36,248,22, -173,12,80,159,36,41,36,159,35,20,103,159,35,16,1,65,98,101,103,105,110, -16,0,83,158,41,20,100,138,66,35,37,98,111,111,116,2,1,11,11,10,10, -36,80,158,35,35,20,103,159,39,16,19,30,2,1,2,2,193,30,2,1,2, -3,193,30,2,5,72,112,97,116,104,45,115,116,114,105,110,103,63,10,30,2, -5,75,112,97,116,104,45,97,100,100,45,115,117,102,102,105,120,7,30,2,6, -1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101, -121,4,30,2,6,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116, -101,114,105,122,97,116,105,111,110,3,30,2,1,2,7,193,30,2,1,2,8, -193,30,2,1,2,9,193,30,2,1,2,10,193,30,2,1,2,11,193,30,2, -1,2,12,193,30,2,1,2,13,193,30,2,1,2,14,193,30,2,1,2,15, -193,30,2,5,69,45,102,105,110,100,45,99,111,108,0,30,2,5,76,110,111, -114,109,97,108,45,99,97,115,101,45,112,97,116,104,6,30,2,5,79,112,97, -116,104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,9,30,2,1, -2,16,193,16,0,11,11,16,11,2,10,2,11,2,8,2,9,2,12,2,13, -2,3,2,7,2,2,2,15,2,14,46,11,38,35,11,11,16,1,2,16,16, -1,11,16,1,2,16,36,36,36,11,11,16,0,16,0,16,0,35,35,11,11, -11,16,0,16,0,16,0,35,35,16,0,16,16,83,158,35,16,2,89,162,43, -36,44,9,223,0,33,23,80,159,35,57,36,83,158,35,16,2,89,162,43,36, -44,9,223,0,33,24,80,159,35,56,36,83,158,35,16,2,89,162,43,36,48, -67,103,101,116,45,100,105,114,223,0,33,25,80,159,35,55,36,83,158,35,16, -2,89,162,43,37,48,68,119,105,116,104,45,100,105,114,223,0,33,26,80,159, -35,54,36,83,158,35,16,2,248,22,176,7,69,115,111,45,115,117,102,102,105, -120,80,159,35,35,36,83,158,35,16,2,89,162,43,37,59,2,3,223,0,33, -35,80,159,35,36,36,83,158,35,16,2,32,0,89,162,8,44,36,41,2,7, -222,192,80,159,35,41,36,83,158,35,16,2,247,22,125,80,159,35,42,36,83, -158,35,16,2,247,22,124,80,159,35,43,36,83,158,35,16,2,247,22,60,80, -159,35,44,36,83,158,35,16,2,248,22,18,74,109,111,100,117,108,101,45,108, -111,97,100,105,110,103,80,159,35,45,36,83,158,35,16,2,11,80,158,35,46, -83,158,35,16,2,11,80,158,35,47,83,158,35,16,2,32,0,89,162,43,37, -44,2,14,222,33,41,80,159,35,48,36,83,158,35,16,2,89,162,8,44,36, -44,2,15,223,0,33,50,80,159,35,49,36,83,158,35,16,2,89,162,43,35, -43,2,16,223,0,33,51,80,159,35,53,36,95,29,94,2,4,68,35,37,107, -101,114,110,101,108,11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11, -2,5,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 4122); +40,11,247,22,177,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,28, +27,89,162,43,36,51,9,225,8,6,4,33,29,27,249,22,5,89,162,8,44, +36,46,9,223,5,33,30,23,203,2,27,28,23,195,1,27,249,22,5,89,162, +8,44,36,52,9,225,13,11,9,33,31,23,205,2,27,28,23,196,2,11,193, +28,192,192,28,193,28,23,196,2,28,249,22,166,3,248,22,66,196,248,22,66, +23,199,2,193,11,11,11,11,28,23,193,2,249,80,159,47,54,36,202,89,162, +43,35,45,9,224,14,2,33,32,87,94,23,193,1,27,28,23,197,1,27,249, +22,5,83,158,39,20,97,94,89,162,8,44,36,50,9,225,14,12,10,33,33, +23,203,1,23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28,249,22, +166,3,248,22,66,196,248,22,66,199,193,11,11,11,11,28,192,249,80,159,48, +54,36,203,89,162,43,35,45,9,224,15,2,33,34,249,80,159,48,54,36,203, +89,162,43,35,44,9,224,15,7,33,35,32,37,89,162,8,44,36,54,2,20, +222,33,39,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36, +34,27,249,22,185,13,2,38,23,196,2,28,23,193,2,87,94,23,194,1,249, +22,64,248,22,89,23,196,2,27,248,22,98,23,197,1,27,249,22,185,13,2, +38,23,196,2,28,23,193,2,87,94,23,194,1,249,22,64,248,22,89,23,196, +2,27,248,22,98,23,197,1,27,249,22,185,13,2,38,23,196,2,28,23,193, +2,87,94,23,194,1,249,22,64,248,22,89,23,196,2,248,2,37,248,22,98, +23,197,1,248,22,74,194,248,22,74,194,248,22,74,194,32,40,89,162,43,36, +54,2,20,222,33,41,28,248,22,72,248,22,66,23,195,2,249,22,7,9,248, +22,65,195,91,159,37,11,90,161,37,35,11,27,248,22,66,23,197,2,28,248, +22,72,248,22,66,23,195,2,249,22,7,9,248,22,65,195,91,159,37,11,90, +161,37,35,11,27,248,22,66,23,197,2,28,248,22,72,248,22,66,23,195,2, +249,22,7,9,248,22,65,195,91,159,37,11,90,161,37,35,11,248,2,40,248, +22,66,23,197,2,249,22,7,249,22,64,248,22,65,23,200,1,23,197,1,195, +249,22,7,249,22,64,248,22,65,23,200,1,23,197,1,195,249,22,7,249,22, +64,248,22,65,23,200,1,23,197,1,195,27,248,2,37,23,195,1,28,194,192, +248,2,40,193,87,95,28,248,22,169,4,195,12,250,22,128,9,2,21,6,20, +20,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104, +197,28,24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,138, +2,80,158,41,42,248,22,141,14,247,22,182,11,11,28,23,193,2,192,87,94, +23,193,1,27,247,22,122,87,94,250,22,136,2,80,158,42,42,248,22,141,14, +247,22,182,11,195,192,250,22,136,2,195,198,66,97,116,116,97,99,104,251,211, +197,198,199,10,28,192,250,22,191,8,11,196,195,248,22,189,8,194,28,249,22, +163,6,194,6,1,1,46,2,17,28,249,22,163,6,194,6,2,2,46,46,62, +117,112,192,28,249,22,164,8,248,22,66,23,200,2,23,197,1,28,249,22,162, +8,248,22,65,23,200,2,23,196,1,251,22,189,8,2,21,6,26,26,99,121, +99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116,32,126,101,58, +32,126,101,23,200,1,249,22,2,22,66,248,22,79,249,22,64,23,206,1,23, +202,1,12,12,247,192,20,14,159,80,158,39,44,249,22,64,248,22,141,14,247, +22,182,11,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,249,22,27, +11,80,158,44,39,22,151,4,23,196,1,249,247,22,188,4,23,198,1,248,22, +53,248,22,139,13,23,198,1,87,94,28,28,248,22,135,13,23,197,2,10,248, +22,175,4,23,197,2,12,28,23,198,2,250,22,191,8,11,6,15,15,98,97, +100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2,250,22,128,9,2, +21,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114,32,112,97, +116,104,23,199,2,28,28,248,22,62,23,197,2,249,22,162,8,248,22,65,23, +199,2,2,4,11,248,22,170,4,248,22,89,197,28,28,248,22,62,23,197,2, +249,22,162,8,248,22,65,23,199,2,66,112,108,97,110,101,116,11,87,94,28, +207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22,27,11,80,158,42, +39,22,182,11,23,197,1,90,161,36,35,10,249,22,152,4,21,94,2,22,6, +18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101,114,46,115,115,1, +27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110,97,109,101,45,114, +101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94,23,193,1,27,89, +162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101,99,116,105,111,110, +45,101,114,114,223,6,33,45,27,28,248,22,52,23,199,2,27,250,22,138,2, +80,158,43,43,249,22,64,23,204,2,247,22,176,13,11,28,23,193,2,192,87, +94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,44,48,36,248,22, +55,23,204,2,11,27,251,80,158,47,50,2,21,23,202,1,28,248,22,72,23, +199,2,23,199,2,248,22,65,23,199,2,28,248,22,72,23,199,2,9,248,22, +66,23,199,2,249,22,153,13,23,195,1,28,248,22,72,23,197,1,87,94,23, +197,1,6,7,7,109,97,105,110,46,115,115,249,22,180,6,23,199,1,6,3, +3,46,115,115,28,248,22,157,6,23,199,2,87,94,23,194,1,27,248,80,159, +41,55,36,23,201,2,27,250,22,138,2,80,158,44,43,249,22,64,23,205,2, +23,199,2,11,28,23,193,2,192,87,94,23,193,1,91,159,37,11,90,161,37, +35,11,249,80,159,45,48,36,23,204,2,11,250,22,1,22,153,13,23,199,1, +249,22,78,249,22,2,32,0,89,162,8,44,36,43,9,222,33,46,23,200,1, +248,22,74,23,200,1,28,248,22,135,13,23,199,2,87,94,23,194,1,28,248, +22,158,13,23,199,2,23,198,2,248,22,74,6,26,26,32,40,97,32,112,97, +116,104,32,109,117,115,116,32,98,101,32,97,98,115,111,108,117,116,101,41,28, +249,22,162,8,248,22,65,23,201,2,2,22,27,250,22,138,2,80,158,43,43, +249,22,64,23,204,2,247,22,176,13,11,28,23,193,2,192,87,94,23,193,1, +91,159,38,11,90,161,37,35,11,249,80,159,45,48,36,248,22,89,23,205,2, +11,90,161,36,37,11,28,248,22,72,248,22,91,23,204,2,28,248,22,72,23, +194,2,249,22,187,13,0,8,35,114,120,34,91,46,93,34,23,196,2,11,10, +27,27,28,23,197,2,249,22,78,28,248,22,72,248,22,91,23,208,2,21,93, +6,5,5,109,122,108,105,98,249,22,1,22,78,249,22,2,80,159,51,56,36, +248,22,91,23,211,2,23,197,2,28,248,22,72,23,196,2,248,22,74,23,197, +2,23,195,2,251,80,158,49,50,2,21,23,204,1,248,22,65,23,198,2,248, +22,66,23,198,1,249,22,153,13,23,195,1,28,23,198,1,87,94,23,196,1, +23,197,1,28,248,22,72,23,197,1,87,94,23,197,1,6,7,7,109,97,105, +110,46,115,115,28,249,22,187,13,0,8,35,114,120,34,91,46,93,34,23,199, +2,23,197,1,249,22,180,6,23,199,1,6,3,3,46,115,115,28,249,22,162, +8,248,22,65,23,201,2,64,102,105,108,101,249,22,160,13,248,22,164,13,248, +22,89,23,202,2,248,80,159,42,55,36,23,202,2,12,87,94,28,28,248,22, +135,13,23,194,2,10,248,22,179,7,23,194,2,87,94,23,200,1,12,28,23, +200,2,250,22,191,8,67,114,101,113,117,105,114,101,249,22,141,7,6,17,17, +98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2, +248,22,65,23,199,2,6,0,0,23,203,1,87,94,23,200,1,250,22,128,9, +2,21,249,22,141,7,6,13,13,109,111,100,117,108,101,32,112,97,116,104,126, +97,28,23,198,2,248,22,65,23,199,2,6,0,0,23,201,2,27,28,248,22, +179,7,23,195,2,249,22,184,7,23,196,2,35,249,22,162,13,248,22,163,13, +23,197,2,11,27,28,248,22,179,7,23,196,2,249,22,184,7,23,197,2,36, +248,80,158,42,51,23,195,2,91,159,38,11,90,161,38,35,11,28,248,22,179, +7,23,199,2,250,22,7,2,23,249,22,184,7,23,203,2,37,2,23,248,22, +156,13,23,198,2,87,95,23,195,1,23,193,1,27,28,248,22,179,7,23,200, +2,249,22,184,7,23,201,2,38,249,80,158,47,52,23,197,2,5,0,27,28, +248,22,179,7,23,201,2,249,22,184,7,23,202,2,39,248,22,170,4,23,200, +2,27,27,250,22,138,2,80,158,51,42,248,22,141,14,247,22,182,11,11,28, +23,193,2,192,87,94,23,193,1,27,247,22,122,87,94,250,22,136,2,80,158, +52,42,248,22,141,14,247,22,182,11,195,192,87,95,28,23,209,1,27,250,22, +138,2,23,197,2,197,11,28,23,193,1,12,87,95,27,27,28,248,22,17,80, +158,51,45,80,158,50,45,247,22,19,250,22,25,248,22,23,23,197,2,80,158, +53,44,23,196,1,27,248,22,141,14,247,22,182,11,249,22,3,83,158,39,20, +97,94,89,162,8,44,36,54,9,226,12,11,2,3,33,47,23,195,1,23,196, +1,248,28,248,22,17,80,158,50,45,32,0,89,162,43,36,41,9,222,33,48, +80,159,49,57,36,89,162,43,35,50,9,227,14,9,8,4,3,33,49,250,22, +136,2,23,197,1,197,10,12,28,28,248,22,179,7,23,202,1,11,27,248,22, +157,6,23,208,2,28,192,192,28,248,22,62,23,208,2,249,22,162,8,248,22, +65,23,210,2,2,22,11,250,22,136,2,80,158,50,43,28,248,22,157,6,23, +210,2,249,22,64,23,211,1,248,80,159,53,55,36,23,213,1,87,94,23,210, +1,249,22,64,23,211,1,247,22,176,13,252,22,181,7,23,208,1,23,207,1, +23,205,1,23,203,1,201,12,193,91,159,37,10,90,161,36,35,10,11,90,161, +36,36,10,83,158,38,20,96,96,2,21,89,162,8,44,36,50,9,224,2,0, +33,43,89,162,43,38,48,9,223,1,33,44,89,162,43,39,8,30,9,225,2, +3,0,33,50,208,87,95,248,22,150,4,248,80,158,37,49,247,22,182,11,248, +22,188,4,80,158,36,36,248,22,173,12,80,159,36,41,36,159,35,20,103,159, +35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,138,66,35,37,98, +111,111,116,2,1,11,11,10,10,36,80,158,35,35,20,103,159,39,16,19,30, +2,1,2,2,193,30,2,1,2,3,193,30,2,5,72,112,97,116,104,45,115, +116,114,105,110,103,63,10,30,2,5,75,112,97,116,104,45,97,100,100,45,115, +117,102,102,105,120,7,30,2,6,1,20,112,97,114,97,109,101,116,101,114,105, +122,97,116,105,111,110,45,107,101,121,4,30,2,6,1,23,101,120,116,101,110, +100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,30,2, +1,2,7,193,30,2,1,2,8,193,30,2,1,2,9,193,30,2,1,2,10, +193,30,2,1,2,11,193,30,2,1,2,12,193,30,2,1,2,13,193,30,2, +1,2,14,193,30,2,1,2,15,193,30,2,5,69,45,102,105,110,100,45,99, +111,108,0,30,2,5,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97, +116,104,6,30,2,5,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115, +117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,11,2,10,2, +11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,14,46,11, +38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36,36,11,11,16, +0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16, +16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,159,35,57,36, +83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159,35,56,36,83, +158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,223,0,33,26, +80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,105,116,104,45, +100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2,248,22,176,7, +69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,35,16,2,89, +162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158,35,16,2,32, +0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83,158,35,16,2, +247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80,159,35,43,36, +83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16,2,248,22,18, +74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,35,45,36,83, +158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,35,47,83,158, +35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159,35,48,36,83, +158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80,159,35,49,36, +83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80,159,35,53,36, +95,29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94,2,4,69,35, +37,109,105,110,45,115,116,120,11,2,5,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 4131); } diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 7c64c50239..75bcbcd3b0 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -96,6 +96,9 @@ static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]); static Scheme_Object *local_context(int argc, Scheme_Object *argv[]); static Scheme_Object *local_phase_level(int argc, Scheme_Object *argv[]); static Scheme_Object *local_make_intdef_context(int argc, Scheme_Object *argv[]); +static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]); +static Scheme_Object *intdef_context_p(int argc, Scheme_Object *argv[]); +static Scheme_Object *id_intdef_remove(int argc, Scheme_Object *argv[]); static Scheme_Object *local_introduce(int argc, Scheme_Object *argv[]); static Scheme_Object *local_module_introduce(int argc, Scheme_Object *argv[]); static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]); @@ -108,6 +111,7 @@ static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]); static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]); static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]); static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]); +static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]); static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]); static Scheme_Object *set_transformer_p(int argc, Scheme_Object *argv[]); static Scheme_Object *set_transformer_proc(int argc, Scheme_Object *argv[]); @@ -510,10 +514,15 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-make-definition-context", local_make_intdef_context, 0, 0, env); + GLOBAL_PRIM_W_ARITY("internal-definition-context-seal", intdef_context_seal, 1, 1, env); + GLOBAL_PRIM_W_ARITY("internal-definition-context?", intdef_context_p, 1, 1, env); + GLOBAL_PRIM_W_ARITY("identifier-remove-from-definition-context", id_intdef_remove, 2, 2, env); GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 1, env); GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env); GLOBAL_PRIM_W_ARITY("make-syntax-introducer", make_introducer, 0, 1, env); + GLOBAL_PRIM_W_ARITY("syntax-local-make-delta-introducer", local_make_delta_introduce, 1, 1, env); GLOBAL_PRIM_W_ARITY("syntax-local-certifier", local_certify, 0, 1, env); + GLOBAL_PRIM_W_ARITY("syntax-local-module-exports", local_module_exports, 1, 1, env); GLOBAL_PRIM_W_ARITY("syntax-local-module-defined-identifiers", local_module_definitions, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-module-required-identifiers", local_module_imports, 2, 2, env); @@ -523,7 +532,7 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("set!-transformer?", set_transformer_p, 1, 1, env); GLOBAL_PRIM_W_ARITY("set!-transformer-procedure", set_transformer_proc, 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 1, env); + GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 2, env); GLOBAL_PRIM_W_ARITY("rename-transformer?", rename_transformer_p, 1, 1, env); GLOBAL_PRIM_W_ARITY("rename-transformer-target", rename_transformer_target, 1, 1, env); @@ -2525,6 +2534,17 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, } } + if (_lexical_binding_id) { + if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) + val = scheme_stx_remove_extra_marks(find_id, COMPILE_DATA(frame)->const_names[i], + ((frame->flags & SCHEME_CAPTURE_LIFTED) + ? NULL + : uid)); + else + val = find_id; + *_lexical_binding_id = val; + } + val = COMPILE_DATA(frame)->const_vals[i]; if (!val) { @@ -4230,6 +4250,38 @@ local_make_intdef_context(int argc, Scheme_Object *argv[]) return c; } +static Scheme_Object * +intdef_context_p(int argc, Scheme_Object *argv[]) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type) + ? scheme_true + : scheme_false); +} + +static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type)) + scheme_wrong_type("internal-definition-context-seal", + "internal-definition context", 0, argc, argv); + + scheme_stx_seal_rib(SCHEME_PTR2_VAL(argv[0])); + return scheme_void; +} + +static Scheme_Object * +id_intdef_remove(int argc, Scheme_Object *argv[]) +{ + if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) + scheme_wrong_type("identifier-from-from-definition-context", + "syntax identifier", 0, argc, argv); + + if (!SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_intdef_context_type)) + scheme_wrong_type("identifier-remove-from-definition-context", + "internal-definition context", 1, argc, argv); + + return scheme_stx_id_remove_rib(argv[0], SCHEME_PTR2_VAL(argv[1])); +} + static Scheme_Object * local_introduce(int argc, Scheme_Object *argv[]) { @@ -4332,7 +4384,7 @@ local_get_shadower(int argc, Scheme_Object *argv[]) SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) { esym = COMPILE_DATA(frame)->const_names[i]; env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { + if (1 || scheme_equal(env_marks, sym_marks)) { sym = esym; if (COMPILE_DATA(frame)->const_uids) { uid = COMPILE_DATA(frame)->const_uids[i]; @@ -4348,9 +4400,9 @@ local_get_shadower(int argc, Scheme_Object *argv[]) } if (!uid) { - /* No lexical shadower, but strip module context and mark barriers, if any. */ + /* No lexical shadower, but strip module context, if any */ sym = scheme_stx_strip_module_context(sym); - /* Add current module context, if any. */ + /* Add current module context, if any */ sym = local_module_introduce(1, &sym); return sym; } @@ -4364,7 +4416,9 @@ local_get_shadower(int argc, Scheme_Object *argv[]) rn = scheme_make_rename(uid, 1); scheme_set_rename(rn, 0, result); - return scheme_add_rename(result, rn); + result = scheme_add_rename(result, rn); + + return result; } } @@ -4391,6 +4445,115 @@ make_introducer(int argc, Scheme_Object *argv[]) "syntax-introducer", 1, 1); } +static Scheme_Object * +delta_introducer_proc(void *_i_plus_m, int argc, Scheme_Object *argv[]) +{ + Scheme_Object *p = (Scheme_Object *)_i_plus_m, *l, *v, *a[1]; + const char *who = "delta introducer attached to a rename transformer"; + + v = argv[0]; + if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) { + scheme_wrong_type(who, "identifier", 0, argc, argv); + } + + /* Apply mapping functions: */ + l = SCHEME_CDR(p); + while (SCHEME_PAIRP(l)) { + a[0] = v; + v = _scheme_apply(SCHEME_CAR(l), 1, a); + l = SCHEME_CDR(l); + } + + /* Apply delta-introducing functions: */ + l = SCHEME_CAR(p); + while (SCHEME_PAIRP(l)) { + a[0] = v; + v = _scheme_apply(SCHEME_CAR(l), 1, a); + if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) { + a[0] = v; + scheme_wrong_type(who, "identifier", -1, -1, a); + } + l = SCHEME_CDR(l); + } + + return v; +} + +static Scheme_Object * +local_make_delta_introduce(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *sym, *binder, *introducer, *a[2], *v; + Scheme_Object *introducers = scheme_null, *mappers = scheme_null; + int renamed = 0; + Scheme_Comp_Env *env; + + env = scheme_current_thread->current_local_env; + if (!env) + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "syntax-local-make-delta-introducer: not currently transforming"); + + if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) + scheme_wrong_type("syntax-local-make-delta-introducer", "syntax identifier", 0, argc, argv); + + sym = argv[0]; + + sym = scheme_stx_activate_certs(sym); + + while (1) { + binder = NULL; + + v = scheme_lookup_binding(sym, env, + (SCHEME_NULL_FOR_UNBOUND + + SCHEME_RESOLVE_MODIDS + + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK + + SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST), + scheme_current_thread->current_local_certs, + scheme_current_thread->current_local_modidx, + NULL, NULL, &binder); + + /* Deref globals */ + if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) + v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val; + + if (!v || NOT_SAME_TYPE(SCHEME_TYPE(v), scheme_macro_type)) { + scheme_arg_mismatch("syntax-local-make-delta-introducer", + (renamed + ? "not defined as syntax (after renaming): " + : "not defined as syntax: "), + argv[0]); + } + + if (!binder) { + /* Not a lexical biding, so use empty id */ + binder = scheme_datum_to_syntax(scheme_intern_symbol("no-binder"), + scheme_false, scheme_false, 1, 0); + } + + a[0] = sym; + a[1] = binder; + introducer = scheme_syntax_make_transfer_intro(2, a); + introducers = scheme_make_pair(introducer, introducers); + + v = SCHEME_PTR_VAL(v); + if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) { + sym = SCHEME_PTR1_VAL(v); + + v = SCHEME_PTR2_VAL(v); + if (!SCHEME_FALSEP(v)) + mappers = scheme_make_pair(v, mappers); + + renamed = 1; + SCHEME_USE_FUEL(1); + } else { + /* that's the end of the chain */ + mappers = scheme_reverse(mappers); + return scheme_make_closed_prim_w_arity(delta_introducer_proc, + scheme_make_pair(introducers, mappers), + "syntax-delta-introducer", 1, 1); + } + } +} + static Scheme_Object * certifier(void *_data, int argc, Scheme_Object **argv) { @@ -4689,9 +4852,13 @@ make_rename_transformer(int argc, Scheme_Object *argv[]) if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) scheme_wrong_type("make-rename-transformer", "syntax identifier", 0, argc, argv); - v = scheme_alloc_small_object(); + if (argc > 1) + scheme_check_proc_arity("make-rename-transformer", 1, 1, argc, argv); + + v = scheme_alloc_object(); v->type = scheme_id_macro_type; - SCHEME_PTR_VAL(v) = argv[0]; + SCHEME_PTR1_VAL(v) = argv[0]; + SCHEME_PTR2_VAL(v) = ((argc > 1) ? argv[1] : scheme_false); return v; } diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index ad1973066c..859f21deea 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -6453,6 +6453,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, if (!more) { /* We've converted to a letrec or letrec-values+syntaxes */ + scheme_stx_seal_rib(rib); rec[drec].env_already = 1; if (rec[drec].comp) { @@ -6473,6 +6474,8 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, } } + scheme_stx_seal_rib(rib); + if (rec[drec].comp) { Scheme_Object *vname, *rest; @@ -9535,6 +9538,11 @@ local_eval(int argc, Scheme_Object **argv) stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]); rib = SCHEME_PTR2_VAL(argv[2]); + + if (scheme_stx_is_rib_sealed(rib)) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-bind-syntaxes: given " + "internal-definition context has been sealed"); + } if (!scheme_is_sub_env(stx_env, env)) { scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-bind-syntaxes: transforming context does " diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index df3bae8b96..d6f5546903 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -5184,6 +5184,8 @@ static int lex_rib_SIZE(void *p) { static int lex_rib_MARK(void *p) { Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)p; gcMARK(rib->rename); + gcMARK(rib->timestamp); + gcMARK(rib->sealed); gcMARK(rib->next); return gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); @@ -5192,6 +5194,8 @@ static int lex_rib_MARK(void *p) { static int lex_rib_FIXUP(void *p) { Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)p; gcFIXUP(rib->rename); + gcFIXUP(rib->timestamp); + gcFIXUP(rib->sealed); gcFIXUP(rib->next); return gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index fcf503e2c0..abf1066285 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -2118,6 +2118,8 @@ lex_rib { mark: Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)p; gcMARK(rib->rename); + gcMARK(rib->timestamp); + gcMARK(rib->sealed); gcMARK(rib->next); size: gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h index 468bba7d2c..40e1023314 100644 --- a/src/mzscheme/src/schminc.h +++ b/src/mzscheme/src/schminc.h @@ -13,7 +13,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 938 +#define EXPECTED_PRIM_COUNT 942 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 8cff95e5c6..6e93798b60 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -720,6 +720,9 @@ void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname); Scheme_Object *scheme_make_rename_rib(void); void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename); void scheme_drop_first_rib_rename(Scheme_Object *ro); +Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro); +void scheme_stx_seal_rib(Scheme_Object *rib); +int scheme_stx_is_rib_sealed(Scheme_Object *rib); Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename); Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib); @@ -727,6 +730,8 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib); Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to, Scheme_Object *uid); +Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv); + #define mzMOD_RENAME_TOPLEVEL 0 #define mzMOD_RENAME_NORMAL 1 #define mzMOD_RENAME_MARKED 2 diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 809edc18dd..d53c03204c 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.3.1" +#define MZSCHEME_VERSION "4.1.3.2" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 1 +#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index e24d1a87dd..6aa53457e7 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -55,7 +55,6 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv); static Scheme_Object *syntax_property(int argc, Scheme_Object **argv); static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv); static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv); static Scheme_Object *bound_eq(int argc, Scheme_Object **argv); static Scheme_Object *module_eq(int argc, Scheme_Object **argv); @@ -198,6 +197,7 @@ typedef struct Scheme_Lexical_Rib { Scheme_Object so; Scheme_Object *rename; /* a vector for a lexical rename */ Scheme_Object *timestamp; + int *sealed; struct Scheme_Lexical_Rib *next; } Scheme_Lexical_Rib; @@ -226,7 +226,7 @@ static Module_Renames *krn; - A wrap-elem (vector ... ...) is also a lexical rename var resolved where the variables have already been resolved and filtered (no mark - comparison needed with the remaining wraps) + or lexical-env comparison needed with the remaining wraps) - A wrap-elem (make-rib vector rib) is an extensible set of lexical renames; it is the same as @@ -454,9 +454,9 @@ void scheme_init_stx(Scheme_Env *env) env); scheme_add_global_constant("make-syntax-delta-introducer", - scheme_make_immed_prim(syntax_transfer_intro, + scheme_make_immed_prim(scheme_syntax_make_transfer_intro, "make-syntax-delta-introducer", - 2, 2), + 2, 3), env); scheme_add_global_constant("bound-identifier=?", @@ -1038,11 +1038,16 @@ void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname) Scheme_Object *scheme_make_rename_rib() { Scheme_Lexical_Rib *rib; + int *sealed; rib = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); rib->so.type = scheme_lexical_rib_type; rib->timestamp = current_rib_timestamp; + sealed = (int *)scheme_malloc_atomic(sizeof(int)); + *sealed = 0; + rib->sealed = sealed; + current_rib_timestamp = scheme_add1(1, ¤t_rib_timestamp); return (Scheme_Object *)rib; @@ -1061,6 +1066,7 @@ void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename) rib->next = naya; naya->timestamp = rib->timestamp; + naya->sealed = rib->sealed; } void scheme_drop_first_rib_rename(Scheme_Object *ro) @@ -1069,6 +1075,68 @@ void scheme_drop_first_rib_rename(Scheme_Object *ro) rib->next = rib->next->next; } +void scheme_stx_seal_rib(Scheme_Object *rib) +{ + *((Scheme_Lexical_Rib *)rib)->sealed = 1; +} + +int scheme_stx_is_rib_sealed(Scheme_Object *rib) +{ + return *((Scheme_Lexical_Rib *)rib)->sealed; +} + +Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro) +{ + Scheme_Object *v; + int count = 0, rib_count = 0; + WRAP_POS awl; + Wrap_Chunk *wc; + Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro, *rib2; + + WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); + while (!WRAP_POS_END_P(awl)) { + count++; + v = WRAP_POS_FIRST(awl); + if (SCHEME_RIBP(v)) { + rib2 = (Scheme_Lexical_Rib *)v; + if (SAME_OBJ(rib2->timestamp, rib->timestamp)) + rib_count++; + } + WRAP_POS_INC(awl); + } + + if (!rib_count) + return stx; + + count -= rib_count; + + wc = MALLOC_WRAP_CHUNK(count); + wc->type = scheme_wrap_chunk_type; + wc->len = count; + + count = 0; + WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); + while (!WRAP_POS_END_P(awl)) { + v = WRAP_POS_FIRST(awl); + if (SCHEME_RIBP(v)) { + rib2 = (Scheme_Lexical_Rib *)v; + if (SAME_OBJ(rib2->timestamp, rib->timestamp)) + v = NULL; + } + if (v) { + wc->a[count++] = v; + } + WRAP_POS_INC(awl); + } + + v = scheme_make_pair((Scheme_Object *)wc, scheme_null); + + stx = scheme_add_rename(stx, scheme_make_integer(0)); + ((Scheme_Stx *)stx)->wraps = v; + + return stx; +} + /******************** module renames ********************/ static int same_phase(Scheme_Object *a, Scheme_Object *b) @@ -3363,7 +3431,8 @@ static int explain_resolves = 0; static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *a, Scheme_Object *orig_phase, int w_mod, Scheme_Object **get_names, - Scheme_Object *skip_ribs, int *_binding_marks_skipped) + Scheme_Object *skip_ribs, int *_binding_marks_skipped, + int *_depends_on_unsealed_rib, int depth) /* Module binding ignored if w_mod is 0. If module bound, result is module idx, and get_names[0] is set to source name, get_names[1] is set to the nominal source module, get_names[2] is set to @@ -3385,9 +3454,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Hash_Table *export_registry = NULL; int mresult_skipped = 0; + int depends_on_unsealed_rib = 0; - EXPLAIN(printf("Resolving %s [skips: %s]:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), - scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); + EXPLAIN(fprintf(stderr, "%d Resolving %s [skips: %s]:\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), + scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); if (_wraps) { WRAP_POS_COPY(wraps, *_wraps); @@ -3401,17 +3471,17 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *result, *key; int did_lexical = 0; - EXPLAIN(printf("Rename...\n")); + EXPLAIN(fprintf(stderr, "%d Rename...\n", depth)); result = scheme_false; while (!SCHEME_NULLP(o_rename_stack)) { key = SCHEME_CAAR(o_rename_stack); if (SAME_OBJ(key, result)) { - EXPLAIN(printf("Match %s\n", scheme_write_to_string(key, 0))); + EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); did_lexical = 1; result = SCHEME_CDR(SCHEME_CAR(o_rename_stack)); } else { - EXPLAIN(printf("No match %s\n", scheme_write_to_string(key, 0))); + EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); if (SAME_OBJ(key, scheme_true)) { /* marks a module-level renaming that overrides lexical renaming */ did_lexical = 0; @@ -3422,11 +3492,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, while (stack_pos) { key = rename_stack[stack_pos - 1]; if (SAME_OBJ(key, result)) { - EXPLAIN(printf("Match %s\n", scheme_write_to_string(key, 0))); + EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); result = rename_stack[stack_pos - 2]; did_lexical = 1; } else { - EXPLAIN(printf("No match %s\n", scheme_write_to_string(key, 0))); + EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); if (SAME_OBJ(key, scheme_true)) { /* marks a module-level renaming that overrides lexical renaming */ did_lexical = 0; @@ -3441,7 +3511,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else if (get_names) get_names[0] = scheme_undefined; - EXPLAIN(printf("Result: %s\n", scheme_write_to_string(result, 0))); + if (_depends_on_unsealed_rib) + *_depends_on_unsealed_rib = depends_on_unsealed_rib; + + EXPLAIN(fprintf(stderr, "%d Result: %s\n", depth, scheme_write_to_string(result, 0))); return result; } else if ((SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) @@ -3451,7 +3524,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Module_Renames *mrn; int skipped; - EXPLAIN(printf("Rename/set\n")); + EXPLAIN(fprintf(stderr, "%d Rename/set\n", depth)); if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) { mrn = (Module_Renames *)WRAP_POS_FIRST(wraps); @@ -3467,7 +3540,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) && !skip_other_mods) { - EXPLAIN(printf(" use rename %p %d\n", mrn->phase, mrn->kind)); + EXPLAIN(fprintf(stderr, "%d use rename %p %d\n", depth, mrn->phase, mrn->kind)); if (mrn->kind != mzMOD_RENAME_TOPLEVEL) is_in_module = 1; @@ -3482,7 +3555,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (mrn->marked_names) { /* Resolve based on rest of wraps: */ if (!bdg) { - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs, NULL); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs, NULL, NULL, depth+1); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -3509,7 +3582,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, glob_id = SCHEME_STX_VAL(a); } - EXPLAIN(printf(" search %s\n", scheme_write_to_string(glob_id, 0))); + EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0))); rename = scheme_hash_get(mrn->ht, glob_id); if (!rename && mrn->nomarshal_ht) @@ -3525,7 +3598,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, get_names_done = 1; } - EXPLAIN(printf(" search result: %p\n", rename)); + EXPLAIN(fprintf(stderr, "%d search result: %p\n", depth, rename)); if (rename) { if (mrn->kind == mzMOD_RENAME_MARKED) { @@ -3675,6 +3748,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, is_rib = NULL; } + EXPLAIN(fprintf(stderr, "%d lexical rename (%d)\n", depth, is_rib ? 1 : 0)); + c = SCHEME_RENAME_LEN(rename); /* Get index from hash table, if there is one: */ @@ -3711,32 +3786,36 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, other_env = scheme_false; envname = SCHEME_VEC_ELS(rename)[2+c+ri]; same = 1; - EXPLAIN(printf("Targes %s <- %s\n", - scheme_write_to_string(envname, 0), - scheme_write_to_string(other_env, 0))); + no_lexical = 1; /* simplified table always has final result */ + EXPLAIN(fprintf(stderr, "%d Targes %s <- %s\n", depth, + scheme_write_to_string(envname, 0), + scheme_write_to_string(other_env, 0))); } else { envname = SCHEME_VEC_ELS(rename)[0]; other_env = SCHEME_VEC_ELS(rename)[2+c+ri]; if (SCHEME_VOIDP(other_env)) { + int rib_dep = 0; SCHEME_USE_FUEL(1); - other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL); - if (!is_rib) + other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1); + if (!is_rib && !rib_dep) SCHEME_VEC_ELS(rename)[2+c+ri] = other_env; + if (rib_dep) + depends_on_unsealed_rib = 1; SCHEME_USE_FUEL(1); } - EXPLAIN(printf("Target %s <- %s (%d)\n", - scheme_write_to_string(envname, 0), - scheme_write_to_string(other_env, 0), - nom_mod_p(rename))); + EXPLAIN(fprintf(stderr, "%d Target %s <- %s (%d)\n", depth, + scheme_write_to_string(envname, 0), + scheme_write_to_string(other_env, 0), + nom_mod_p(rename))); { WRAP_POS w2; WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps); same = same_marks(&w2, &wraps, other_env); if (!same) - EXPLAIN(printf("Different marks\n")); + EXPLAIN(fprintf(stderr, "%d Different marks\n", depth)); } } @@ -3755,8 +3834,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, o_rename_stack); } if (is_rib) { - /* skip rest of rib (if any) and future instances of the same rib */ - rib = NULL; + /* skip future instances of the same rib; + used to skip the rest of the current rib, too, but + that's wrong in the case that the same symbolic + name with multiple binding contexts is re-bound + in a rib */ skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs); } } @@ -3768,17 +3850,17 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps)) && !no_lexical) { /* Lexical-rename rib. Splice in the names. */ rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps); - EXPLAIN(printf("Rib: %p...\n", rib)); + EXPLAIN(fprintf(stderr, "%d Rib: %p...\n", depth, rib)); if (skip_ribs) { if (in_skip_set(rib->timestamp, skip_ribs)) { - EXPLAIN(printf("Skip rib\n")); + EXPLAIN(fprintf(stderr, "%d Skip rib\n", depth)); rib = NULL; } } if (rib) { if (nonempty_rib(rib)) { if (SAME_OBJ(did_rib, rib)) { - EXPLAIN(printf("Did rib\n")); + EXPLAIN(fprintf(stderr, "%d Did rib\n", depth)); rib = NULL; } else { recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs); @@ -3789,6 +3871,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, rib = NULL; } } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { + EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps))); did_rib = NULL; } else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) { Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps); @@ -3883,13 +3966,13 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (mrn->needs_unmarshal) { /* Use resolve_env to trigger unmarshal, so that we don't have to implement top/from shifts here: */ - resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL); + resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0); } if (mrn->marked_names) { /* Resolve based on rest of wraps: */ if (!bdg) - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -3969,8 +4052,8 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha if ((a == asym) || (b == bsym)) return 1; - a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL); - b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL); + a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0); + b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0); if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) a = scheme_module_resolve(a, 0); @@ -4012,7 +4095,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, names[4] = NULL; names[5] = NULL; - modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL); + modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, NULL, 0); if (names[0]) { if (SAME_OBJ(names[0], scheme_undefined)) { @@ -4038,12 +4121,12 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, } Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) - /* Returns either NULL or a lexical-rename symbol */ + /* Returns either false, a lexical-rename symbol, or void for "floating" */ { if (SCHEME_STXP(a)) { Scheme_Object *r; - r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL); + r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0); if (SCHEME_FALSEP(r)) r = check_floating_id(a); @@ -4051,7 +4134,7 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) if (r) return r; } - return NULL; + return scheme_false; } int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase) @@ -4075,13 +4158,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u if (!SAME_OBJ(asym, bsym)) return 0; - ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL); + ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0); /* No need to module_resolve ae, because we ignored module renamings. */ if (uid) be = uid; else { - be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL); + be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0); /* No need to module_resolve be, because we ignored module renamings. */ } @@ -4111,7 +4194,7 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) { explain_resolves++; - a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL); + a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0); --explain_resolves; return a; } @@ -4483,13 +4566,30 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist) The wraps->datum tools are also used to simplify syntax object (to minimize the occupied space among a set of objects). */ -static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache) +#define EXPLAIN_SIMP 0 +#if EXPLAIN_SIMP +#define EXPLAIN_S(x) if (explain_simp) x +static int explain_simp = 0; +static void print_skips(Scheme_Object *skips) { - WRAP_POS w; - WRAP_POS prev; - WRAP_POS w2; - Scheme_Object *stack = scheme_null, *key, *old_key, *skip_ribs = scheme_null, *orig_skip_ribs; - Scheme_Object *v, *v2, *v2l, *stx, *name, *svl; + while (skips) { + printf(" skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL)); + skips = SCHEME_CDR(skips); + } +} +#else +#define EXPLAIN_S(x) /* empty */ +#endif + +static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache) +{ + WRAP_POS w, prev, w2; + Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs = NULL, *prev_prec_ribs; + Scheme_Object *ribs_stack = scheme_null; + Scheme_Object *v, *v2, *v2l, *stx, *name, *svl, *end_mutable = NULL; + Scheme_Lexical_Rib *did_rib = NULL; + Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; + int copy_on_write; long size, vsize, psize, i, j, pos; /* Although it makes no sense to simplify the rename table itself, @@ -4497,48 +4597,136 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca (But don't mutate the wrap list, because that will stomp on tables that might be needed by a propoagation.) - A lex_cache maps wrap starts w to simplified tables. A lex_cache - is modified by this function, only, but it's also read in - datum_to_wraps. + A lex_cache maps wrap starts within `w' to lists of simplified + tables. This helps avoid re-simplifying when the result is + clearly going to be the same. A lex_cache is read and modified by + this function, only. - In addition to depending on the rest of the wraps, a - simplification can depend on preceding wraps due to rib - skipping. So the lex_cache maps a wrap to another hash table that - maps a skip list to a simplified rename. */ + In addition to depending on the rest of the wraps, a resolved + binding can depend on preceding wraps due to rib skipping. For + now, simplifications that depend on preceding wraps are not + cached (though individual computed renamings are cached to save + space). + + The simplification stragegy mostly works inside out: since later + renames depend on earlier renames, we simplify the earlier ones + first, and then collapse to a flattened rename while working + outward. This also lets us track shared tails in some common + cases. + + A catch with the inside-out approach has to do with ribs (again). + Preceding ribs determine the recur_skip_ribs set, so we can + simply track that as we recur into the wraps initially to build + our worklist. However, whether we process a rib at all (on the + way out in the second pass) for a given id depends on whether any + preceding instance of the same rib (i.e., further out) matches + the symbol and marks. So, we have to compute that summary as we + go in. */ WRAP_POS_INIT(w, wraps); WRAP_POS_INIT_END(prev); old_key = NULL; + v2l = scheme_null; + while (!WRAP_POS_END_P(w)) { if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) || SCHEME_RIBP(WRAP_POS_FIRST(w))) { /* Lexical rename */ key = WRAP_POS_KEY(w); if (!SAME_OBJ(key, old_key)) { - v = scheme_hash_get(lex_cache, key); - if (v) - v = scheme_hash_get((Scheme_Hash_Table *)v, skip_ribs); + if (!prec_ribs) + v = scheme_hash_get(lex_cache, key); + else + v = NULL; } else v = NULL; old_key = key; - orig_skip_ribs = skip_ribs; + prev_prec_ribs = prec_ribs; + prev_skip_ribs_ht = skip_ribs_ht; if (v) { /* Tables here are already simplified. */ - WRAP_POS_COPY(prev, w); + v2l = v; /* build on simplify chain extracted from cache */ + end_mutable = v2l; /* No non-simplified table can follow a simplified one */ break; } else { - int add = 0; + int add = 0, skip_this = 0; v = WRAP_POS_FIRST(w); if (SCHEME_RIBP(v)) { /* A rib certainly isn't simplified yet. */ - add = 1; - if (nonempty_rib((Scheme_Lexical_Rib *)v)) - skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)v)->timestamp, skip_ribs); + Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)v; + add = 1; + if (SAME_OBJ(did_rib, rib) + || !nonempty_rib(rib)) { + skip_this = 1; + EXPLAIN_S(fprintf(stderr, " to skip %p=%s\n", rib, + scheme_write_to_string(rib->timestamp, NULL))); + } else { + did_rib = rib; + if (!*rib->sealed) { + scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); + return NULL; + } + prec_ribs = add_skip_set(rib->timestamp, prec_ribs); + + EXPLAIN_S(fprintf(stderr, " down rib %p=%s\n", rib, + scheme_write_to_string(rib->timestamp, NULL))); + EXPLAIN_S(print_skips(prec_ribs)); + + copy_on_write = 1; + + /* Compute, per id, whether to skip later instances of rib: */ + for (rib = rib->next; rib; rib = rib->next) { + vsize = SCHEME_RENAME_LEN(rib->rename); + for (i = 0; i < vsize; i++) { + stx = SCHEME_VEC_ELS(rib->rename)[2+i]; + + EXPLAIN_S(fprintf(stderr, " skip? %s %p=%s %s\n", + scheme_write_to_string(SCHEME_STX_VAL(stx), NULL), + rib, + scheme_write_to_string(rib->timestamp, NULL), + scheme_write_to_string(SCHEME_VEC_ELS(rib->rename)[0], NULL))); + + /* already skipped? */ + if (!skip_ribs_ht + || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp))) { + /* No. Should we skip? */ + Scheme_Object *other_env; + other_env = SCHEME_VEC_ELS(rib->rename)[2+vsize+i]; + if (SCHEME_VOIDP(other_env)) { + int rib_dep; + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0); + if (rib_dep) { + scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); + return NULL; + } + SCHEME_VEC_ELS(rib->rename)[2+vsize+i] = other_env; + } + WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); + if (same_marks(&w2, &w, other_env)) { + /* yes, skip */ + EXPLAIN_S(fprintf(stderr, " skip! %s\n", + scheme_write_to_string(SCHEME_STX_VAL(stx), NULL))); + if (!skip_ribs_ht) + skip_ribs_ht = scheme_make_hash_table_equal(); + else if (copy_on_write) + skip_ribs_ht = scheme_clone_hash_table(skip_ribs_ht); + copy_on_write = 0; + scheme_hash_set(skip_ribs_ht, + scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp), + scheme_true); + } + } else { + EXPLAIN_S(fprintf(stderr, " already skipped %s\n", + scheme_write_to_string(SCHEME_STX_VAL(stx), NULL))); + } + } + } + } } else { /* Need to simplify this vector? */ if (SCHEME_VEC_SIZE(v) == 1) @@ -4550,15 +4738,25 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca } if (add) { + if (skip_this) { + ribs_stack = scheme_make_pair(scheme_false, ribs_stack); + } else { + ribs_stack = scheme_make_pair(scheme_make_pair(prec_ribs, + (Scheme_Object *)prev_skip_ribs_ht), + ribs_stack); + } + /* Need to simplify, but do deepest first: */ - if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_CAR(SCHEME_CAR(stack)), key)) { - stack = CONS(CONS(key, orig_skip_ribs), stack); + if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_VEC_ELS(SCHEME_CAR(stack))[0], key)) { + v = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(v)[0] = key; + SCHEME_VEC_ELS(v)[1] = prev_prec_ribs; + stack = CONS(v, stack); } } else { /* This is already simplified. Remember it and stop, because no non-simplified table can follow a simplified one. */ - if (WRAP_POS_END_P(prev)) - WRAP_POS_COPY(prev, w); + WRAP_POS_COPY(prev, w); break; } } @@ -4569,11 +4767,8 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca while (!SCHEME_NULLP(stack)) { key = SCHEME_CAR(stack); - orig_skip_ribs = SCHEME_CDR(key); - key = SCHEME_CAR(key); - v2l = scheme_null; - - skip_ribs = orig_skip_ribs; + prev_prec_ribs = SCHEME_VEC_ELS(key)[1]; + key = SCHEME_VEC_ELS(key)[0]; WRAP_POS_REVINIT(w, key); @@ -4586,22 +4781,43 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2]))) { /* This is the place to simplify: */ Scheme_Lexical_Rib *rib = NULL, *init_rib = NULL; - Scheme_Object *skip_ribs = NULL; - int ii, vvsize; + Scheme_Object *local_ribs; + int ii, vvsize, done_rib_pos = 0; - if (SCHEME_RIBP(v)) { - init_rib = (Scheme_Lexical_Rib *)v; - if (nonempty_rib(init_rib)) - skip_ribs = scheme_make_pair(init_rib->timestamp, skip_ribs); - rib = init_rib->next; + if (SCHEME_FALSEP(SCHEME_CAR(ribs_stack))) { + EXPLAIN_S(fprintf(stderr, " skip rib %p=%s\n", v, + scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL))); + ribs_stack = SCHEME_CDR(ribs_stack); vsize = 0; - while (rib) { - vsize += SCHEME_RENAME_LEN(rib->rename); - rib = rib->next; + } else { + prec_ribs = SCHEME_CAR(SCHEME_CAR(ribs_stack)); + skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CDR(SCHEME_CAR(ribs_stack)); + ribs_stack = SCHEME_CDR(ribs_stack); + + if (SCHEME_RIBP(v)) { + init_rib = (Scheme_Lexical_Rib *)v; + EXPLAIN_S(fprintf(stderr, " up rib %p=%s\n", init_rib, + scheme_write_to_string(init_rib->timestamp, NULL))); + EXPLAIN_S(print_skips(prec_ribs)); + rib = init_rib->next; + vsize = 0; + local_ribs = NULL; + while (rib) { + /* We need to process the renamings in reverse order: */ + local_ribs = scheme_make_raw_pair((Scheme_Object *)rib, local_ribs); + + vsize += SCHEME_RENAME_LEN(rib->rename); + rib = rib->next; + } + if (local_ribs) { + rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs); + local_ribs = SCHEME_CDR(local_ribs); + } + } else { + vsize = SCHEME_RENAME_LEN(v); + local_ribs = NULL; } - rib = init_rib->next; - } else - vsize = SCHEME_RENAME_LEN(v); + } /* Initial size; may shrink: */ size = vsize; @@ -4612,7 +4828,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca /* Local vector (different from i when we have a rib) */ ii = 0; - vvsize= vsize; + vvsize = vsize; for (i = 0; i < vsize; i++) { if (rib) { @@ -4620,7 +4836,9 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca vvsize = SCHEME_RENAME_LEN(v); while (ii >= vvsize) { ii = 0; - rib = rib->next; + done_rib_pos = pos; + rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs); + local_ribs = SCHEME_CDR(local_ribs); v = rib->rename; vvsize = SCHEME_RENAME_LEN(v); } @@ -4629,38 +4847,71 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca name = SCHEME_STX_VAL(stx); SCHEME_VEC_ELS(v2)[2+pos] = name; - { + if (!rib + || !skip_ribs_ht + || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(name, rib->timestamp))) { /* Either this name is in prev, in which case the answer must match this rename's target, or this rename's answer applies. */ Scheme_Object *ok = NULL, *ok_replace = NULL; int ok_replace_index = 0; + Scheme_Object *other_env; + + if (rib) { + EXPLAIN_S(fprintf(stderr, " resolve %s %s (%d)\n", + scheme_write_to_string(name, NULL), + scheme_write_to_string(rib->timestamp, NULL), + done_rib_pos)); + } + + other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; + if (SCHEME_VOIDP(other_env)) { + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, NULL, 0); + SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; + } if (!WRAP_POS_END_P(prev) || SCHEME_PAIRP(v2l)) { WRAP_POS w3; Scheme_Object *vp; - Scheme_Object *other_env; - other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; - if (SCHEME_VOIDP(other_env)) { - other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs, NULL); - SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; - } - - /* Check marks (now that we have the correct barriers). */ + /* Check marks (now that we have the correct barriers). */ WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); if (!same_marks(&w2, &w, other_env)) { other_env = NULL; } if (other_env) { - /* First, check simplications in v2l. - If not in v2l, try prev. */ - if (!ok) { + /* A simplified table need to have the final answer, so + fold conversions from the rest of the wraps. In the case + of ribs, the "rest" can include earlier rib renamings. + Otherwise, check simplications accumulated in v2l (possibly from a + previously simplified tail in the same cache). Finally, + try prev (from a previously simplified tail in an earlier + round of simplifying). */ + int rib_found = 0; + if (done_rib_pos) { + for (j = 0; j < done_rib_pos; j++) { + if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+j], name)) { + rib_found = 1; + if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+size+j], other_env)) { + ok = SCHEME_VEC_ELS(v)[0]; + ok_replace = v2; + ok_replace_index = 2 + size + j; + } else { + EXPLAIN_S(fprintf(stderr, " not matching prev rib\n")); + ok = NULL; + } + break; + } + } + } + if (!rib_found) { + int passed_mutable = 0; WRAP_POS_COPY(w3, prev); svl = v2l; for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) { + if (SAME_OBJ(svl, end_mutable)) passed_mutable = 1; if (SCHEME_PAIRP(svl)) vp = SCHEME_CAR(svl); else @@ -4672,13 +4923,16 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+psize+j], other_env)) { ok = SCHEME_VEC_ELS(v)[0]; } else { + EXPLAIN_S(fprintf(stderr, + " not matching deeper %s\n", + scheme_write_to_string(other_env, NULL))); ok = NULL; /* Alternate time/space tradeoff: could be SCHEME_VEC_ELS(vp)[2+psize+j], which is the value from prev */ } - if (ok && SCHEME_PAIRP(svl)) { - /* Need to overwrite old map, instead + if (ok && SCHEME_PAIRP(svl) && !passed_mutable) { + /* Can overwrite old map, instead of adding a new one. */ ok_replace = vp; ok_replace_index = 2 + psize + j; @@ -4697,26 +4951,45 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca } if (WRAP_POS_END_P(w3) && SCHEME_NULLP(svl) && SCHEME_FALSEP(other_env)) ok = SCHEME_VEC_ELS(v)[0]; - } else - ok = NULL; - } + } + } else + ok = NULL; } else { - WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); - if (same_marks(&w2, &w, scheme_false)) - ok = SCHEME_VEC_ELS(v)[0]; - else - ok = NULL; + if (!SCHEME_FALSEP(other_env)) { + EXPLAIN_S(fprintf(stderr, " not based on #f\n")); + ok = NULL; + } else { + WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); + if (same_marks(&w2, &w, scheme_false)) + ok = SCHEME_VEC_ELS(v)[0]; + else { + EXPLAIN_S(fprintf(stderr, " not matching marks\n")); + ok = NULL; + } + } } if (ok) { if (ok_replace) { + EXPLAIN_S(fprintf(stderr, " replace mapping %s\n", + scheme_write_to_string(ok, NULL))); SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok; } else { + EXPLAIN_S(fprintf(stderr, " add mapping %s\n", + scheme_write_to_string(ok, NULL))); SCHEME_VEC_ELS(v2)[2+size+pos] = ok; pos++; } - } - } + } else { + EXPLAIN_S(fprintf(stderr, " no mapping %s\n", + scheme_write_to_string(name, NULL))); + } + } else { + EXPLAIN_S(fprintf(stderr, " skip %s %s %p\n", + scheme_write_to_string(name, NULL), + scheme_write_to_string(rib->timestamp, NULL), + rib)); + } ii++; } @@ -4758,15 +5031,16 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca WRAP_POS_DEC(w); } - v = scheme_hash_get(lex_cache, key); - if (!v) { - v = (Scheme_Object *)scheme_make_hash_table_equal(); - scheme_hash_set(lex_cache, key, v); + if (!prev_prec_ribs) { + /* no dependency on ribs, so we can globally cache this result */ + scheme_hash_set(lex_cache, v, v2l); + end_mutable = v2l; } - scheme_hash_set((Scheme_Hash_Table *)v, skip_ribs, v2l); stack = SCHEME_CDR(stack); } + + return v2l; } static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, @@ -4774,7 +5048,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, Scheme_Hash_Table *rns, int just_simplify) { - Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *skip_ribs = scheme_null; + Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *prec_ribs = scheme_null; WRAP_POS w; Scheme_Hash_Table *lex_cache, *reverse_map; int stack_size = 0; @@ -4812,7 +5086,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, } /* Ensures that all lexical tables in w have been simplified */ - simplify_lex_renames(w_in, lex_cache); + simplifies = simplify_lex_renames(w_in, lex_cache); if (mt) scheme_marshal_push_refs(mt); @@ -4840,14 +5114,9 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, /* a is not a simplified table; need to look it up; if simplifies is non-null, then we already have found a list of simplified tables for the current wrap segment. */ - if (SCHEME_NULLP(simplifies)) { - simplifies = scheme_hash_get(lex_cache, old_key); - simplifies = scheme_hash_get((Scheme_Hash_Table *)simplifies, skip_ribs); - /* assert: a is not NULL; see the simplify_lex_rename() call above */ - } if (SCHEME_RIBP(a)) { if (nonempty_rib((Scheme_Lexical_Rib *)a)) - skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, skip_ribs); + prec_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, prec_ribs); } a = SCHEME_CAR(simplifies); /* used up one simplification: */ @@ -6494,6 +6763,16 @@ Scheme_Object *scheme_new_stx_simplify_cache() void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) { +#if 0 + if (SAME_OBJ(scheme_intern_symbol("x"), SCHEME_STX_VAL(stx))) { + fprintf(stderr, + "simplifying... %s\n", + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0), + NULL)); + explain_simp = 1; + } +#endif + if (cache) { Scheme_Hash_Table *rns; @@ -6501,6 +6780,15 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) simplify_syntax_inner(stx, rns, NULL); } + +#if 0 + if (explain_simp) { + explain_simp = 0; + fprintf(stderr, "simplified: %s\n", + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0), + NULL)); + } +#endif } /*========================================================================*/ @@ -6924,16 +7212,49 @@ static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], S return r; } -static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv) +static Scheme_Object *extract_phase(const char *who, int pos, int argc, Scheme_Object **argv, + Scheme_Object *delta, int use_shift) +{ + Scheme_Object *phase; + + if (argc > pos) { + phase = argv[pos]; + if (!SCHEME_FALSEP(phase) + && !SCHEME_INTP(phase) + && !SCHEME_BIGNUMP(phase)) + scheme_wrong_type(who, "exact integer or #f", pos, argc, argv); + } else { + Scheme_Thread *p = scheme_current_thread; + long ph; + ph = (p->current_local_env + ? p->current_local_env->genv->phase + : (use_shift + ? p->current_phase_shift + : 0)); + phase = scheme_make_integer(ph); + + if (SCHEME_FALSEP(delta) || SCHEME_FALSEP(phase)) + phase = scheme_false; + else + phase = scheme_bin_plus(delta, phase); + } + + return phase; +} + +Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) { Scheme_Object *orig_m1, *m1, *m2, *delta, *a[1]; int l1, l2; + Scheme_Object *phase; - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("make-syntax-delta-introducer", "syntax", 0, argc, argv); + if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) + scheme_wrong_type("make-syntax-delta-introducer", "syntax identifier", 0, argc, argv); if (!SCHEME_STXP(argv[1])) scheme_wrong_type("make-syntax-delta-introducer", "syntax", 1, argc, argv); + phase = extract_phase("make-syntax-delta-introducer", 2, argc, argv, scheme_make_integer(0), 1); + m1 = scheme_stx_extract_marks(argv[0]); orig_m1 = m1; m2 = scheme_stx_extract_marks(argv[1]); @@ -6949,15 +7270,11 @@ static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv) } if (!scheme_equal(m1, m2)) { - /* tails don't match, so keep all marks --- except those that determine a module binding */ + /* tails don't match, so keep all marks --- except + those that determine a module binding */ int skipped = 0; - Scheme_Object *phase; - Scheme_Thread *p = scheme_current_thread; - phase = scheme_make_integer(p->current_local_env - ? p->current_local_env->genv->phase - : 0); - resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped); + resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0); if (skipped) { /* Just keep the first `skipped' marks. */ @@ -6992,18 +7309,7 @@ static Scheme_Object *bound_eq(int argc, Scheme_Object **argv) if (!SCHEME_STX_IDP(argv[1])) scheme_wrong_type("bound-identifier=?", "identifier syntax", 1, argc, argv); - if (argc > 2) { - phase = argv[2]; - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - scheme_wrong_type("bound-identifier=?", "exact integer or #f", 2, argc, argv); - } else { - Scheme_Thread *p = scheme_current_thread; - phase = scheme_make_integer(p->current_local_env - ? p->current_local_env->genv->phase - : 0); - } + phase = extract_phase("bound-identifier=?", 2, argc, argv, scheme_make_integer(0), 0); return (scheme_stx_bound_eq(argv[0], argv[1], phase) ? scheme_true @@ -7019,24 +7325,11 @@ static Scheme_Object *do_module_eq(const char *who, int delta, int argc, Scheme_ if (!SCHEME_STX_IDP(argv[1])) scheme_wrong_type(who, "identifier syntax", 1, argc, argv); - if (argc > 2) { - phase = argv[2]; - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - scheme_wrong_type(who, "exact integer or #f", 2, argc, argv); - } else { - Scheme_Thread *p = scheme_current_thread; - if (delta == MZ_LABEL_PHASE) - phase = scheme_false; - else { - long ph; - ph = (delta + (p->current_local_env - ? p->current_local_env->genv->phase - : 0)); - phase = scheme_make_integer(ph); - } - } + phase = extract_phase(who, 2, argc, argv, + ((delta == MZ_LABEL_PHASE) + ? scheme_false + : scheme_make_integer(delta)), + 0); return (scheme_stx_module_eq2(argv[0], argv[1], phase, NULL) ? scheme_true @@ -7073,6 +7366,8 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) scheme_wrong_type(name, "identifier syntax", 0, argc, argv); + phase = extract_phase(name, 1, argc, argv, dphase, 1); + if (argc > 1) { phase = argv[1]; if (!SCHEME_FALSEP(phase) diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index 3f26099c07..e0582c5813 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -577,7 +577,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_svector_type, svector_val); GC_REG_TRAV(scheme_set_macro_type, small_object); - GC_REG_TRAV(scheme_id_macro_type, small_object); + GC_REG_TRAV(scheme_id_macro_type, twoptr_obj); GC_REG_TRAV(scheme_stx_type, stx_val); GC_REG_TRAV(scheme_stx_offset_type, stx_off_val); From f40ae63f455724a33bb89b5d9e7a0362e62b2956 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 24 Nov 2008 21:15:22 +0000 Subject: [PATCH 101/193] R6RS test-suite patch from Taro Minowa (PR 9942) svn: r12580 --- collects/tests/r6rs/base.sls | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/tests/r6rs/base.sls b/collects/tests/r6rs/base.sls index d39521ad9e..50bcf669e6 100644 --- a/collects/tests/r6rs/base.sls +++ b/collects/tests/r6rs/base.sls @@ -72,6 +72,10 @@ (syntax-rules () [(_ [str num] ...) (begin (test (string->number str) num) ...)])) + (define-syntax test/approx-string-to-number + (syntax-rules () + [(_ [str num] ...) (begin (test/approx (string->number str) num) ...)])) + ;; Definitions ---------------------------------------- (define add3 @@ -968,7 +972,9 @@ ("#e1e1000" (expt 10 1000)) ("#e-1e1000" (- (expt 10 1000))) ("#e1e-1000" (expt 10 -1000)) - ("#e-1e-1000" (- (expt 10 -1000))) + ("#e-1e-1000" (- (expt 10 -1000)))) + + (test/approx-string-to-number ("#i1e100" (inexact (expt 10 100))) ("#i1e1000" (inexact (expt 10 1000))) ("#i-1e1000" (inexact (- (expt 10 1000)))) From e2c5c973fc42d85fa6b61629ba1f22919f38b29b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 24 Nov 2008 23:42:20 +0000 Subject: [PATCH 102/193] document improved splitting with empty matches svn: r12581 --- collects/scribblings/reference/regexps.scrbl | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/collects/scribblings/reference/regexps.scrbl b/collects/scribblings/reference/regexps.scrbl index eea79141e9..97df718550 100644 --- a/collects/scribblings/reference/regexps.scrbl +++ b/collects/scribblings/reference/regexps.scrbl @@ -312,10 +312,13 @@ byte strings corresponding to a sequence of matches of results for parenthesized sub-patterns in @scheme[pattern] are not returned.) -If @scheme[pattern] matches a zero-length string or byte sequence, and -if it is at the beginning or end of the input, then the match does not -count. Otherwise, one character or byte in the input is skipped before -attempting another match. +The @scheme[pattern] is used in order to find matches, where each +match attempt starts at the end of the last match. Empty matches are +handled like any matches, returning a zero-length string or byte +sequence (they are more useful in the complementing +@scheme[regexp-split] function). However, the @scheme[pattern] is +restricted from matching an empty string at the beginning (or right +after a previous match) or at the end. If @scheme[input] contains no matches (in the range @scheme[start-pos] to @scheme[end-pos]), @scheme[null] is returned. Otherwise, each item @@ -525,7 +528,7 @@ strings (if @scheme[pattern] is a string or character regexp and @scheme[input] that are separated by matches to @scheme[pattern]. Adjacent matches are separated with @scheme[""] or @scheme[#""]. Zero-length matches are treated the same as in -@scheme[regexp-match*]. +@scheme[regexp-match*], but are more useful in this case. If @scheme[input] contains no matches (in the range @scheme[start-pos] to @scheme[end-pos]), the result is a list containing @scheme[input]'s @@ -539,8 +542,11 @@ case splitting goes to the end of @scheme[input] (which corresponds to an end-of-file if @scheme[input] is an input port). @examples[ -(regexp-split #rx"x" "12x4x6") -(regexp-split #rx"." "12x4x6") +(regexp-split #rx" +" "12 34") +(regexp-split #rx"." "12 34") +(regexp-split #rx"" "12 34") +(regexp-split #rx" *" "12 34") +(regexp-split #px"\\b" "12, 13 and 14.") ]} @;------------------------------------------------------------------------ From 4d6aed53285bbee856a7f73dc7230cfc0d47cf00 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 24 Nov 2008 23:42:36 +0000 Subject: [PATCH 103/193] typo svn: r12582 --- collects/scribblings/reference/stx-trans.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index eb0ced966b..f05aad24f3 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -243,7 +243,7 @@ Indicates that no further bindings will be added to identifier?]{ Removes @scheme[intdef-ctx] from the @tech{lexical information} of -@scheme[id-stx]. This operation is useful for correlating a identifier +@scheme[id-stx]. This operation is useful for correlating an identifier that is bound in an internal-definition context with its binding before the internal-definition context was created.} From e89c1a13cbc54e0480dbca82b17c1e819844c02b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 24 Nov 2008 23:46:43 +0000 Subject: [PATCH 104/193] Welcome to a new PLT day. svn: r12583 --- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 6 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index f26316da27..0ab155b489 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Tue, 25 Nov 2008 01:00:37 +0000 Subject: [PATCH 105/193] added the scribble tests svn: r12584 --- collects/tests/run-automated-tests.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index 72513d6336..2df9b00213 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -37,6 +37,7 @@ [require "match/plt-match-tests.ss"] ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] [require "lazy/main.ss"] + [require "scribble/main.ss"] )) From 5f3b7e5c6f26298c519be93f6d45fc865d626aaf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 25 Nov 2008 03:08:08 +0000 Subject: [PATCH 106/193] another int-def binding simplification repair svn: r12585 --- collects/scheme/package.ss | 158 +++++++++++++++++++++++++++---------- src/mzscheme/src/stxobj.c | 20 +++-- 2 files changed, 131 insertions(+), 47 deletions(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 41827b90bb..c01128df68 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -1,11 +1,45 @@ #lang scheme/base (require (for-syntax scheme/base syntax/kerncase - syntax/boundmap)) + syntax/boundmap + syntax/define)) -(provide define-package +(provide define* + define*-values + define*-syntax + define*-syntaxes + define-package open-package) +(define-for-syntax (do-define-* stx define-values-id) + (syntax-case stx () + [(_ (id ...) rhs) + (let ([ids (syntax->list #'(id ...))]) + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "expected an identifier for definition" + stx + id))) + ids) + (with-syntax ([define-values define-values-id]) + (syntax/loc stx + (define-values (id ...) rhs))))])) +(define-syntax (define*-values stx) + (do-define-* stx #'define-values)) +(define-syntax (define*-syntaxes stx) + (do-define-* stx #'define-syntaxes)) + +(define-syntax (define* stx) + (let-values ([(id rhs) (normalize-definition stx #'lambda)]) + (quasisyntax/loc stx + (define*-values (#,id) #,rhs)))) +(define-syntax (define*-syntax stx) + (let-values ([(id rhs) (normalize-definition stx #'lambda)]) + (quasisyntax/loc stx + (define*-syntaxes (#,id) #,rhs)))) + (begin-for-syntax (define-struct package (exports hidden) #:omit-define-syntaxes @@ -70,14 +104,19 @@ (if (pair? orig-ctx) orig-ctx null)))] - [pre-package-id (lambda (id) - (identifier-remove-from-definition-context - id - def-ctx))] - [kernel-forms (kernel-form-identifier-list)] + [pre-package-id (lambda (id def-ctxes) + (for/fold ([id id]) + ([def-ctx (in-list def-ctxes)]) + (identifier-remove-from-definition-context + id + def-ctx)))] + [kernel-forms (list* + #'define*-values + #'define*-syntaxes + (kernel-form-identifier-list))] [init-exprs (syntax->list #'(form ...))] [new-bindings (make-bound-identifier-mapping)] - [fixup-sub-package (lambda (renamed-exports renamed-defines) + [fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes) (lambda (stx) (syntax-case* stx (define-syntaxes #%plain-app make-package quote-syntax list cons #%plain-lambda) @@ -101,7 +140,7 @@ (bound-identifier=? id e-id)) renamed-defines))) ;; Need to preserve the original - (pre-package-id id) + (pre-package-id id def-ctxes) ;; It's not accessible, so just hide the name ;; to avoid re-binding errors. (car (generate-temporaries (list id))))) @@ -127,20 +166,26 @@ id #t)) ids))] - [add-package-context (lambda (stx) - (let ([q (local-expand #`(quote #,stx) - ctx - (list #'quote) - def-ctx)]) - (syntax-case q () - [(_ stx) #'stx])))]) + [add-package-context (lambda (def-ctxes) + (lambda (stx) + (for/fold ([stx stx]) + ([def-ctx (in-list (reverse def-ctxes))]) + (let ([q (local-expand #`(quote #,stx) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ stx) #'stx])))))]) (let loop ([exprs init-exprs] [rev-forms null] - [defined null]) + [defined null] + [def-ctxes (list def-ctx)]) (cond [(null? exprs) - (internal-definition-context-seal def-ctx) - (let ([exports-renamed (map add-package-context (or exports null))] + (for-each (lambda (def-ctx) + (internal-definition-context-seal def-ctx)) + def-ctxes) + (let ([exports-renamed (map (add-package-context def-ctxes) (or exports null))] [defined-renamed (bound-identifier-mapping-map new-bindings (lambda (k v) k))]) (for-each (lambda (ex renamed) @@ -165,7 +210,8 @@ (bound-identifier-mapping-map new-bindings (lambda (k v) (and v k)))))]) #`(begin - #,@(map (fixup-sub-package exports-renamed defined-renamed) (reverse rev-forms)) + #,@(map (fixup-sub-package exports-renamed defined-renamed def-ctxes) + (reverse rev-forms)) (define-syntax pack-id (make-package (lambda () @@ -175,40 +221,65 @@ (lambda () (list (quote-syntax hidden) ...)))))))] [else - (let ([expr (local-expand (car exprs) ctx kernel-forms def-ctx)]) - (syntax-case expr (begin define-syntaxes define-values) + (let ([expr ((add-package-context (cdr def-ctxes)) + (local-expand ((add-package-context (cdr def-ctxes)) (car exprs)) + ctx + kernel-forms + (car def-ctxes)))]) + (syntax-case expr (begin) [(begin . rest) (loop (append (syntax->list #'rest) (cdr exprs)) rev-forms defined)] - [(define-syntaxes (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) + [(def (id ...) rhs) + (and (or (free-identifier=? #'def #'define-syntaxes) + (free-identifier=? #'def #'define*-syntaxes)) + (andmap identifier? (syntax->list #'(id ...)))) (with-syntax ([rhs (local-transformer-expand #'rhs 'expression null)]) - (let ([ids (syntax->list #'(id ...))]) - (syntax-local-bind-syntaxes ids #'rhs def-ctx) + (let ([star? (free-identifier=? #'def #'define*-syntaxes)] + [ids (syntax->list #'(id ...))]) + (let* ([def-ctx (if star? + (syntax-local-make-definition-context) + (car def-ctxes))] + [ids (if star? + (map (add-package-context (list def-ctx)) ids) + ids)]) + (syntax-local-bind-syntaxes ids #'rhs def-ctx) + (register-bindings! ids) + (loop (cdr exprs) + (cons #`(define-syntaxes #,ids rhs) + rev-forms) + (cons ids defined) + (if star? (cons def-ctx def-ctxes) def-ctxes)))))] + [(def (id ...) rhs) + (and (or (free-identifier=? #'def #'define-values) + (free-identifier=? #'def #'define*-values)) + (andmap identifier? (syntax->list #'(id ...)))) + (let ([star? (free-identifier=? #'def #'define*-values)] + [ids (syntax->list #'(id ...))]) + (let* ([def-ctx (if star? + (syntax-local-make-definition-context) + (car def-ctxes))] + [ids (if star? + (map (add-package-context (list def-ctx)) ids) + ids)]) + (syntax-local-bind-syntaxes ids #f def-ctx) (register-bindings! ids) (loop (cdr exprs) - (cons #'(define-syntaxes (id ...) rhs) - rev-forms) - (cons ids defined))))] - [(define-values (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (let ([ids (syntax->list #'(id ...))]) - (syntax-local-bind-syntaxes ids #f def-ctx) - (register-bindings! ids) - (loop (cdr exprs) - (cons expr rev-forms) - (cons ids defined)))] + (cons #`(define-values #,ids rhs) rev-forms) + (cons ids defined) + (if star? (cons def-ctx def-ctxes) def-ctxes))))] [else (loop (cdr exprs) (cons #`(define-values () (begin #,expr (values))) rev-forms) - defined)]))]))))))])) + defined + def-ctxes)]))]))))))])) -(define-syntax (open-package stx) +(define-for-syntax (do-open stx define-syntaxes-id) (syntax-case stx () [(_ pack-id) (let ([id #'pack-id]) @@ -239,8 +310,8 @@ (syntax-local-introduce (cdr p)))) ((package-exports v)))] [(h ...) (map syntax-local-introduce ((package-hidden v)))]) - #'(begin - (define-syntaxes (intro ...) + #`(begin + (#,define-syntaxes-id (intro ...) (let ([rev-map (lambda (x) (reverse-mapping x @@ -250,3 +321,8 @@ (list (quote-syntax h) ...)))]) (values (make-rename-transformer #'defined rev-map) ...))))))))])) + +(define-syntax (open-package stx) + (do-open stx #'define-syntaxes)) +(define-syntax (open*-package stx) + (do-open stx #'define*-syntaxes)) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 6aa53457e7..21fc4d7cb4 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -4573,7 +4573,7 @@ static int explain_simp = 0; static void print_skips(Scheme_Object *skips) { while (skips) { - printf(" skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL)); + fprintf(stderr, " skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL)); skips = SCHEME_CDR(skips); } } @@ -4630,6 +4630,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab v2l = scheme_null; + EXPLAIN_S(fprintf(stderr, "[in simplify]\n")); + while (!WRAP_POS_END_P(w)) { if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) || SCHEME_RIBP(WRAP_POS_FIRST(w))) { @@ -4704,7 +4706,6 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; } - SCHEME_VEC_ELS(rib->rename)[2+vsize+i] = other_env; } WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); if (same_marks(&w2, &w, other_env)) { @@ -4789,6 +4790,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL))); ribs_stack = SCHEME_CDR(ribs_stack); vsize = 0; + local_ribs = NULL; } else { prec_ribs = SCHEME_CAR(SCHEME_CAR(ribs_stack)); skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CDR(SCHEME_CAR(ribs_stack)); @@ -4866,8 +4868,14 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; if (SCHEME_VOIDP(other_env)) { - other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, NULL, 0); - SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; + int rib_dep; + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0); + if (rib_dep) { + scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); + return NULL; + } + if (!rib) + SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; } if (!WRAP_POS_END_P(prev) @@ -5033,7 +5041,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab if (!prev_prec_ribs) { /* no dependency on ribs, so we can globally cache this result */ - scheme_hash_set(lex_cache, v, v2l); + scheme_hash_set(lex_cache, key, v2l); end_mutable = v2l; } @@ -6764,7 +6772,7 @@ Scheme_Object *scheme_new_stx_simplify_cache() void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) { #if 0 - if (SAME_OBJ(scheme_intern_symbol("x"), SCHEME_STX_VAL(stx))) { + if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) { fprintf(stderr, "simplifying... %s\n", scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0), From b7addbab82ad04384f2c381b098857b9e745efc6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 25 Nov 2008 03:13:06 +0000 Subject: [PATCH 107/193] provide open*-package svn: r12586 --- collects/scheme/package.ss | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index c01128df68..0aabb74013 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -9,7 +9,8 @@ define*-syntax define*-syntaxes define-package - open-package) + open-package + open*-package) (define-for-syntax (do-define-* stx define-values-id) (syntax-case stx () @@ -230,7 +231,8 @@ [(begin . rest) (loop (append (syntax->list #'rest) (cdr exprs)) rev-forms - defined)] + defined + def-ctxes)] [(def (id ...) rhs) (and (or (free-identifier=? #'def #'define-syntaxes) (free-identifier=? #'def #'define*-syntaxes)) From 4f482b9f81592286037cb7b49ad83682e6574155 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 25 Nov 2008 08:50:17 +0000 Subject: [PATCH 108/193] Welcome to a new PLT day. svn: r12587 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 537431549d..b34ce1cf94 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "24nov2008") +#lang scheme/base (provide stamp) (define stamp "25nov2008") From ba54379202f14d1f19722fcebe4527dba2b2ea5d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 25 Nov 2008 16:03:31 +0000 Subject: [PATCH 109/193] Refine example svn: r12588 --- .../web-server/scribblings/templates.scrbl | 221 +++++++++--------- 1 file changed, 109 insertions(+), 112 deletions(-) diff --git a/collects/web-server/scribblings/templates.scrbl b/collects/web-server/scribblings/templates.scrbl index e04d3dbd06..aa688193b9 100644 --- a/collects/web-server/scribblings/templates.scrbl +++ b/collects/web-server/scribblings/templates.scrbl @@ -286,56 +286,107 @@ the template to be unescaped, then create a @scheme[cdata] structure: @section{Conversion Example} -Alonzo Church has been maintaining a blog with PLT Scheme for some years and would like to convert to @schememodname[web-server/templates]. +Al Church has been maintaining a blog with PLT Scheme for some years and would like to convert to @schememodname[web-server/templates]. -Here's the code he starts off with: -@schememod[ - scheme -(require xml - web-server/servlet - web-server/servlet-env) - -(code:comment "He actually Church-encodes them, but we'll use structs.") -(define-struct post (title body comments)) +The data-structures he uses are defined as: +@schemeblock[ +(define-struct post (title body)) (define posts (list (make-post "(Y Y) Works: The Why of Y" - "..." - (list - "First post! - A.T." - "Didn't I write this? - Matthias")) + "Why is Y, that is the question.") (make-post "Church and the States" - "As you may know, I grew up in DC, not technically a state..." - (list - "Finally, A Diet That Really Works! As Seen On TV")))) + "As you may know, I grew up in DC, not technically a state."))) +] +Actually, Al Church-encodes these posts, but for explanatory reasons, we'll use structs. -(code:comment "A function that is the generic template for the site") +He has divided his code into presentation functions and logic functions. We'll look at the presentation functions first. + +The first presentation function defines the common layout of all pages. +@schemeblock[ (define (template section body) `(html - (head (title "Alonzo's Church: " ,section) - (style ([type "text/css"]) - (code:comment "CDATA objects were useful for returning raw data") - ,(make-cdata #f #f "\n body {\n margin: 0px;\n padding: 10px;\n }\n\n #main {\n background: #dddddd;\n }"))) + (head (title "Al's Church: " ,section)) (body - (script ([type "text/javascript"]) - (code:comment "Which is particularly useful for JavaScript") - ,(make-cdata #f #f "\n var gaJsHost = ((\"https:\" == document.location.protocol) ?\n \"https://ssl.\" : \"http://www.\");\n document.write(unescape(\"%3Cscript src='\" + gaJsHost +\n \"google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E\"));\n")) - (script ([type "text/javascript"]) - ,(make-cdata #f #f "\n var pageTracker = _gat._getTracker(\"UA-YYYYYYY-Y\");\n pageTracker._trackPageview();\n")) - - (h1 "Alonzo's Church: " ,section) + (h1 "Al's Church: " ,section) (div ([id "main"]) - (code:comment "He had to be careful to use splicing here") ,@body)))) +] +One of the things to notice here is the @scheme[unquote-splicing] on the @scheme[body] argument. +This indicates that the @scheme[body] is list of @|xexpr|s. If he had accidentally used only @scheme[unquote] +then there would be an error in converting the return value to an HTTP response. + +@schemeblock[ (define (blog-posted title body k-url) `((h2 ,title) (p ,body) (h1 (a ([href ,k-url]) "Continue")))) +] +Here's an example of simple body that uses a list of @|xexpr|s to show the newly posted blog entry, before continuing to redisplay +the main page. Let's look at a more complicated body: + +@schemeblock[ +(define (blog-posts k-url) + (append + (apply append + (for/list ([p posts]) + `((h2 ,(post-title p)) + (p ,(post-body p))))) + `((h1 "New Post") + (form ([action ,k-url]) + (input ([name "title"])) + (input ([name "body"])) + (input ([type "submit"])))))) +] + +This function shows a number of common patterns that are required by @|xexpr|s. First, @scheme[append] is used to combine +different @|xexpr| lists. Second, @scheme[apply append] is used to collapse and combine the results of a @scheme[for/list] +where each iteration results in a list of @|xexpr|s. We'll see that these patterns are unnecessary with templates. Another +annoying patterns shows up when Al tries to add CSS styling and some JavaScript from Google Analytics to all the pages of +his blog. He changes the @scheme[template] function to: + +@schemeblock[ +(define (template section body) + `(html + (head + (title "Al's Church: " ,section) + (style ([type "text/css"]) + "body {margin: 0px; padding: 10px;}" + "#main {background: #dddddd;}")) + (body + (script + ([type "text/javascript"]) + ,(make-cdata + #f #f + "var gaJsHost = ((\"https:\" ==" + "document.location.protocol)" + "? \"https://ssl.\" : \"http://www.\");" + "document.write(unescape(\"%3Cscript src='\" + gaJsHost" + "+ \"google-analytics.com/ga.js' " + "type='text/javascript'%3E%3C/script%3E\"));")) + (script + ([type "text/javascript"]) + ,(make-cdata + #f #f + "var pageTracker = _gat._getTracker(\"UA-YYYYYYY-Y\");" + "pageTracker._trackPageview();")) + (h1 "Al's Church: " ,section) + (div ([id "main"]) + ,@body)))) +] + +The first thing we notice is that encoding CSS as a string is rather primitive. Encoding JavaScript with strings is even worse for two +reasons: first, we are more likely to need to manually escape characters such as @"\""; second, we need to use a CDATA object, because most +JavaScript code uses characters that "need" to be escaped in XML, such as &, but most browsers will fail if these characters are +entity-encoded. These are all problems that go away with templates. + +Before moving to templates, let's look at the logic functions: +@schemeblock[ (define (extract-post req) (define binds (request-bindings req)) @@ -344,30 +395,13 @@ Here's the code he starts off with: (define body (extract-binding/single 'body binds)) (set! posts - (list* (make-post title body empty) + (list* (make-post title body) posts)) (send/suspend (lambda (k-url) (template "Posted" (blog-posted title body k-url)))) (display-posts)) -(define (blog-posts k-url) - (code:comment "append or splicing is needed") - (append - (code:comment "Each element of the list is another list") - (apply append - (for/list ([p posts]) - `((h2 ,(post-title p)) - (p ,(post-body p)) - (ul - ,@(for/list ([c (post-comments p)]) - `(li ,c)))))) - `((h1 "New Post") - (form ([action ,k-url]) - (input ([name "title"])) - (input ([name "body"])) - (input ([type "submit"])))))) - (define (display-posts) (extract-post (send/suspend @@ -376,19 +410,29 @@ Here's the code he starts off with: (define (start req) (display-posts)) - -(serve/servlet start) ] -Luckily, Alonzo has great software engineering skills, so he's already separated the presentation logic into the functions -@scheme[blog-posted], @scheme[blog-posts], and @scheme[template]. Each one of these will turn into a different -template. +To use templates, we need only change @scheme[template], @scheme[blog-posted], and @scheme[blog-posts]: + +@schemeblock[ +(define (template section body) + (list TEXT/HTML-MIME-TYPE + (include-template "blog.html"))) + +(define (blog-posted title body k-url) + (include-template "blog-posted.html")) + +(define (blog-posts k-url) + (include-template "blog-posts.html")) +] + +Each of the templates are given below: @filepath{blog.html}: @verbatim[#:indent 2]|{ - Alonzo's Church: @|section| + Al's Church: @|section|
" (car c) ", " (cdr c) "