From 17d717a8baee404a1a88e10ba893fb943efb2653 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 23 Jan 2008 18:11:02 +0000 Subject: [PATCH] scheme/bool and scheme/local svn: r8394 --- collects/mzlib/etc.ss | 81 ++------------------- collects/scheme/bool.ss | 27 +++++++ collects/scheme/local.ss | 66 +++++++++++++++++ collects/scheme/main.ss | 6 +- collects/scheme/private/kw.ss | 4 +- collects/scribblings/reference/data.scrbl | 16 ++++ collects/scribblings/reference/syntax.scrbl | 21 +++++- 7 files changed, 142 insertions(+), 79 deletions(-) create mode 100644 collects/scheme/bool.ss create mode 100644 collects/scheme/local.ss diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 23d656c3bc..d35966249b 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -2,6 +2,8 @@ (module etc mzscheme (require (lib "main-collects.ss" "setup") + scheme/local + scheme/bool (only scheme/base build-string build-list @@ -12,16 +14,15 @@ (require-for-syntax (lib "kerncase.ss" "syntax") (lib "stx.ss" "syntax") (lib "name.ss" "syntax") - (lib "context.ss" "syntax") (lib "main-collects.ss" "setup") "private/stxset.ss") - - (provide true false - boolean=? symbol=? + (provide boolean=? symbol=? identity compose + true false + build-string build-vector build-list @@ -49,9 +50,6 @@ begin-lifted) - (define true #t) - (define false #f) - (define identity (lambda (x) x)) (define (loop-until start done? next body) @@ -60,16 +58,6 @@ (body i) (loop (next i))))) - (define (boolean=? x y) - (unless (and (boolean? x) (boolean? y)) - (raise-type-error 'boolean=? "boolean" (if (boolean? x) y x))) - (eq? x y)) - - (define (symbol=? x y) - (unless (and (symbol? x) (symbol? y)) - (raise-type-error 'symbol=? "symbol" (if (symbol? x) y x))) - (eq? x y)) - (define-syntax (opt-lambda stx) (with-syntax ([name (or (syntax-local-infer-name stx) (quote-syntax opt-lambda-proc))]) @@ -118,65 +106,6 @@ (syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]))) - (define-syntax (local stx) - (syntax-case stx () - [(_ (defn ...) body1 body ...) - (let ([defs (let ([expand-context (generate-expand-context)]) - (let loop ([defns (syntax->list (syntax (defn ...)))]) - (apply - append - (map - (lambda (defn) - (let ([d (local-expand - defn - expand-context - (kernel-form-identifier-list))] - [check-ids (lambda (ids) - (for-each - (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "not an identifier for definition" - stx - id))) - ids))]) - (syntax-case d (define-values define-syntaxes begin) - [(begin defn ...) - (loop (syntax->list (syntax (defn ...))))] - [(define-values (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-values . rest) - (raise-syntax-error - #f "ill-formed definition" stx d)] - [(define-syntaxes (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-syntaxes . rest) - (raise-syntax-error - #f "ill-formed definition" stx d)] - [_else - (raise-syntax-error - #f "not a definition" stx defn)]))) - defns))))]) - (let ([ids (apply append - (map - (lambda (d) - (syntax-case d () - [(_ ids . __) (syntax->list (syntax ids))])) - defs))]) - (let ([dup (check-duplicate-identifier ids)]) - (when dup - (raise-syntax-error #f "duplicate identifier" stx dup))) - (with-syntax ([(def ...) defs]) - (syntax/loc stx - (let () def ... (let () body1 body ...))))))] - [(_ x body1 body ...) - (raise-syntax-error #f "not a definition sequence" stx (syntax x))])) - ;; recur is another name for 'let' in a named let (define-syntax (recur stx) (syntax-case stx () diff --git a/collects/scheme/bool.ss b/collects/scheme/bool.ss new file mode 100644 index 0000000000..456d2ffba1 --- /dev/null +++ b/collects/scheme/bool.ss @@ -0,0 +1,27 @@ +#lang scheme/base + +(provide true false + boolean=? + symbol=?) + +(define-syntax-rule (define-constant id val) + (... + (define-syntax id + (syntax-id-rules (set!) + [(set! id rhs) (set! val rhs)] + [(id . args) (val . args)] + [_ val])))) + +(define-constant true #t) +(define-constant false #f) + +(define (boolean=? x y) + (unless (and (boolean? x) (boolean? y)) + (raise-type-error 'boolean=? "boolean" (if (boolean? x) 1 0) x y)) + (eq? x y)) + +(define (symbol=? x y) + (unless (and (symbol? x) (symbol? y)) + (raise-type-error 'symbol=? "symbol" (if (symbol? x) 1 0) x y)) + (eq? x y)) + diff --git a/collects/scheme/local.ss b/collects/scheme/local.ss new file mode 100644 index 0000000000..527a9ca9a8 --- /dev/null +++ b/collects/scheme/local.ss @@ -0,0 +1,66 @@ +#lang scheme/base + +(require (for-syntax scheme/base + syntax/context + syntax/kerncase)) + +(provide local) + +(define-syntax (local stx) + (syntax-case stx () + [(_ (defn ...) body1 body ...) + (let ([defs (let ([expand-context (generate-expand-context)]) + (let loop ([defns (syntax->list (syntax (defn ...)))]) + (apply + append + (map + (lambda (defn) + (let ([d (local-expand + defn + expand-context + (kernel-form-identifier-list))] + [check-ids (lambda (ids) + (for-each + (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "not an identifier for definition" + stx + id))) + ids))]) + (syntax-case d (define-values define-syntaxes begin) + [(begin defn ...) + (loop (syntax->list (syntax (defn ...))))] + [(define-values (id ...) body) + (begin + (check-ids (syntax->list (syntax (id ...)))) + (list d))] + [(define-values . rest) + (raise-syntax-error + #f "ill-formed definition" stx d)] + [(define-syntaxes (id ...) body) + (begin + (check-ids (syntax->list (syntax (id ...)))) + (list d))] + [(define-syntaxes . rest) + (raise-syntax-error + #f "ill-formed definition" stx d)] + [_else + (raise-syntax-error + #f "not a definition" stx defn)]))) + defns))))]) + (let ([ids (apply append + (map + (lambda (d) + (syntax-case d () + [(_ ids . __) (syntax->list (syntax ids))])) + defs))]) + (let ([dup (check-duplicate-identifier ids)]) + (when dup + (raise-syntax-error #f "duplicate identifier" stx dup))) + (with-syntax ([(def ...) defs]) + (syntax/loc stx + (let () def ... (let () body1 body ...))))))] + [(_ x body1 body ...) + (raise-syntax-error #f "not a definition sequence" stx (syntax x))])) \ No newline at end of file diff --git a/collects/scheme/main.ss b/collects/scheme/main.ss index 65eb8841f2..822ec40adf 100644 --- a/collects/scheme/main.ss +++ b/collects/scheme/main.ss @@ -14,6 +14,8 @@ scheme/file scheme/cmdline scheme/promise + scheme/bool + scheme/local (for-syntax scheme/base)) (provide (all-from-out scheme/contract @@ -31,5 +33,7 @@ scheme/path scheme/file scheme/cmdline - scheme/promise) + scheme/promise + scheme/bool + scheme/local) (for-syntax (all-from-out scheme/base)))) diff --git a/collects/scheme/private/kw.ss b/collects/scheme/private/kw.ss index 3b8c3690c2..76a49a91f1 100644 --- a/collects/scheme/private/kw.ss +++ b/collects/scheme/private/kw.ss @@ -719,7 +719,9 @@ ;; Not ok, so far: (let ([p2 (if (keyword-procedure? p) #f - (procedure-extract-target p))]) + (if (procedure? p) + (procedure-extract-target p) + #f))]) (if p2 ;; Maybe the target is ok: (keyword-procedure-extract kws n p2) diff --git a/collects/scribblings/reference/data.scrbl b/collects/scribblings/reference/data.scrbl index 8b916794b4..d68a70c67d 100644 --- a/collects/scribblings/reference/data.scrbl +++ b/collects/scribblings/reference/data.scrbl @@ -127,6 +127,22 @@ values. For opaque structure types, @scheme[equal?] is the same as @scheme[equal-secondary-hash-code] results are based only on @scheme[eq-hash-code].} +@subsection{Boolean Synonyms} + +@note-lib[scheme/bool] + +@defthing[true boolean?]{A synonym for @scheme[#t].} + +@defthing[false boolean?]{A synonym for @scheme[#f].} + +@defproc[(symbol=? [a symbol?] [b symbol?]) boolean?]{ + +Returns @scheme[(equal? a b)].} + +@defproc[(boolean=? [a boolean?] [b boolean?]) boolean?]{ + +Returns @scheme[(equal? a b)].} + @; ------------------------------------------------------------ @include-section["numbers.scrbl"] diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 6e436195c9..3237101266 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -522,7 +522,26 @@ within all @scheme[trans-expr]s.} Combines @scheme[letrec-syntaxes] with @scheme[letrec-values]: each @scheme[trans-id] and @scheme[val-id] is bound in all -@scheme[trans-expr]s and @scheme[val-expr]s.} +@scheme[trans-expr]s and @scheme[val-expr]s. + +See also @scheme[local], which supports local bindings with +@scheme[define], @scheme[define-syntax], and more.} + +@;------------------------------------------------------------------------ +@section[#:tag "local"]{Local Definitions: @scheme[local]} + +@note-lib[scheme/local] + +@defform[(local [definition ...] body ...+)]{ + +Like @scheme[letrec], except that the bindings are expressed in the +same way as in the top-level or in a module body: using +@scheme[define], @scheme[define-values], @scheme[define-syntax], +@scheme[define-struct], etc. Definitions are distinguished from +non-definitions by partially expanding @scheme[definition] forms (see +@secref["partial-expansion"]). As in the top-level or in a module +body, a @scheme[begin]-wrapped sequence is spliced into the sequence +of @scheme[definition]s.} @;------------------------------------------------------------------------ @include-section["shared.scrbl"]