scheme/bool and scheme/local

svn: r8394

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 boolean=? symbol=?
-  (provide true false
-           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 ()

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

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

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

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)

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

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