diff --git a/collects/r6rs/main.ss b/collects/r6rs/main.ss index a1016f3b7b..beee32de75 100644 --- a/collects/r6rs/main.ss +++ b/collects/r6rs/main.ss @@ -2,14 +2,13 @@ #| FIXME: - * (for ... expand) should shift all exports, not just run-time (requires a mzscheme change) - * need meta levels other than 0, 1, and -1 * Check that each identifier is imported only once across phases. |# (require (for-syntax scheme/base syntax/kerncase - "private/find-version.ss")) + "private/find-version.ss" + scheme/provide-transform)) (provide (rename-out [module-begin #%module-begin])) @@ -299,17 +298,10 @@ FIXME: (let* ([levels (map (lambda (level) (syntax-case* level (run expand meta) symbolic-identifier=? - [run #'except-in] - [expand #'for-syntax] - [(meta 0) #'except-in] - [(meta 1) #'for-syntax] - [(meta -1) #'for-template] - [(meta n) - (raise-syntax-error - #f - "meta level not supported" - orig - level)] + [run #'0] + [expand #'1] + [(meta 0) #'0] + [(meta n) #'n] [_ (raise-syntax-error #f @@ -317,12 +309,11 @@ FIXME: orig level)])) (syntax->list #'(level ...)))]) - (with-syntax ([is (parse-import-set orig #'im)] - [(level ...) (if (null? levels) - (list #'only-in) - null)]) - - #`((level is) ...)))] + (with-syntax ([is (parse-import-set orig #'base-im)]) + (if (null? levels) + #'() + (with-syntax ([(level ...) levels]) + #`((for-meta level is) ...)))))] [(for . _) (raise-syntax-error #f @@ -371,11 +362,57 @@ FIXME: orig ex)]))) exs) - (with-syntax ([(ex ...) + (with-syntax ([((ex ...) ...) (map (lambda (ex) (syntax-case ex () [(rename . rest) - #'(rename-out . rest)] - [_ ex])) - exs)]) - #'(provide ex ...)))]))) + #'rest] + [one #'((one one))])) + exs)] + [orig orig]) + #'(provide (all-levels-out orig ex ... ...))))]))) + +(define-syntax all-levels-out + (make-provide-transformer + (lambda (stx mode) + (syntax-case stx () + [(_ orig (local-id ext-id) ...) + (let* ([table (make-hash-table)] + [map-id (lambda (phase) + (lambda (id) + (let ([l (hash-table-get table (syntax-e id) null)]) + (unless (ormap (lambda (e) + (and (equal? (cdr e) phase) + (free-identifier=? (car e) id phase))) + l) + (hash-table-put! table + (syntax-e id) + (cons (cons id phase) l))))))]) + (let-values ([(ids for-syntax-ids) (syntax-local-module-defined-identifiers)]) + (for-each (map-id 0) ids) + (for-each (map-id 1) for-syntax-ids)) + (for-each (lambda (l) + (for-each (map-id (car l)) (cdr l))) + (syntax-local-module-required-identifiers #f #t)) + (apply + append + (map (lambda (local-id ext-id) + (let* ([l (hash-table-get table (syntax-e local-id) null)] + [l (filter (lambda (e) + (free-identifier=? (car e) local-id (cdr e))) + l)]) + (unless l + (raise-syntax-error + #f + "identifier not defined or imported" + #'orig + local-id)) + (map (lambda (e) + (make-export local-id + (syntax-e ext-id) + (cdr e) + #f + local-id)) + l))) + (syntax->list #'(local-id ...)) + (syntax->list #'(ext-id ...)))))])))) diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index dff5488b89..7d0ad88954 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -62,7 +62,10 @@ even? finite? infinite? nan? min max + * - / - abs gcd lcm + abs + div-and-mod div mod + div0-and-mod0 div0 mod0 + gcd lcm numerator denominator floor ceiling truncate round rationalize @@ -197,6 +200,50 @@ (define (nan? n) (eqv? n +nan.0)) +;; Someone needs to look more closely at div and mod. +;; I started with the code from Enger04, and poked it +;; until the results matched the examples in R6RS. + +(define (div x y) + (let ([n (* (numerator x) + (denominator y))] + [d (* (denominator x) + (numerator y))]) + (if (negative? n) + (- (quotient (- (abs d) n 1) d)) + (quotient n d)))) + +(define (div0 x y) + (cond + [(zero? y) 0] + [(positive? y) + (if (negative? x) + (- (div (- x) y)) + (div x y))] + [(negative? y) + (let ([n (* -2 + (numerator x) + (denominator y))] + [d (* (denominator x) + (- (numerator y)))]) + (if (< n d) + (- (quotient (- d n) (* 2 d))) + (quotient (+ n d -1) (* 2 d))))])) + +(define (mod x y) + (- x (* (div x y) y))) + +(define (div-and-mod x y) + (let ([d (div x y)]) + (values d (- x (* d y))))) + +(define (mod0 x y) + (- x (* (div0 x y) y))) + +(define (div0-and-mod0 x y) + (let ([d (div0 x y)]) + (values d (- x (* d y))))) + (define (r6rs:number->string z [radix 10] [precision #f]) (number->string z radix)) diff --git a/collects/scheme/private/reqprov.ss b/collects/scheme/private/reqprov.ss index fbbf6b8060..e06961467b 100644 --- a/collects/scheme/private/reqprov.ss +++ b/collects/scheme/private/reqprov.ss @@ -292,7 +292,14 @@ [transform-one (lambda (in) ;; Recognize `for-syntax', etc. for simple cases: - (syntax-case in () + (syntax-case in (for-meta) + [(for-meta n elem ...) + (or (exact-integer? (syntax-e #'n)) + (not (syntax-e #'n))) + (apply append + (map (lambda (in) + (transform-simple in (syntax-e #'n))) + (syntax->list #'(elem ...))))] [(for-something elem ...) (and (identifier? #'for-something) (ormap (lambda (i) (free-identifier=? i #'for-something)) diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss index b491d36c2a..b64cdff056 100644 --- a/collects/scribble/run.ss +++ b/collects/scribble/run.ss @@ -92,6 +92,6 @@ (when (current-info-output-file) (let ([s (send renderer serialize-info r-info)]) (with-output-to-file (current-info-output-file) - #:exists 'truncate/replace (lambda () - (write s)))))))))))) + (write s)) + 'truncate/replace)))))))))) diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index 0f2b935b80..84ab4e585f 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -191,7 +191,7 @@ (with-handlers ([exn:fail:contract? (lambda (exn) (error 'serialize-delayed-element - "serialization failed (wrong resolve info?); ~a" + "serialization failed (wrong resolve info? delayed element never rendered?); ~a" (exn-message exn)))]) (vector (make-element #f (delayed-element-content d ri)))))) @@ -234,7 +234,7 @@ (with-handlers ([exn:fail:contract? (lambda (exn) (error 'serialize-part-relative-element - "serialization failed (wrong resolve info?); ~a" + "serialization failed (wrong resolve info? part-relative element never rendered?); ~a" (exn-message exn)))]) (vector (make-element #f (part-relative-element-content d ri)))))) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 3e46acd87b..18f78fa6e2 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -481,35 +481,26 @@ for-syntax) definitions.} @defproc[(syntax-local-module-required-identifiers [mod-path (or/c module-path? false/c)] - [normal-imports? any/c] - [syntax-imports? any/c] - [label-imports? any/c]) - (values (listof identifier?) - (listof identifier?) - (listof identifier?))]{ + [phase-level (or/c exact-integer? false/c (one-of/c #t))]) + (listof (cons/c (or/c exact-integer? false/c) + (listof identifier?)))]{ Can be called only while @scheme[syntax-local-transforming-module-provides?] returns @scheme[#t]. -It returns three lists of identifiers corresponding to all bindings -imported into the module being expanded using the module path +It returns an association list mapping phase levels to lists of +identifiers. Each list of identifiers includes all bindings imported +(into the module being expanded) using the module path @scheme[mod-path], or all modules if @scheme[mod-path] is -@scheme[#f]. This information is used for implementing -@scheme[provide] sub-forms like @scheme[all-from-out]. +@scheme[#f]. The association list includes all identifiers imported +with a @scheme[phase-level] shift, of all shifts if +@scheme[phase-level] is @scheme[#t]. -The first result list corresponds to @tech{phase level} 0 (i.e., -normal) bindings, and the second list corresponds to @tech{phase -level} -1 (i.e., for-syntax) bindings, and the last list corresponds -corresponds to @tech{label phase level} (i.e., for-label) bindings. - -The @scheme[normal-imports?], @scheme[syntax-imports?], and -@scheme[label-imports?] arguments determine whether each of normal, -@scheme[for-syntax], and @scheme[for-label] @scheme[require]s are -considered in building the result lists. Note that normal -@scheme[require]s can add to all three lists, while -@scheme[for-syntax] and @scheme[for-label] @scheme[require]s -contribute only to one of the latter two lists, respectively.} +When an identifier is renamed on import, the result association list +includes the identifier by its internal name. Use +@scheme[identifier-binding] to obtain more information about the +identifier.} @; ---------------------------------------------------------------------- @@ -672,9 +663,9 @@ Returns @scheme[#t] if @scheme[v] has the @defstruct[export ([local-id identifier?] [out-sym symbol?] - [orig-stx syntax?] + [mode (or/c exact-integer? false/c)] [protect? any/c] - [mode (or/c exact-integer? false/c)])]{ + [orig-stx syntax?])]{ A structure representing a single imported identifier: