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

scheme/bool and scheme/local

Browse Source 
svn: r8394
This commit is contained in:
Matthew Flatt 2008-01-23 18:11:02 +00:00
parent 15a4c155bf
commit 17d717a8ba
7 changed files with 142 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
collects/mzlib/etc.ss
View File

@ -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 ()

27
collects/scheme/bool.ss Normal file
View File

@ -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))

66
collects/scheme/local.ss Normal file
View File

@ -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))]))

6
collects/scheme/main.ss
View File

@ -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))))

4
collects/scheme/private/kw.ss
View File

@ -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)

16
collects/scribblings/reference/data.scrbl
View File

@ -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"]

21
collects/scribblings/reference/syntax.scrbl
View File

@ -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"]