diff --git a/collects/tests/unstable/define.rkt b/collects/tests/unstable/define.rkt new file mode 100644 index 0000000000..ec393de503 --- /dev/null +++ b/collects/tests/unstable/define.rkt @@ -0,0 +1,85 @@ +#lang racket + +(require rackunit rackunit/text-ui racket/sandbox unstable/define "helpers.rkt") + +(run-tests + (test-suite "define.ss" + + (test-suite "at-end") + + (test-suite "define-if-unbound" + (test + (let () + (define-if-unbound very-special-name 1) + (define-if-unbound very-special-name 2) + (check-equal? very-special-name 1))) + (test + (let () + (define-if-unbound (very-special-function) 1) + (define-if-unbound (very-special-function) 2) + (check-equal? (very-special-function) 1)))) + + (test-suite "define-values-if-unbound" + (test + (let () + (define-values-if-unbound [very-special-name] 1) + (define-values-if-unbound [very-special-name] 2) + (check-equal? very-special-name 1)))) + + (test-suite "define-syntax-if-unbound" + (test + (let () + (define-syntax-if-unbound very-special-macro + (lambda (stx) #'(quote 1))) + (define-syntax-if-unbound very-special-macro + (lambda (stx) #'(quote 2))) + (check-equal? (very-special-macro) 1))) + (test + (let () + (define-syntax-if-unbound (very-special-macro stx) + #'(quote 1)) + (define-syntax-if-unbound (very-special-macro stx) + #'(quote 2)) + (check-equal? (very-special-macro) 1)))) + + (test-suite "define-syntaxes-if-unbound" + (test + (let () + (define-syntaxes-if-unbound [very-special-macro] + (lambda (stx) #'(quote 1))) + (define-syntaxes-if-unbound [very-special-macro] + (lambda (stx) #'(quote 2))) + (check-equal? (very-special-macro) 1)))) + + (test-suite "define-renamings" + (test + (let () + (define-renamings [with define] [fun lambda]) + (with f (fun (x) (add1 x))) + (check-equal? (f 7) 8)))) + + (test-suite "declare-names" + (test + (let () + (declare-names x y z) + (define-values [x y z] (values 1 2 3)) + (check-equal? x 1) + (check-equal? y 2) + (check-equal? z 3)))) + + (test-suite "define-with-parameter" + (test + (let () + (define p (make-parameter 0)) + (define-with-parameter with-p p) + (with-p 7 (check-equal? (p) 7))))) + + (test-suite "define-single-definition" + (test + (let () + (define-single-definition with define-values) + (with x 0) + (check-equal? x 0)))) + + (test-suite "in-phase1") + (test-suite "in-phase1/pass2"))) diff --git a/collects/unstable/cce/define.ss b/collects/unstable/cce/define.ss deleted file mode 100644 index a8f0d7eb79..0000000000 --- a/collects/unstable/cce/define.ss +++ /dev/null @@ -1,140 +0,0 @@ -#lang scheme - -(require "private/define-core.ss" - (for-syntax scheme/match - syntax/kerncase - unstable/syntax)) - -(provide - - in-phase1 in-phase1/pass2 - - block - at-end - - declare-names - define-renamings - define-single-definition - define-with-parameter - - define-if-unbound - define-values-if-unbound - define-syntax-if-unbound - define-syntaxes-if-unbound) - -(define-syntax (at-end stx) - (syntax-case stx () - [(_ e ...) - (match (syntax-local-context) - ['module - (begin - (syntax-local-lift-module-end-declaration - (syntax/loc stx (begin e ...))) - (syntax/loc stx (begin)))] - [ctx (wrong-syntax stx - "can only be used in module context; got: ~s" - ctx)])])) - -(define-syntax-rule (define-with-parameter name parameter) - (define-syntax-rule (name value body (... ...)) - (parameterize ([parameter value]) body (... ...)))) - -(define-syntax (#%definition stx0) - (syntax-case stx0 () - [(_ form) - (let* ([stx (head-expand #'form)]) - (syntax-case stx ( module - #%require - #%provide - define-values - define-syntaxes - define-values-for-syntax - begin ) - [(module . _) stx] - [(#%require . _) stx] - [(#%provide . _) stx] - [(define-values . _) stx] - [(define-syntaxes . _) stx] - [(define-values-for-syntax . _) stx] - [(begin d ...) (syntax/loc stx0 (begin (#%definition d) ...))] - [_ (raise-syntax-error '#%definition "not a definition" stx0 stx)]))])) - -(define-syntax (#%as-definition stx0) - (syntax-case stx0 () - [(_ form) - (let* ([stx (head-expand #'form)]) - (syntax-case stx ( module - #%require - #%provide - define-values - define-syntaxes - define-values-for-syntax - begin ) - [(module . _) stx] - [(#%require . _) stx] - [(#%provide . _) stx] - [(define-values . _) stx] - [(define-syntaxes . _) stx] - [(define-values-for-syntax . _) stx] - [(begin d ...) (syntax/loc stx0 (begin (#%as-definition d) ...))] - [e - (syntax/loc stx0 - (define-values [] (begin e (#%plain-app values))))]))])) - -(define-syntax (#%as-expression stx0) - (syntax-case stx0 () - [(_ form) - (let* ([stx (head-expand #'form)] - ;; pre-compute this to save duplicated code below - [done (quasisyntax/loc stx0 (begin #,stx (#%plain-app void)))]) - (syntax-case stx ( module - #%require - #%provide - define-values - define-syntaxes - define-values-for-syntax - begin ) - [(module . _) done] - [(#%require . _) done] - [(#%provide . _) done] - [(define-values . _) done] - [(define-syntaxes . _) done] - [(define-values-for-syntax . _) done] - [(begin) (syntax/loc stx0 (#%plain-app void))] - [(begin d ... e) - (syntax/loc stx0 (begin (#%as-definition d) ... (#%as-expression e)))] - [_ stx]))])) - -(define-syntax-rule (block form ...) - (let-values () (#%as-expression (begin form ...)))) - -(define-syntax (declare-names stx) - (match (syntax-local-context) - ['top-level - (syntax-case stx [] - [(_ name ...) (syntax/loc stx (define-syntaxes [name ...] (values)))])] - [_ (syntax/loc stx (begin))])) - -(define-syntax-rule (define-renamings [new old] ...) - (define-syntaxes [new ...] (values (make-rename-transformer #'old) ...))) - -(define-syntax (in-phase1 stx) - (syntax-case stx [] - [(_ e) - (match (syntax-local-context) - ['expression (syntax/loc stx (let-syntax ([dummy e]) (void)))] - [(or 'module 'top-level (? pair?)) - (syntax/loc stx - (begin - (define-syntax (macro stx*) (begin e (syntax/loc stx* (begin)))) - (macro)))] - ['module-begin (wrong-syntax stx "cannot be used as module body")])])) - -(define-syntax (in-phase1/pass2 stx) - (syntax-case stx [] - [(_ e) - (match (syntax-local-context) - [(? pair?) - (syntax/loc stx (define-values [] (begin (in-phase1 e) (values))))] - [(or 'expression 'top-level 'module 'module-begin) - (syntax/loc stx (#%expression (in-phase1 e)))])])) diff --git a/collects/unstable/cce/private/define-core.ss b/collects/unstable/cce/private/define-core.ss deleted file mode 100644 index fbca4ccc61..0000000000 --- a/collects/unstable/cce/private/define-core.ss +++ /dev/null @@ -1,54 +0,0 @@ -#lang scheme/base - -(require (for-syntax scheme/base scheme/list unstable/syntax)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Definition Generalization -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide define-single-definition) - -(define-syntax-rule (define-single-definition define-one define-many) - (define-syntax define-one - (syntax-rules [] - [(_ (head . args) . body) (define-one head (lambda args . body))] - [(_ name expr) (define-many [name] expr)]))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Potentially Redundant Bindings -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide define-if-unbound - define-values-if-unbound - define-syntaxes-if-unbound - define-syntax-if-unbound) - -(define-syntax (define-many-if-unbound stx) - (syntax-case stx [] - [(_ def [name ...] expr) - (let* ([ids (syntax->list #'(name ...))]) - (for ([bad (in-list ids)] #:when (not (identifier? bad))) - (wrong-syntax bad "expected an identifier")) - (let*-values ([(bound unbound) (partition identifier-binding ids)]) - (cond - [(null? bound) (syntax/loc stx (def [name ...] expr))] - [(null? unbound) (syntax/loc stx (def [] (values)))] - [else (wrong-syntax - stx - "conflicting definitions for ~s; none for ~s" - (map syntax-e bound) - (map syntax-e unbound))])))])) - -(define-syntax-rule (define-values-if-unbound [name ...] expr) - (define-many-if-unbound define-values [name ...] expr)) - -(define-single-definition define-if-unbound define-values-if-unbound) - -(define-syntax-rule (define-syntaxes-if-unbound [name ...] expr) - (define-many-if-unbound define-syntaxes [name ...] expr)) - -(define-single-definition define-syntax-if-unbound define-syntaxes-if-unbound) diff --git a/collects/unstable/cce/reference/manual.scrbl b/collects/unstable/cce/reference/manual.scrbl index a3cbbc5d50..a32608753a 100644 --- a/collects/unstable/cce/reference/manual.scrbl +++ b/collects/unstable/cce/reference/manual.scrbl @@ -12,8 +12,6 @@ @include-section["set.scrbl"] -@include-section["define.scrbl"] - @include-section["require-provide.scrbl"] @include-section["planet.scrbl"] diff --git a/collects/unstable/cce/require-provide.ss b/collects/unstable/cce/require-provide.ss index 11fb316f23..6f3b986ffd 100644 --- a/collects/unstable/cce/require-provide.ss +++ b/collects/unstable/cce/require-provide.ss @@ -5,7 +5,7 @@ scheme/provide-transform syntax/parse unstable/planet-syntax) - "define.ss") + unstable/define) (define-syntax (define-planet-package stx) (syntax-parse stx diff --git a/collects/unstable/cce/slideshow.ss b/collects/unstable/cce/slideshow.ss index 3523549da5..8b3ea7a99a 100644 --- a/collects/unstable/cce/slideshow.ss +++ b/collects/unstable/cce/slideshow.ss @@ -2,7 +2,7 @@ (require slideshow/base slideshow/pict scheme/splicing scheme/stxparam scheme/gui/base - "define.ss") + unstable/define) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; diff --git a/collects/unstable/cce/test/test-define.ss b/collects/unstable/cce/test/test-define.ss deleted file mode 100644 index 0711529094..0000000000 --- a/collects/unstable/cce/test/test-define.ss +++ /dev/null @@ -1,99 +0,0 @@ -#lang scheme - -(require scheme/sandbox - "checks.ss" - "../define.ss") - -(provide define-suite) - -(define define-suite - (test-suite "define.ss" - - (test-suite "block" - (test - (block - (define (f x y) (both x y)) - (define-match-expander both - (syntax-rules () [(_ a b) (struct pair [a b])]) - (syntax-rules () [(_ a b) (make-pair a b)])) - (define-struct pair [x y] #:transparent) - (check-equal? (f 1 2) (make-pair 1 2))))) - - (test-suite "at-end") - - (test-suite "define-if-unbound" - (test - (let () - (define-if-unbound very-special-name 1) - (define-if-unbound very-special-name 2) - (check-equal? very-special-name 1))) - (test - (let () - (define-if-unbound (very-special-function) 1) - (define-if-unbound (very-special-function) 2) - (check-equal? (very-special-function) 1)))) - - (test-suite "define-values-if-unbound" - (test - (let () - (define-values-if-unbound [very-special-name] 1) - (define-values-if-unbound [very-special-name] 2) - (check-equal? very-special-name 1)))) - - (test-suite "define-syntax-if-unbound" - (test - (let () - (define-syntax-if-unbound very-special-macro - (lambda (stx) #'(quote 1))) - (define-syntax-if-unbound very-special-macro - (lambda (stx) #'(quote 2))) - (check-equal? (very-special-macro) 1))) - (test - (let () - (define-syntax-if-unbound (very-special-macro stx) - #'(quote 1)) - (define-syntax-if-unbound (very-special-macro stx) - #'(quote 2)) - (check-equal? (very-special-macro) 1)))) - - (test-suite "define-syntaxes-if-unbound" - (test - (let () - (define-syntaxes-if-unbound [very-special-macro] - (lambda (stx) #'(quote 1))) - (define-syntaxes-if-unbound [very-special-macro] - (lambda (stx) #'(quote 2))) - (check-equal? (very-special-macro) 1)))) - - (test-suite "define-renamings" - (test - (let () - (define-renamings [with define] [fun lambda]) - (with f (fun (x) (add1 x))) - (check-equal? (f 7) 8)))) - - (test-suite "declare-names" - (test - (let () - (declare-names x y z) - (define-values [x y z] (values 1 2 3)) - (check-equal? x 1) - (check-equal? y 2) - (check-equal? z 3)))) - - (test-suite "define-with-parameter" - (test - (let () - (define p (make-parameter 0)) - (define-with-parameter with-p p) - (with-p 7 (check-equal? (p) 7))))) - - (test-suite "define-single-definition" - (test - (let () - (define-single-definition with define-values) - (with x 0) - (check-equal? x 0)))) - - (test-suite "in-phase1") - (test-suite "in-phase1/pass2"))) diff --git a/collects/unstable/cce/test/test-main.ss b/collects/unstable/cce/test/test-main.ss index aef81b6f10..f1a34592a9 100644 --- a/collects/unstable/cce/test/test-main.ss +++ b/collects/unstable/cce/test/test-main.ss @@ -2,7 +2,6 @@ (require "checks.ss" "test-debug.ss" - "test-define.ss" "test-planet.ss" "test-require-provide.ss" "test-scribble.ss" @@ -11,7 +10,6 @@ (run-tests (test-suite "scheme.plt" debug-suite - define-suite planet-suite require-provide-suite scribble-suite diff --git a/collects/unstable/define.rkt b/collects/unstable/define.rkt new file mode 100644 index 0000000000..6060426ce1 --- /dev/null +++ b/collects/unstable/define.rkt @@ -0,0 +1,114 @@ +#lang racket + +(require (for-syntax racket/list + racket/match + syntax/kerncase + unstable/syntax)) + +(provide + + in-phase1 in-phase1/pass2 + + at-end + + declare-names + define-renamings + define-single-definition + define-with-parameter + + define-if-unbound + define-values-if-unbound + define-syntax-if-unbound + define-syntaxes-if-unbound) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Definition Generalization +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax-rule (define-single-definition define-one define-many) + (define-syntax define-one + (syntax-rules [] + [(_ (head . args) . body) (define-one head (lambda args . body))] + [(_ name expr) (define-many [name] expr)]))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Potentially Redundant Bindings +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax (define-many-if-unbound stx) + (syntax-case stx [] + [(_ def [name ...] expr) + (let* ([ids (syntax->list #'(name ...))]) + (for ([bad (in-list ids)] #:when (not (identifier? bad))) + (wrong-syntax bad "expected an identifier")) + (let*-values ([(bound unbound) (partition identifier-binding ids)]) + (cond + [(null? bound) (syntax/loc stx (def [name ...] expr))] + [(null? unbound) (syntax/loc stx (def [] (values)))] + [else (wrong-syntax + stx + "conflicting definitions for ~s; none for ~s" + (map syntax-e bound) + (map syntax-e unbound))])))])) + +(define-syntax-rule (define-values-if-unbound [name ...] expr) + (define-many-if-unbound define-values [name ...] expr)) + +(define-single-definition define-if-unbound define-values-if-unbound) + +(define-syntax-rule (define-syntaxes-if-unbound [name ...] expr) + (define-many-if-unbound define-syntaxes [name ...] expr)) + +(define-single-definition define-syntax-if-unbound define-syntaxes-if-unbound) + +(define-syntax (at-end stx) + (syntax-case stx () + [(_ e ...) + (match (syntax-local-context) + ['module + (begin + (syntax-local-lift-module-end-declaration + (syntax/loc stx (begin e ...))) + (syntax/loc stx (begin)))] + [ctx (wrong-syntax stx + "can only be used in module context; got: ~s" + ctx)])])) + +(define-syntax-rule (define-with-parameter name parameter) + (define-syntax-rule (name value body (... ...)) + (parameterize ([parameter value]) body (... ...)))) + +(define-syntax (declare-names stx) + (match (syntax-local-context) + ['top-level + (syntax-case stx [] + [(_ name ...) (syntax/loc stx (define-syntaxes [name ...] (values)))])] + [_ (syntax/loc stx (begin))])) + +(define-syntax-rule (define-renamings [new old] ...) + (define-syntaxes [new ...] (values (make-rename-transformer #'old) ...))) + +(define-syntax (in-phase1 stx) + (syntax-case stx [] + [(_ e) + (match (syntax-local-context) + ['expression (syntax/loc stx (let-syntax ([dummy e]) (void)))] + [(or 'module 'top-level (? pair?)) + (syntax/loc stx + (begin + (define-syntax (macro stx*) (begin e (syntax/loc stx* (begin)))) + (macro)))] + ['module-begin (wrong-syntax stx "cannot be used as module body")])])) + +(define-syntax (in-phase1/pass2 stx) + (syntax-case stx [] + [(_ e) + (match (syntax-local-context) + [(? pair?) + (syntax/loc stx (define-values [] (begin (in-phase1 e) (values))))] + [(or 'expression 'top-level 'module 'module-begin) + (syntax/loc stx (#%expression (in-phase1 e)))])])) diff --git a/collects/unstable/cce/reference/define.scrbl b/collects/unstable/scribblings/define.scrbl similarity index 69% rename from collects/unstable/cce/reference/define.scrbl rename to collects/unstable/scribblings/define.scrbl index 01abf1f079..43f57bac8e 100644 --- a/collects/unstable/cce/reference/define.scrbl +++ b/collects/unstable/scribblings/define.scrbl @@ -1,50 +1,14 @@ -#lang scribble/doc -@(require scribble/manual - scribble/eval - "../scribble.ss" - "eval.ss") -@(require (for-label scheme unstable/cce/define)) +#lang scribble/manual +@(require scribble/eval "utils.rkt" (for-label racket unstable/define)) -@title[#:style 'quiet #:tag "cce-define"]{Definitions} +@title{Definitions} -@defmodule[unstable/cce/define] +@defmodule[unstable/define] + +@unstable[@author+email["Carl Eastlund" "cce@racket-lang.org"]] This module provides macros for creating and manipulating definitions. -@section{Interleaving Definitions and Expressions} - -@defform[(block def-or-expr ...)]{ - -This expression establishes a lexically scoped block (i.e. an internal -definition context) in which definitions and expressions may be interleaved. -Its result is that of the last term (after @scheme[begin]-splicing), executed in -tail position, if the term is an expression; if there are no terms, or the last -term is a definition, its result is @scheme[(void)]. - -This form is equivalent to @scheme[(begin-with-definitions def-or-expr ...)]. - -@defexamples[ -#:eval (evaluator 'unstable/cce/define) -(define (intersection list-one list-two) - (block - - (define hash-one (make-hash)) - (for ([x (in-list list-one)]) - (hash-set! hash-one x #t)) - - (define hash-two (make-hash)) - (for ([x (in-list list-two)]) - (hash-set! hash-two x #t)) - - (for/list ([x (in-hash-keys hash-one)] - #:when (hash-has-key? hash-two x)) - x))) - -(intersection (list 1 2 3) (list 2 3 4)) -] - -} - @section{Deferred Evaluation in Modules} @defform[(at-end expr)]{ @@ -53,13 +17,13 @@ When used at the top level of a module, evaluates @scheme[expr] at the end of the module. This can be useful for calling functions before their definitions. @defexamples[ -#:eval (evaluator 'unstable/cce/define) +#:eval (eval/require 'unstable/define) (module Failure scheme (f 5) (define (f x) x)) (require 'Failure) (module Success scheme - (require unstable/cce/define) + (require unstable/define) (at-end (f 5)) (define (f x) x)) (require 'Success) @@ -88,7 +52,7 @@ Scheme with different bindings, to provide an implementation of a binding for versions that do not have it but use the built-in one in versions that do. @defexamples[ -#:eval (evaluator 'unstable/cce/define) +#:eval (eval/require 'unstable/define) (define-if-unbound x 1) x (define y 2) @@ -106,7 +70,7 @@ This form establishes a rename transformer for each @scheme[new] identifier, redirecting it to the corresponding @scheme[old] identifier. @defexamples[ -#:eval (evaluator 'unstable/cce/define) +#:eval (eval/require 'unstable/define) (define-renamings [def define] [lam lambda]) (def plus (lam (x y) (+ x y))) (plus 1 2) @@ -133,7 +97,7 @@ Defines the form @scheme[name] as a shorthand for setting the parameter to @scheme[(parameterize ([parameter value]) body ...)]. @defexamples[ -#:eval (evaluator 'unstable/cce/define) +#:eval (eval/require 'unstable/define) (define-with-parameter with-input current-input-port) (with-input (open-input-string "Tom Dick Harry") (read)) ] @@ -148,7 +112,7 @@ definition form with function shorthand like @scheme[define] and which works like @scheme[define-values] or @scheme[define-syntaxes]. @defexamples[ -#:eval (evaluator 'unstable/cce/define) +#:eval (eval/require 'unstable/define) (define-single-definition define-like define-values) (define-like x 0) x diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 71858b9ef6..025a92cfe0 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -74,6 +74,7 @@ Keep documentation and tests up to date. @include-section["bytes.scrbl"] @include-section["class.scrbl"] @include-section["contract.scrbl"] +@include-section["define.scrbl"] @include-section["dict.scrbl"] @include-section["dirs.scrbl"] @include-section["exn.scrbl"]