scheme/bool and scheme/local
svn: r8394
This commit is contained in:
parent
15a4c155bf
commit
17d717a8ba
|
@ -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
27
collects/scheme/bool.ss
Normal 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
66
collects/scheme/local.ss
Normal 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))]))
|
|
@ -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))))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"]
|
||||
|
||||
|
|
|
@ -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"]
|
||||
|
|
Loading…
Reference in New Issue
Block a user