From 23736d15be7adef157279932da03493e7791d38d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 11 Apr 2010 16:55:18 +0000 Subject: [PATCH 1/6] module paths normalize to .rkt, load handler converts .rkt back to .ss if necessary svn: r18788 original commit: bdb71498e3ed816d44c9faf830f97fbe9fdaa3f2 --- collects/mzlib/include.ss | 169 ++++++++++++++++++++------------------ 1 file changed, 90 insertions(+), 79 deletions(-) diff --git a/collects/mzlib/include.ss b/collects/mzlib/include.ss index d86dee9..b8f4606 100644 --- a/collects/mzlib/include.ss +++ b/collects/mzlib/include.ss @@ -76,91 +76,102 @@ (syntax-case stx () [(_ orig-stx ctx loc fn reader) ;; Parse the file name - (let ([c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx) #'build-path)] + (let ([orig-c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx) #'build-path)] [ctx (syntax ctx)] [loc (syntax loc)] [reader (syntax reader)] - [orig-stx (syntax orig-stx)]) + [orig-stx (syntax orig-stx)] + [rkt->ss (lambda (p) + (let ([b (path->bytes p)]) + (if (regexp-match? #rx#"[.]rkt$" b) + (path-replace-suffix p #".ss") + p)))]) - (register-external-file c-file) + (let ([c-file (if (file-exists? orig-c-file) + orig-c-file + (let ([p2 (rkt->ss orig-c-file)]) + (if (file-exists? p2) + p2 + orig-c-file)))]) + (register-external-file c-file) - (let ([read-syntax (if (syntax-e reader) - (reader-val - (let loop ([e (syntax-object->datum - (local-expand reader 'expression null))]) - (cond - [(reader? e) e] - [(pair? e) (or (loop (car e)) - (loop (cdr e)))] - [else #f]))) - read-syntax)]) - (unless (and (procedure? read-syntax) - (procedure-arity-includes? read-syntax 2)) - (raise-syntax-error - #f - "reader is not a procedure of two arguments" - orig-stx)) + (let ([read-syntax (if (syntax-e reader) + (reader-val + (let loop ([e (syntax-object->datum + (local-expand reader 'expression null))]) + (cond + [(reader? e) e] + [(pair? e) (or (loop (car e)) + (loop (cdr e)))] + [else #f]))) + read-syntax)]) + (unless (and (procedure? read-syntax) + (procedure-arity-includes? read-syntax 2)) + (raise-syntax-error + #f + "reader is not a procedure of two arguments" + orig-stx)) - ;; Open the included file - (let ([p (with-handlers ([exn:fail? - (lambda (exn) - (raise-syntax-error - #f - (format - "can't open include file (~a)" - (if (exn? exn) - (exn-message exn) - exn)) - orig-stx - c-file))]) - (open-input-file c-file))]) - (port-count-lines! p) - ;; Read expressions from file - (let ([content - (let loop () - (let ([r (with-handlers ([exn:fail? - (lambda (exn) - (close-input-port p) - (raise-syntax-error - #f - (format - "read error (~a)" - (if (exn? exn) - (exn-message exn) - exn)) - orig-stx))]) - (read-syntax c-file p))]) - (if (eof-object? r) - null - (cons r (loop)))))]) - (close-input-port p) - ;; Preserve src info for content, but set its - ;; lexical context to be that of the include expression - (let ([lexed-content - (let loop ([content content]) - (cond - [(pair? content) - (cons (loop (car content)) - (loop (cdr content)))] - [(null? content) null] - [else - (let ([v (syntax-e content)]) - (datum->syntax-object - ctx - (cond - [(pair? v) - (loop v)] - [(vector? v) - (list->vector (loop (vector->list v)))] - [(box? v) - (box (loop (unbox v)))] - [else - v]) - content))]))]) - (datum->syntax-object - (quote-syntax here) - `(begin ,@lexed-content) - orig-stx))))))])) + ;; Open the included file + (let ([p (with-handlers ([exn:fail? + (lambda (exn) + (raise-syntax-error + #f + (format + "can't open include file (~a)" + (if (exn? exn) + (exn-message exn) + exn)) + orig-stx + c-file))]) + (open-input-file c-file))]) + (port-count-lines! p) + ;; Read expressions from file + (let ([content + (let loop () + (let ([r (with-handlers ([exn:fail? + (lambda (exn) + (close-input-port p) + (raise-syntax-error + #f + (format + "read error (~a)" + (if (exn? exn) + (exn-message exn) + exn)) + orig-stx))]) + (read-syntax c-file p))]) + (if (eof-object? r) + null + (cons r (loop)))))]) + (close-input-port p) + ;; Preserve src info for content, but set its + ;; lexical context to be that of the include expression + (let ([lexed-content + (let loop ([content content]) + (cond + [(pair? content) + (cons (loop (car content)) + (loop (cdr content)))] + [(null? content) null] + [else + (let ([v (syntax-e content)]) + (datum->syntax-object + ctx + (cond + [(pair? v) + (loop v)] + [(vector? v) + (list->vector (loop (vector->list v)))] + [(box? v) + (box (loop (unbox v)))] + [else + v]) + content))]))]) + (datum->syntax-object + (quote-syntax here) + `(begin ,@lexed-content) + orig-stx)))))))])) (define (include/proc stx) (syntax-case stx () From 07e1c1fda1510ea72551794781a2ff72aa8a257a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 11 Apr 2010 21:08:37 +0000 Subject: [PATCH 2/6] racket: keep old 'define-struct', include new form as 'struct' svn: r18789 original commit: 65d3d3240b647685f446f89d86b907f2bcc73b64 --- collects/mzlib/unit.ss | 216 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 213 insertions(+), 3 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index fb654f6..b1ae2bf 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -21,7 +21,8 @@ "private/unit-contract.ss" "private/unit-keywords.ss" "private/unit-runtime.ss" - "private/unit-utils.ss") + "private/unit-utils.ss" + (rename-in racket/private/struct [struct struct~])) (provide define-signature-form struct struct/ctc open define-signature provide-signature-elements @@ -35,7 +36,8 @@ define-unit-binding unit/new-import-export define-unit/new-import-export unit/s define-unit/s - unit/c define-unit/contract) + unit/c define-unit/contract + struct~ struct~/ctc) (define-syntax/err-param (define-signature-form stx) (syntax-case stx () @@ -130,6 +132,99 @@ ((_) (raise-stx-err "missing name and fields"))))) +;; Replacement `struct' signature form for `scheme/unit': +(define-signature-form (struct~~ stx) + (syntax-case stx () + ((_ name (field ...) opt ...) + (begin + (unless (identifier? #'name) + (raise-syntax-error #f + "expected an identifier to name the structure type" + stx + #'name)) + (for-each (lambda (field) + (unless (identifier? field) + (syntax-case field () + [(id #:mutable) + (identifier? #'id) + 'ok] + [_ + (raise-syntax-error #f + "bad field specification" + stx + field)]))) + (syntax->list #'(field ...))) + (let-values ([(no-ctr? mutable? no-stx? no-rt?) + (let loop ([opts (syntax->list #'(opt ...))] + [no-ctr? #f] + [mutable? #f] + [no-stx? #f] + [no-rt? #f]) + (if (null? opts) + (values no-ctr? mutable? no-stx? no-rt?) + (let ([opt (car opts)]) + (case (syntax-e opt) + [(#:omit-constructor) + (if no-ctr? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) #t mutable? no-stx? no-rt?))] + [(#:mutable) + (if mutable? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? #t no-stx? no-rt?))] + [(#:omit-define-syntaxes) + (if no-stx? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? #t no-rt?))] + [(#:omit-define-values) + (if no-rt? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? no-stx? #t))] + [else + (raise-syntax-error #f + (string-append + "expected a keyword to specify option: " + "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") + stx + opt)]))))]) + (cons + #`(define-syntaxes (name) + #,(build-struct-expand-info + #'name (syntax->list #'(field ...)) + #f (not mutable?) + #f '(#f) '(#f) + #:omit-constructor? no-ctr?)) + (let ([names (build-struct-names #'name (syntax->list #'(field ...)) + #f (not mutable?))]) + (if no-ctr? + (cons (car names) (cddr names)) + names)))))) + ((_ name fields opt ...) + (raise-syntax-error #f + "bad syntax; expected a parenthesized sequence of fields" + stx + #'fields)) + ((_ name) + (raise-syntax-error #f + "bad syntax; missing fields" + stx)) + ((_) + (raise-syntax-error #f + "missing name and fields" + stx)))) + (define-signature-form (struct/ctc stx) (parameterize ((error-syntax stx)) (syntax-case stx () @@ -214,6 +309,118 @@ ((_) (raise-stx-err "missing name and fields"))))) +;; Replacement struct/ctc form for `scheme/unit': +(define-signature-form (struct~/ctc stx) + (syntax-case stx () + ((_ name ([field ctc] ...) opt ...) + (begin + (unless (identifier? #'name) + (raise-syntax-error #f + "expected an identifier to name the structure type" + stx + #'name)) + (for-each (lambda (field) + (unless (identifier? field) + (syntax-case field () + [(id #:mutable) + (identifier? #'id) + 'ok] + [_ + (raise-syntax-error #f + "bad field specification" + stx + field)]))) + (syntax->list #'(field ...))) + (let-values ([(no-ctr? mutable? no-stx? no-rt?) + (let loop ([opts (syntax->list #'(opt ...))] + [no-ctr? #f] + [mutable? #f] + [no-stx? #f] + [no-rt? #f]) + (if (null? opts) + (values no-ctr? mutable? no-stx? no-rt?) + (let ([opt (car opts)]) + (case (syntax-e opt) + [(#:omit-constructor) + (if no-ctr? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) #t mutable? no-stx? no-rt?))] + [(#:mutable) + (if mutable? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? #t no-stx? no-rt?))] + [(#:omit-define-syntaxes) + (if no-stx? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? #t no-rt?))] + [(#:omit-define-values) + (if no-rt? + (raise-syntax-error #f + "redundant option" + stx + opt) + (loop (cdr opts) no-ctr? mutable? no-stx? #t))] + [else + (raise-syntax-error #f + (string-append + "expected a keyword to specify option: " + "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") + stx + opt)]))))]) + (define (add-contracts l) + (let* ([pred (caddr l)] + [ctor-ctc #`(-> ctc ... #,pred)] + [pred-ctc #'(-> any/c boolean?)] + [field-ctcs + (apply append + (map (λ (f c) + (cons #`(-> #,pred #,c) + (if (and (not mutable?) + (not (pair? (syntax-e f)))) + null + #`(-> #,pred #,c void?)))) + (syntax->list #'(field ...)) + (syntax->list #'(ctc ...))))]) + (list* (car l) + (list (cadr l) ctor-ctc) + (list pred pred-ctc) + (map list (cdddr l) field-ctcs)))) + (cons + #`(define-syntaxes (name) + #,(build-struct-expand-info + #'name (syntax->list #'(field ...)) + #f (not mutable?) + #f '(#f) '(#f) + #:omit-constructor? no-ctr?)) + (let* ([names (add-contracts + (build-struct-names #'name (syntax->list #'(field ...)) + #f (not mutable?)))] + [cpairs (cons 'contracted + (if no-ctr? (cddr names) (cdr names)))]) + (list (car names) cpairs)))))) + ((_ name fields opt ...) + (raise-syntax-error #f + "bad syntax; expected a parenthesized sequence of fields" + stx + #'fields)) + ((_ name) + (raise-syntax-error #f + "bad syntax; missing fields" + stx)) + ((_) + (raise-syntax-error #f + "missing name and fields" + stx)))) + ;; build-val+macro-defs : sig -> (list syntax-object^3) (define-for-syntax (build-val+macro-defs sig) @@ -395,7 +602,10 @@ (let ((trans (set!-trans-extract (syntax-local-value - (syntax-local-introduce #'x) + ;; redirect struct~ to struct~~ + (if (free-identifier=? #'x #'struct~) + #'struct~~ + (syntax-local-introduce #'x)) (lambda () (raise-stx-err "unknown signature form" #'x)))))) (unless (signature-form? trans) From b2b3c44aa45e896a7068c4989cd8faa4fca3a27b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Apr 2010 13:54:40 +0000 Subject: [PATCH 3/6] add define-values-for-export to scheme/unit; sort out different unit-signature 'struct' forms for mzlib vs. scheme vs. racket svn: r18792 original commit: b4aa4d4afb76d2ab57a2fa8ca0ad5ad3173e466a --- collects/mzlib/unit.ss | 148 ++++++++++++++++++++++++++++++++--------- 1 file changed, 116 insertions(+), 32 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index b1ae2bf..5a0d8b5 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -8,6 +8,7 @@ syntax/name syntax/parse syntax/struct + scheme/struct-info syntax/stx unstable/location "private/unit-contract-syntax.ss" @@ -27,6 +28,7 @@ (provide define-signature-form struct struct/ctc open define-signature provide-signature-elements only except rename import export prefix link tag init-depend extends contracted + define-values-for-export unit? (rename-out [:unit unit]) define-unit compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer @@ -37,7 +39,8 @@ unit/new-import-export define-unit/new-import-export unit/s define-unit/s unit/c define-unit/contract - struct~ struct~/ctc) + struct~s struct~s/ctc + struct~r struct~r/ctc) (define-syntax/err-param (define-signature-form stx) (syntax-case stx () @@ -132,8 +135,26 @@ ((_) (raise-stx-err "missing name and fields"))))) +(begin-for-syntax + (define-struct self-name-struct-info (id) + #:super struct:struct-info + #:property prop:procedure (lambda (me stx) + (syntax-case stx () + [(_ arg ...) (datum->syntax + stx + (cons (self-name-struct-info-id me) + #'(arg ...)) + stx + stx)] + [_ (let ([id (self-name-struct-info-id me)]) + (datum->syntax id + (syntax-e id) + stx + stx))])) + #:omit-define-syntaxes)) + ;; Replacement `struct' signature form for `scheme/unit': -(define-signature-form (struct~~ stx) +(define-for-syntax (do-struct~ stx type-as-ctr?) (syntax-case stx () ((_ name (field ...) opt ...) (begin @@ -198,19 +219,30 @@ "expected a keyword to specify option: " "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") stx - opt)]))))]) + opt)]))))] + [(tmp-name) (and type-as-ctr? + (car (generate-temporaries #'(name))))]) (cons #`(define-syntaxes (name) - #,(build-struct-expand-info - #'name (syntax->list #'(field ...)) - #f (not mutable?) - #f '(#f) '(#f) - #:omit-constructor? no-ctr?)) + #,(let ([e (build-struct-expand-info + #'name (syntax->list #'(field ...)) + #f (not mutable?) + #f '(#f) '(#f) + #:omit-constructor? no-ctr? + #:constructor-name (and type-as-ctr? (cons #'name tmp-name)))]) + (if type-as-ctr? + #`(make-self-name-struct-info + (lambda () #,e) + (quote-syntax #,tmp-name)) + e))) (let ([names (build-struct-names #'name (syntax->list #'(field ...)) - #f (not mutable?))]) - (if no-ctr? - (cons (car names) (cddr names)) - names)))))) + #f (not mutable?) + #:constructor-name (and type-as-ctr? + (cons #'name tmp-name)))]) + (cond + [no-ctr? (cons (car names) (cddr names))] + [tmp-name (cons #`(define-values-for-export (#,tmp-name) name) names)] + [else names])))))) ((_ name fields opt ...) (raise-syntax-error #f "bad syntax; expected a parenthesized sequence of fields" @@ -225,6 +257,11 @@ "missing name and fields" stx)))) +(define-signature-form (struct~s stx) + (do-struct~ stx #f)) +(define-signature-form (struct~r stx) + (do-struct~ stx #t)) + (define-signature-form (struct/ctc stx) (parameterize ((error-syntax stx)) (syntax-case stx () @@ -310,7 +347,7 @@ (raise-stx-err "missing name and fields"))))) ;; Replacement struct/ctc form for `scheme/unit': -(define-signature-form (struct~/ctc stx) +(define-for-syntax (do-struct~/ctc stx type-as-ctr?) (syntax-case stx () ((_ name ([field ctc] ...) opt ...) (begin @@ -375,7 +412,9 @@ "expected a keyword to specify option: " "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") stx - opt)]))))]) + opt)]))))] + [(tmp-name) (and type-as-ctr? + (car (generate-temporaries #'(name))))]) (define (add-contracts l) (let* ([pred (caddr l)] [ctor-ctc #`(-> ctc ... #,pred)] @@ -400,10 +439,13 @@ #'name (syntax->list #'(field ...)) #f (not mutable?) #f '(#f) '(#f) - #:omit-constructor? no-ctr?)) + #:omit-constructor? no-ctr? + #:constructor-name (and type-as-ctr? (cons #'name tmp-name)))) (let* ([names (add-contracts (build-struct-names #'name (syntax->list #'(field ...)) - #f (not mutable?)))] + #f (not mutable?) + #:constructor-name (and type-as-ctr? + (cons #'name tmp-name))))] [cpairs (cons 'contracted (if no-ctr? (cddr names) (cdr names)))]) (list (car names) cpairs)))))) @@ -421,28 +463,47 @@ "missing name and fields" stx)))) +(define-signature-form (struct~s/ctc stx) + (do-struct~/ctc stx #f)) +(define-signature-form (struct~r/ctc stx) + (do-struct~/ctc stx #t)) ;; build-val+macro-defs : sig -> (list syntax-object^3) (define-for-syntax (build-val+macro-defs sig) (with-syntax ([(((int-ivar . ext-ivar) ...) ((((int-vid . ext-vid) ...) . vbody) ...) ((((int-sid . ext-sid) ...) . sbody) ...) - (cbody ...)) + _ + _) (map-sig (lambda (x) x) (make-syntax-introducer) sig)]) (list #'((ext-ivar ... ext-vid ... ... ext-sid ... ...) (values - (make-rename-transformer - (quote-syntax int-ivar)) ... - (make-rename-transformer - (quote-syntax int-vid)) ... ... - (make-rename-transformer - (quote-syntax int-sid)) ... ...)) + (make-rename-transformer (quote-syntax int-ivar)) ... + (make-rename-transformer (quote-syntax int-vid)) ... ... + (make-rename-transformer (quote-syntax int-sid)) ... ...)) #'(((int-sid ...) sbody) ...) #'(((int-vid ...) vbody) ...)))) +;; build-post-val-defs : sig -> (list syntax-object) +(define-for-syntax (build-post-val-defs sig) + (with-syntax ([(((int-ivar . ext-ivar) ...) + ((((int-vid . ext-vid) ...) . _) ...) + ((((int-sid . ext-sid) ...) . _) ...) + _ + (((post-id ...) . post-rhs) ...)) + (map-sig (lambda (x) x) + (make-syntax-introducer) + sig)]) + (list + #'((ext-ivar ... ext-vid ... ... ext-sid ... ...) + (values + (make-rename-transformer (quote-syntax int-ivar)) ... + (make-rename-transformer (quote-syntax int-vid)) ... ... + (make-rename-transformer (quote-syntax int-sid)) ... ...)) + #'(post-rhs ...)))) (define-signature-form (open stx) (define (build-sig-elems sig) @@ -468,7 +529,9 @@ (_ (raise-stx-err (format "must match (~a export-spec)" (syntax-e (stx-car stx)))))))) - + +(define-signature-form (define-values-for-export stx) + (raise-syntax-error #f "internal error" stx)) (define-for-syntax (introduce-def d) (cons (map syntax-local-introduce (car d)) @@ -480,7 +543,8 @@ (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs)) (let ([ses (checked-syntax->list sig-exprs)]) (define-values (super-names super-ctimes super-rtimes super-bindings - super-val-defs super-stx-defs super-ctcs) + super-val-defs super-stx-defs super-post-val-defs + super-ctcs) (if super-sigid (let* ([super-sig (lookup-signature super-sigid)] [super-siginfo (signature-siginfo super-sig)]) @@ -491,22 +555,25 @@ (map syntax-local-introduce (signature-vars super-sig)) (map introduce-def (signature-val-defs super-sig)) (map introduce-def (signature-stx-defs super-sig)) + (map introduce-def (signature-post-val-defs super-sig)) (map (lambda (ctc) (if ctc (syntax-local-introduce ctc) ctc)) (signature-ctcs super-sig)))) - (values '() '() '() '() '() '() '()))) + (values '() '() '() '() '() '() '() '()))) (let loop ((sig-exprs ses) (bindings null) (val-defs null) (stx-defs null) + (post-val-defs null) (ctcs null)) (cond ((null? sig-exprs) (let* ([all-bindings (append super-bindings (reverse bindings))] [all-val-defs (append super-val-defs (reverse val-defs))] [all-stx-defs (append super-stx-defs (reverse stx-defs))] + [all-post-val-defs (append super-post-val-defs (reverse post-val-defs))] [all-ctcs (append super-ctcs (reverse ctcs))] [dup (check-duplicate-identifier @@ -520,7 +587,8 @@ ((var ...) all-bindings) ((ctc ...) all-ctcs) ((((vid ...) . vbody) ...) all-val-defs) - ((((sid ...) . sbody) ...) all-stx-defs)) + ((((sid ...) . sbody) ...) all-stx-defs) + ((((pvid ...) . pvbody) ...) all-post-val-defs)) #`(begin (define signature-tag (gensym)) (define-syntax #,sigid @@ -539,6 +607,10 @@ ((syntax-local-certifier) (quote-syntax sbody))) ...) + (list (cons (list (quote-syntax pvid) ...) + ((syntax-local-certifier) + (quote-syntax pvbody))) + ...) (list #,@(map (lambda (c) (if c #`((syntax-local-certifier) @@ -558,7 +630,7 @@ (syntax-case (car sig-exprs) (define-values define-syntaxes contracted) (x (identifier? #'x) - (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs))) + (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs post-val-defs (cons #f ctcs))) ((x (y z) ...) (and (identifier? #'x) (free-identifier=? #'x #'contracted) @@ -567,6 +639,7 @@ (append (syntax->list #'(y ...)) bindings) val-defs stx-defs + post-val-defs (append (syntax->list #'(z ...)) ctcs))) ((x . z) (and (identifier? #'x) @@ -578,7 +651,8 @@ ((x . y) (and (identifier? #'x) (or (free-identifier=? #'x #'define-values) - (free-identifier=? #'x #'define-syntaxes))) + (free-identifier=? #'x #'define-syntaxes) + (free-identifier=? #'x #'define-values-for-export))) (begin (check-def-syntax (car sig-exprs)) (syntax-case #'y () @@ -597,14 +671,18 @@ (cons (cons (syntax->list #'(name ...)) b) stx-defs) stx-defs) + (if (free-identifier=? #'x #'define-values-for-export) + (cons (cons (syntax->list #'(name ...)) b) + post-val-defs) + post-val-defs) ctcs))))))) ((x . y) (let ((trans (set!-trans-extract (syntax-local-value - ;; redirect struct~ to struct~~ + ;; redirect struct~ to struct~r (if (free-identifier=? #'x #'struct~) - #'struct~~ + #'struct~r (syntax-local-introduce #'x)) (lambda () (raise-stx-err "unknown signature form" #'x)))))) @@ -619,6 +697,7 @@ bindings val-defs stx-defs + post-val-defs ctcs)))) (x (raise-stx-err "expected either an identifier or signature form" @@ -742,6 +821,8 @@ (map build-val+macro-defs import-sigs)] [(((int-ivar . ext-ivar) ...) ...) (map car import-sigs)] [(((int-evar . ext-evar) ...) ...) (map car export-sigs)] + [((((e-post-id ...) . _) ...) ...) (map (lambda (s) (list-ref s 4)) export-sigs)] + [((post-renames (e-post-rhs ...)) ...) (map build-post-val-defs export-sigs)] [((iloc ...) ...) (map (lambda (x) (generate-temporaries (car x))) import-sigs)] [((eloc ...) ...) @@ -812,7 +893,10 @@ (int-evar ... ...) (eloc ... ...) (ectc ... ...) - . body))))) + (begin . body) + (define-values (e-post-id ...) + (letrec-syntaxes+values (post-renames ...) () + e-post-rhs)) ... ...))))) (unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...))))))) import-tagged-sigids export-tagged-sigids From 7b544af2a56eea29d5dc95f22060132434a13d4b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 20 Apr 2010 15:24:48 -0600 Subject: [PATCH 4/6] move most of the 'scheme' collection to the 'racket' collection original commit: c95a39875453e7f057395a7bf626e5d2ed732e7e --- collects/mzlib/class.ss | 2 +- collects/mzlib/contract.ss | 30 ++++----- collects/mzlib/etc.ss | 4 +- collects/mzlib/list.ss | 30 ++------- collects/mzlib/match.ss | 6 +- collects/mzlib/plt-match.ss | 4 +- collects/mzlib/port.ss | 65 +++++++++---------- collects/mzlib/private/contract-arr-checks.ss | 4 +- .../mzlib/private/contract-arr-obj-helpers.ss | 2 +- collects/mzlib/private/contract-arrow.ss | 12 ++-- collects/mzlib/private/contract-define.ss | 8 +-- collects/mzlib/private/contract-object.ss | 10 +-- collects/mzlib/serialize.ss | 4 +- collects/mzlib/unit.ss | 2 +- .../{scheme/mpair.ss => racket/mpair.rkt} | 0 .../{scheme/package.ss => racket/package.rkt} | 0 .../old-ds.ss => racket/private/old-ds.rkt} | 0 .../old-if.ss => racket/private/old-if.rkt} | 0 .../private/old-procs.rkt} | 10 +-- .../old-rp.ss => racket/private/old-rp.rkt} | 2 +- .../private/stxmz-body.rkt} | 4 +- collects/scheme/mpair.rkt | 2 + collects/scheme/package.rkt | 2 + 23 files changed, 94 insertions(+), 109 deletions(-) rename collects/{scheme/mpair.ss => racket/mpair.rkt} (100%) rename collects/{scheme/package.ss => racket/package.rkt} (100%) rename collects/{scheme/private/old-ds.ss => racket/private/old-ds.rkt} (100%) rename collects/{scheme/private/old-if.ss => racket/private/old-if.rkt} (100%) rename collects/{scheme/private/old-procs.ss => racket/private/old-procs.rkt} (96%) rename collects/{scheme/private/old-rp.ss => racket/private/old-rp.rkt} (96%) rename collects/{scheme/private/stxmz-body.ss => racket/private/stxmz-body.rkt} (91%) create mode 100644 collects/scheme/mpair.rkt create mode 100644 collects/scheme/package.rkt diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index 55e0f0d..4e2e272 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -1,3 +1,3 @@ (module class mzscheme - (require scheme/private/class-internal) + (require racket/private/class-internal) (provide-public-names)) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 3c6ef88..8516d28 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -25,37 +25,37 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -;; provide everything from the scheme/ implementation +;; provide everything from the racket/ implementation ;; except the arrow contracts ;; -(require scheme/contract/private/base - scheme/contract/private/misc - scheme/contract/private/provide - scheme/contract/private/guts - scheme/contract/private/ds - scheme/contract/private/opt - scheme/contract/private/basic-opters) +(require racket/contract/private/base + racket/contract/private/misc + racket/contract/private/provide + racket/contract/private/guts + racket/contract/private/ds + racket/contract/private/opt + racket/contract/private/basic-opters) (provide opt/c define-opt/c ;(all-from "private/contract-opt.ss") - (except-out (all-from-out scheme/contract/private/ds) + (except-out (all-from-out racket/contract/private/ds) lazy-depth-to-look) - (all-from-out scheme/contract/private/base) - (all-from-out scheme/contract/private/provide) - (except-out (all-from-out scheme/contract/private/misc) + (all-from-out racket/contract/private/base) + (all-from-out racket/contract/private/provide) + (except-out (all-from-out racket/contract/private/misc) check-between/c string-len/c check-unary-between/c) (rename-out [or/c union]) (rename-out [string-len/c string/len]) - (except-out (all-from-out scheme/contract/private/guts) + (except-out (all-from-out racket/contract/private/guts) check-flat-contract check-flat-named-contract)) -;; copied here because not provided by scheme/contract anymore +;; copied here because not provided by racket/contract anymore (define (flat-contract/predicate? pred) (or (flat-contract? pred) (and (procedure? pred) diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index c9b28bb..9add9b9 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -1,8 +1,8 @@ #lang mzscheme (require setup/main-collects - scheme/local - scheme/bool + racket/local + racket/bool (only scheme/base build-string build-list diff --git a/collects/mzlib/list.ss b/collects/mzlib/list.ss index c8b3a4d..4457338 100644 --- a/collects/mzlib/list.ss +++ b/collects/mzlib/list.ss @@ -1,31 +1,13 @@ -#lang mzscheme +#lang racket/base ;; The `first', etc. operations in this library ;; work on pairs, not lists. -(require (only scheme/base - foldl - foldr - - remv - remq - remove - remv* - remq* - remove* - - findf - memf - assf - - filter - - sort) - (only scheme/list - cons? - empty? - empty - last-pair)) +(require (only-in scheme/list + cons? + empty? + empty + last-pair)) (provide first second diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss index d38a78a..8362e9a 100644 --- a/collects/mzlib/match.ss +++ b/collects/mzlib/match.ss @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base -(require scheme/match/legacy-match) -(provide (all-from-out scheme/match/legacy-match)) +(require racket/match/legacy-match) +(provide (all-from-out racket/match/legacy-match)) diff --git a/collects/mzlib/plt-match.ss b/collects/mzlib/plt-match.ss index 84e08e6..add845a 100644 --- a/collects/mzlib/plt-match.ss +++ b/collects/mzlib/plt-match.ss @@ -1,4 +1,4 @@ #lang scheme/base -(require scheme/match/match) -(provide (all-from-out scheme/match/match)) +(require racket/match/match) +(provide (all-from-out racket/match/match)) diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss index 56b1203..c588143 100644 --- a/collects/mzlib/port.ss +++ b/collects/mzlib/port.ss @@ -1,8 +1,7 @@ -#lang scheme/base +#lang racket/base -(require (for-syntax scheme/base) - mzlib/etc - scheme/contract/base +(require (for-syntax racket/base) + racket/contract/base mzlib/list "private/port.ss") @@ -118,13 +117,13 @@ ;; 0 always (which implies that the `read' proc must not return ;; a pipe input port). (define make-input-port/read-to-peek - (opt-lambda (name read fast-peek close - [location-proc #f] - [count-lines!-proc void] - [init-position 1] - [buffer-mode-proc #f] - [buffering? #f] - [on-consumed #f]) + (lambda (name read fast-peek close + [location-proc #f] + [count-lines!-proc void] + [init-position 1] + [buffer-mode-proc #f] + [buffering? #f] + [on-consumed #f]) (define lock-semaphore (make-semaphore 1)) (define commit-semaphore (make-semaphore 1)) (define-values (peeked-r peeked-w) (make-pipe)) @@ -440,7 +439,7 @@ (buffer-mode-proc mode)]))))) (define peeking-input-port - (opt-lambda (orig-in [name (object-name orig-in)] [delta 0]) + (lambda (orig-in [name (object-name orig-in)] [delta 0]) (make-input-port/read-to-peek name (lambda (s) @@ -452,11 +451,11 @@ void))) (define relocate-input-port - (opt-lambda (p line col pos [close? #t]) + (lambda (p line col pos [close? #t]) (transplant-to-relocate transplant-input-port p line col pos close?))) (define transplant-input-port - (opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void]) + (lambda (p location-proc pos [close? #t] [count-lines!-proc void]) (make-input-port (object-name p) (lambda (s) @@ -486,7 +485,7 @@ ;; thread when write evts are active; otherwise, we use a lock semaphore. ;; (Actually, the lock semaphore has to be used all the time, to guard ;; the flag indicating whether the manager thread is running.) - (opt-lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe]) + (lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe]) (let-values ([(r w) (make-pipe limit)] [(more) null] [(more-last) #f] @@ -724,7 +723,7 @@ (values in out)))) (define input-port-append - (opt-lambda (close-orig? . ports) + (lambda (close-orig? . ports) (make-input-port (map object-name ports) (lambda (str) @@ -815,7 +814,7 @@ (loop half skip))))))) (define make-limited-input-port - (opt-lambda (port limit [close-orig? #t]) + (lambda (port limit [close-orig? #t]) (let ([got 0]) (make-input-port (object-name port) @@ -1208,13 +1207,13 @@ (loop (add1 i) (add1 j))]))))])) (define reencode-input-port - (opt-lambda (port encoding [error-bytes #f] [close? #f] - [name (object-name port)] - [newline-convert? #f] - [decode-error (lambda (msg port) - (error 'reencode-input-port - (format "~a: ~e" msg) - port))]) + (lambda (port encoding [error-bytes #f] [close? #f] + [name (object-name port)] + [newline-convert? #f] + [decode-error (lambda (msg port) + (error 'reencode-input-port + (format "~a: ~e" msg) + port))]) (let ([c (let ([c (bytes-open-converter encoding "UTF-8")]) (if newline-convert? (mcons c #f) c))] [ready-bytes (make-bytes 1024)] @@ -1345,13 +1344,13 @@ ;; -------------------------------------------------- (define reencode-output-port - (opt-lambda (port encoding [error-bytes #f] [close? #f] - [name (object-name port)] - [convert-newlines-to #f] - [decode-error (lambda (msg port) - (error 'reencode-input-port - (format "~a: ~e" msg) - port))]) + (lambda (port encoding [error-bytes #f] [close? #f] + [name (object-name port)] + [convert-newlines-to #f] + [decode-error (lambda (msg port) + (error 'reencode-input-port + (format "~a: ~e" msg) + port))]) (let ([c (bytes-open-converter "UTF-8" encoding)] [ready-bytes (make-bytes 1024)] [ready-start 0] @@ -1664,7 +1663,7 @@ ;; ---------------------------------------- (define dup-output-port - (opt-lambda (p [close? #f]) + (lambda (p [close? #f]) (let ([new (transplant-output-port p (lambda () (port-next-location p)) @@ -1677,7 +1676,7 @@ new))) (define dup-input-port - (opt-lambda (p [close? #f]) + (lambda (p [close? #f]) (let ([new (transplant-input-port p (lambda () (port-next-location p)) diff --git a/collects/mzlib/private/contract-arr-checks.ss b/collects/mzlib/private/contract-arr-checks.ss index 5410d74..9bbb341 100644 --- a/collects/mzlib/private/contract-arr-checks.ss +++ b/collects/mzlib/private/contract-arr-checks.ss @@ -1,7 +1,7 @@ -#lang scheme/base +#lang racket/base (provide (all-defined-out)) -(require scheme/contract/private/guts) +(require racket/contract/private/guts) (define empty-case-lambda/c (flat-named-contract '(case->) diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss index cb38466..5123ffd 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.ss +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -4,7 +4,7 @@ (require (for-syntax scheme/base)) (require (for-template scheme/base) - (for-template scheme/contract/private/guts) + (for-template racket/contract/private/guts) (for-template "contract-arr-checks.ss")) (provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 2b13878..038951a 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -1,11 +1,11 @@ -#lang scheme/base +#lang racket/base -(require scheme/contract/private/guts - scheme/contract/private/opt +(require racket/contract/private/guts + racket/contract/private/opt "contract-arr-checks.ss") -(require (for-syntax scheme/base) - (for-syntax scheme/contract/private/opt-guts) - (for-syntax scheme/contract/private/helpers) +(require (for-syntax racket/base) + (for-syntax racket/contract/private/opt-guts) + (for-syntax racket/contract/private/helpers) (for-syntax "contract-arr-obj-helpers.ss") (for-syntax syntax/stx) (for-syntax syntax/name)) diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss index 4cece1f..faad09a 100644 --- a/collects/mzlib/private/contract-define.ss +++ b/collects/mzlib/private/contract-define.ss @@ -1,11 +1,11 @@ -#lang scheme/base +#lang racket/base (provide define/contract) -(require (for-syntax scheme/base +(require (for-syntax racket/base unstable/srcloc - (prefix-in a: scheme/contract/private/helpers)) - (only-in scheme/contract/private/base contract)) + (prefix-in a: racket/contract/private/helpers)) + (only-in racket/contract/private/base contract)) ;; First, we have the old define/contract implementation, which ;; is still used in mzlib/contract. diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index 7b7579f..66cc2c5 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -1,11 +1,11 @@ -#lang scheme/base +#lang racket/base (require "contract-arrow.ss" - scheme/contract/private/guts - scheme/private/class-internal + racket/contract/private/guts + racket/private/class-internal "contract-arr-checks.ss") -(require (for-syntax scheme/base - scheme/contract/private/helpers +(require (for-syntax racket/base + racket/contract/private/helpers "contract-arr-obj-helpers.ss")) (provide mixin-contract diff --git a/collects/mzlib/serialize.ss b/collects/mzlib/serialize.ss index ed816f9..e455013 100644 --- a/collects/mzlib/serialize.ss +++ b/collects/mzlib/serialize.ss @@ -4,13 +4,13 @@ mzlib/etc mzlib/list ;; core [de]serializer: - scheme/private/serialize) + racket/private/serialize) (provide define-serializable-struct define-serializable-struct/versions ;; core [de]serializer: - (all-from scheme/private/serialize)) + (all-from racket/private/serialize)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; define-serializable-struct diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 5a0d8b5..3c03679 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -16,7 +16,7 @@ "private/unit-syntax.ss")) (require mzlib/etc - scheme/contract/base + racket/contract/base scheme/stxparam unstable/location "private/unit-contract.ss" diff --git a/collects/scheme/mpair.ss b/collects/racket/mpair.rkt similarity index 100% rename from collects/scheme/mpair.ss rename to collects/racket/mpair.rkt diff --git a/collects/scheme/package.ss b/collects/racket/package.rkt similarity index 100% rename from collects/scheme/package.ss rename to collects/racket/package.rkt diff --git a/collects/scheme/private/old-ds.ss b/collects/racket/private/old-ds.rkt similarity index 100% rename from collects/scheme/private/old-ds.ss rename to collects/racket/private/old-ds.rkt diff --git a/collects/scheme/private/old-if.ss b/collects/racket/private/old-if.rkt similarity index 100% rename from collects/scheme/private/old-if.ss rename to collects/racket/private/old-if.rkt diff --git a/collects/scheme/private/old-procs.ss b/collects/racket/private/old-procs.rkt similarity index 96% rename from collects/scheme/private/old-procs.ss rename to collects/racket/private/old-procs.rkt index 7a074fd..632acb6 100644 --- a/collects/scheme/private/old-procs.ss +++ b/collects/racket/private/old-procs.rkt @@ -1,10 +1,10 @@ (module old-procs '#%kernel - (#%require "small-scheme.ss" - "more-scheme.ss" - "misc.ss" - "stxmz-body.ss" - "define.ss") + (#%require "small-scheme.rkt" + "more-scheme.rkt" + "misc.rkt" + "stxmz-body.rkt" + "define.rkt") (#%provide make-namespace free-identifier=?* diff --git a/collects/scheme/private/old-rp.ss b/collects/racket/private/old-rp.rkt similarity index 96% rename from collects/scheme/private/old-rp.ss rename to collects/racket/private/old-rp.rkt index 2634ece..74f1554 100644 --- a/collects/scheme/private/old-rp.ss +++ b/collects/racket/private/old-rp.rkt @@ -1,6 +1,6 @@ (module old-rp '#%kernel - (#%require (for-syntax '#%kernel "stx.ss" "small-scheme.ss" "stxcase-scheme.ss")) + (#%require (for-syntax '#%kernel "stx.rkt" "small-scheme.rkt" "stxcase-scheme.rkt")) (#%provide require require-for-syntax require-for-template require-for-label provide provide-for-syntax provide-for-label) diff --git a/collects/scheme/private/stxmz-body.ss b/collects/racket/private/stxmz-body.rkt similarity index 91% rename from collects/scheme/private/stxmz-body.ss rename to collects/racket/private/stxmz-body.rkt index 8ae50ce..20e1984 100644 --- a/collects/scheme/private/stxmz-body.ss +++ b/collects/racket/private/stxmz-body.rkt @@ -2,8 +2,8 @@ ;; mzscheme's `#%module-begin' (module stxmz-body '#%kernel - (#%require "stxcase-scheme.ss" "define.ss" - (for-syntax '#%kernel "stx.ss")) + (#%require "stxcase-scheme.rkt" "define.rkt" + (for-syntax '#%kernel "stx.rkt")) ;; So that expansions print the way the MzScheme programmer expects: (#%require (rename '#%kernel #%plain-module-begin #%module-begin)) diff --git a/collects/scheme/mpair.rkt b/collects/scheme/mpair.rkt new file mode 100644 index 0000000..fd74621 --- /dev/null +++ b/collects/scheme/mpair.rkt @@ -0,0 +1,2 @@ +#lang scheme/private/provider +racket/mpair diff --git a/collects/scheme/package.rkt b/collects/scheme/package.rkt new file mode 100644 index 0000000..332c173 --- /dev/null +++ b/collects/scheme/package.rkt @@ -0,0 +1,2 @@ +#lang scheme/private/provider +racket/package From a9c5ca02a2eaf38a53f3853786361d44b48fc8fc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 27 Apr 2010 18:28:39 -0600 Subject: [PATCH 5/6] move tests/mzscheme to tests/racket original commit: 882b7dce0eaf92eab6fe45565ca6c1a09aa26027 --- collects/tests/{mzscheme => racket}/awk.rkt | 0 collects/tests/{mzscheme => racket}/binc.rkt | 0 collects/tests/{mzscheme => racket}/compat.rkt | 0 collects/tests/{mzscheme => racket}/contract-mzlib-test.rkt | 0 collects/tests/{mzscheme => racket}/etc.rkt | 0 collects/tests/{mzscheme => racket}/kw.rkt | 0 collects/tests/{mzscheme => racket}/macrolib.rkt | 0 collects/tests/{mzscheme => racket}/pconvert.rkt | 0 collects/tests/{mzscheme => racket}/restart.rkt | 0 collects/tests/{mzscheme => racket}/string-mzlib.rkt | 0 collects/tests/{mzscheme => racket}/structlib.rkt | 0 collects/tests/{mzscheme => racket}/threadlib.rkt | 0 collects/tests/{mzscheme => racket}/uinc.rkt | 0 collects/tests/{mzscheme => racket}/uinc2.rkt | 0 collects/tests/{mzscheme => racket}/unit.rkt | 0 collects/tests/{mzscheme => racket}/unitsig.rkt | 0 16 files changed, 0 insertions(+), 0 deletions(-) rename collects/tests/{mzscheme => racket}/awk.rkt (100%) rename collects/tests/{mzscheme => racket}/binc.rkt (100%) rename collects/tests/{mzscheme => racket}/compat.rkt (100%) rename collects/tests/{mzscheme => racket}/contract-mzlib-test.rkt (100%) rename collects/tests/{mzscheme => racket}/etc.rkt (100%) rename collects/tests/{mzscheme => racket}/kw.rkt (100%) rename collects/tests/{mzscheme => racket}/macrolib.rkt (100%) rename collects/tests/{mzscheme => racket}/pconvert.rkt (100%) rename collects/tests/{mzscheme => racket}/restart.rkt (100%) rename collects/tests/{mzscheme => racket}/string-mzlib.rkt (100%) rename collects/tests/{mzscheme => racket}/structlib.rkt (100%) rename collects/tests/{mzscheme => racket}/threadlib.rkt (100%) rename collects/tests/{mzscheme => racket}/uinc.rkt (100%) rename collects/tests/{mzscheme => racket}/uinc2.rkt (100%) rename collects/tests/{mzscheme => racket}/unit.rkt (100%) rename collects/tests/{mzscheme => racket}/unitsig.rkt (100%) diff --git a/collects/tests/mzscheme/awk.rkt b/collects/tests/racket/awk.rkt similarity index 100% rename from collects/tests/mzscheme/awk.rkt rename to collects/tests/racket/awk.rkt diff --git a/collects/tests/mzscheme/binc.rkt b/collects/tests/racket/binc.rkt similarity index 100% rename from collects/tests/mzscheme/binc.rkt rename to collects/tests/racket/binc.rkt diff --git a/collects/tests/mzscheme/compat.rkt b/collects/tests/racket/compat.rkt similarity index 100% rename from collects/tests/mzscheme/compat.rkt rename to collects/tests/racket/compat.rkt diff --git a/collects/tests/mzscheme/contract-mzlib-test.rkt b/collects/tests/racket/contract-mzlib-test.rkt similarity index 100% rename from collects/tests/mzscheme/contract-mzlib-test.rkt rename to collects/tests/racket/contract-mzlib-test.rkt diff --git a/collects/tests/mzscheme/etc.rkt b/collects/tests/racket/etc.rkt similarity index 100% rename from collects/tests/mzscheme/etc.rkt rename to collects/tests/racket/etc.rkt diff --git a/collects/tests/mzscheme/kw.rkt b/collects/tests/racket/kw.rkt similarity index 100% rename from collects/tests/mzscheme/kw.rkt rename to collects/tests/racket/kw.rkt diff --git a/collects/tests/mzscheme/macrolib.rkt b/collects/tests/racket/macrolib.rkt similarity index 100% rename from collects/tests/mzscheme/macrolib.rkt rename to collects/tests/racket/macrolib.rkt diff --git a/collects/tests/mzscheme/pconvert.rkt b/collects/tests/racket/pconvert.rkt similarity index 100% rename from collects/tests/mzscheme/pconvert.rkt rename to collects/tests/racket/pconvert.rkt diff --git a/collects/tests/mzscheme/restart.rkt b/collects/tests/racket/restart.rkt similarity index 100% rename from collects/tests/mzscheme/restart.rkt rename to collects/tests/racket/restart.rkt diff --git a/collects/tests/mzscheme/string-mzlib.rkt b/collects/tests/racket/string-mzlib.rkt similarity index 100% rename from collects/tests/mzscheme/string-mzlib.rkt rename to collects/tests/racket/string-mzlib.rkt diff --git a/collects/tests/mzscheme/structlib.rkt b/collects/tests/racket/structlib.rkt similarity index 100% rename from collects/tests/mzscheme/structlib.rkt rename to collects/tests/racket/structlib.rkt diff --git a/collects/tests/mzscheme/threadlib.rkt b/collects/tests/racket/threadlib.rkt similarity index 100% rename from collects/tests/mzscheme/threadlib.rkt rename to collects/tests/racket/threadlib.rkt diff --git a/collects/tests/mzscheme/uinc.rkt b/collects/tests/racket/uinc.rkt similarity index 100% rename from collects/tests/mzscheme/uinc.rkt rename to collects/tests/racket/uinc.rkt diff --git a/collects/tests/mzscheme/uinc2.rkt b/collects/tests/racket/uinc2.rkt similarity index 100% rename from collects/tests/mzscheme/uinc2.rkt rename to collects/tests/racket/uinc2.rkt diff --git a/collects/tests/mzscheme/unit.rkt b/collects/tests/racket/unit.rkt similarity index 100% rename from collects/tests/mzscheme/unit.rkt rename to collects/tests/racket/unit.rkt diff --git a/collects/tests/mzscheme/unitsig.rkt b/collects/tests/racket/unitsig.rkt similarity index 100% rename from collects/tests/mzscheme/unitsig.rkt rename to collects/tests/racket/unitsig.rkt From 212171f54fd28d45b6ffa5cbd1df40f19db1c07e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 1 May 2010 09:57:07 -0600 Subject: [PATCH 6/6] use .rktl suffix for files meant to be 'load'ed original commit: e504acb72622f4668a50770476fc7545ef9450b0 --- collects/tests/racket/{awk.rkt => awk.rktl} | 2 +- collects/tests/racket/{binc.rkt => binc.rktl} | 0 collects/tests/racket/{compat.rkt => compat.rktl} | 2 +- ...act-mzlib-test.rkt => contract-mzlib-test.rktl} | 4 ++-- collects/tests/racket/{etc.rkt => etc.rktl} | 2 +- collects/tests/racket/{kw.rkt => kw.rktl} | 2 +- .../tests/racket/{macrolib.rkt => macrolib.rktl} | 2 +- .../tests/racket/{pconvert.rkt => pconvert.rktl} | 4 ++-- .../tests/racket/{restart.rkt => restart.rktl} | 2 +- .../racket/{string-mzlib.rkt => string-mzlib.rktl} | 2 +- .../tests/racket/{structlib.rkt => structlib.rktl} | 2 +- .../tests/racket/{threadlib.rkt => threadlib.rktl} | 2 +- collects/tests/racket/ttt/uinc4.rktl | 5 +++++ collects/tests/racket/{uinc.rkt => uinc.rktl} | 0 collects/tests/racket/{uinc2.rkt => uinc2.rktl} | 0 collects/tests/racket/uinc3.rktl | 7 +++++++ collects/tests/racket/{unit.rkt => unit.rktl} | 2 +- .../tests/racket/{unitsig.rkt => unitsig.rktl} | 14 +++++++------- 18 files changed, 33 insertions(+), 21 deletions(-) rename collects/tests/racket/{awk.rkt => awk.rktl} (96%) rename collects/tests/racket/{binc.rkt => binc.rktl} (100%) rename collects/tests/racket/{compat.rkt => compat.rktl} (94%) rename collects/tests/racket/{contract-mzlib-test.rkt => contract-mzlib-test.rktl} (99%) rename collects/tests/racket/{etc.rkt => etc.rktl} (97%) rename collects/tests/racket/{kw.rkt => kw.rktl} (99%) rename collects/tests/racket/{macrolib.rkt => macrolib.rktl} (99%) rename collects/tests/racket/{pconvert.rkt => pconvert.rktl} (99%) rename collects/tests/racket/{restart.rkt => restart.rktl} (97%) rename collects/tests/racket/{string-mzlib.rkt => string-mzlib.rktl} (99%) rename collects/tests/racket/{structlib.rkt => structlib.rktl} (97%) rename collects/tests/racket/{threadlib.rkt => threadlib.rktl} (98%) create mode 100644 collects/tests/racket/ttt/uinc4.rktl rename collects/tests/racket/{uinc.rkt => uinc.rktl} (100%) rename collects/tests/racket/{uinc2.rkt => uinc2.rktl} (100%) create mode 100644 collects/tests/racket/uinc3.rktl rename collects/tests/racket/{unit.rkt => unit.rktl} (99%) rename collects/tests/racket/{unitsig.rkt => unitsig.rktl} (99%) diff --git a/collects/tests/racket/awk.rkt b/collects/tests/racket/awk.rktl similarity index 96% rename from collects/tests/racket/awk.rkt rename to collects/tests/racket/awk.rktl index ecbbf6b..73d00c8 100644 --- a/collects/tests/racket/awk.rkt +++ b/collects/tests/racket/awk.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'awk) diff --git a/collects/tests/racket/binc.rkt b/collects/tests/racket/binc.rktl similarity index 100% rename from collects/tests/racket/binc.rkt rename to collects/tests/racket/binc.rktl diff --git a/collects/tests/racket/compat.rkt b/collects/tests/racket/compat.rktl similarity index 94% rename from collects/tests/racket/compat.rkt rename to collects/tests/racket/compat.rktl index b83e7ad..5e25b83 100644 --- a/collects/tests/racket/compat.rkt +++ b/collects/tests/racket/compat.rktl @@ -1,6 +1,6 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'compat) diff --git a/collects/tests/racket/contract-mzlib-test.rkt b/collects/tests/racket/contract-mzlib-test.rktl similarity index 99% rename from collects/tests/racket/contract-mzlib-test.rkt rename to collects/tests/racket/contract-mzlib-test.rktl index a748a6e..9789df3 100644 --- a/collects/tests/racket/contract-mzlib-test.rkt +++ b/collects/tests/racket/contract-mzlib-test.rktl @@ -1,12 +1,12 @@ #| -This file started out as a copy of contract-test.rkt. +This file started out as a copy of contract-test.rktl. Its purpose is to try to ensure that the mzlib version of the contract library does not change over time. |# -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'mzlib/contract) (parameterize ([error-print-width 200]) diff --git a/collects/tests/racket/etc.rkt b/collects/tests/racket/etc.rktl similarity index 97% rename from collects/tests/racket/etc.rkt rename to collects/tests/racket/etc.rktl index 1292002..4b462e9 100644 --- a/collects/tests/racket/etc.rkt +++ b/collects/tests/racket/etc.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'etc) diff --git a/collects/tests/racket/kw.rkt b/collects/tests/racket/kw.rktl similarity index 99% rename from collects/tests/racket/kw.rkt rename to collects/tests/racket/kw.rktl index d8ec3a8..185ae18 100644 --- a/collects/tests/racket/kw.rkt +++ b/collects/tests/racket/kw.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'kw) diff --git a/collects/tests/racket/macrolib.rkt b/collects/tests/racket/macrolib.rktl similarity index 99% rename from collects/tests/racket/macrolib.rkt rename to collects/tests/racket/macrolib.rktl index b79b23a..23eb8b0 100644 --- a/collects/tests/racket/macrolib.rkt +++ b/collects/tests/racket/macrolib.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'macrolib) diff --git a/collects/tests/racket/pconvert.rkt b/collects/tests/racket/pconvert.rktl similarity index 99% rename from collects/tests/racket/pconvert.rkt rename to collects/tests/racket/pconvert.rktl index 58385e9..534ec11 100644 --- a/collects/tests/racket/pconvert.rkt +++ b/collects/tests/racket/pconvert.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'pconvert) @@ -367,7 +367,7 @@ (test 'empty print-convert '()) -(let ([fn (make-temporary-file "pconvert.rkt-test~a")]) +(let ([fn (make-temporary-file "pconvert.rktl-test~a")]) (let ([in (open-input-file fn)]) (test `(open-input-file ,fn) print-convert in) (close-input-port in)) diff --git a/collects/tests/racket/restart.rkt b/collects/tests/racket/restart.rktl similarity index 97% rename from collects/tests/racket/restart.rkt rename to collects/tests/racket/restart.rktl index 56d5b03..2fcaa5f 100644 --- a/collects/tests/racket/restart.rkt +++ b/collects/tests/racket/restart.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (require mzlib/restart) diff --git a/collects/tests/racket/string-mzlib.rkt b/collects/tests/racket/string-mzlib.rktl similarity index 99% rename from collects/tests/racket/string-mzlib.rkt rename to collects/tests/racket/string-mzlib.rktl index 45f3573..2a5c20d 100644 --- a/collects/tests/racket/string-mzlib.rkt +++ b/collects/tests/racket/string-mzlib.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'mzlib-string) diff --git a/collects/tests/racket/structlib.rkt b/collects/tests/racket/structlib.rktl similarity index 97% rename from collects/tests/racket/structlib.rkt rename to collects/tests/racket/structlib.rktl index a827649..fc07a82 100644 --- a/collects/tests/racket/structlib.rkt +++ b/collects/tests/racket/structlib.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'structlib) diff --git a/collects/tests/racket/threadlib.rkt b/collects/tests/racket/threadlib.rktl similarity index 98% rename from collects/tests/racket/threadlib.rkt rename to collects/tests/racket/threadlib.rktl index b961afe..b5b4d38 100644 --- a/collects/tests/racket/threadlib.rkt +++ b/collects/tests/racket/threadlib.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'threadlib) diff --git a/collects/tests/racket/ttt/uinc4.rktl b/collects/tests/racket/ttt/uinc4.rktl new file mode 100644 index 0000000..bd0a771 --- /dev/null +++ b/collects/tests/racket/ttt/uinc4.rktl @@ -0,0 +1,5 @@ + +(define also-unused 'ok) + +(include (build-path up "uinc.rktl")) + diff --git a/collects/tests/racket/uinc.rkt b/collects/tests/racket/uinc.rktl similarity index 100% rename from collects/tests/racket/uinc.rkt rename to collects/tests/racket/uinc.rktl diff --git a/collects/tests/racket/uinc2.rkt b/collects/tests/racket/uinc2.rktl similarity index 100% rename from collects/tests/racket/uinc2.rkt rename to collects/tests/racket/uinc2.rktl diff --git a/collects/tests/racket/uinc3.rktl b/collects/tests/racket/uinc3.rktl new file mode 100644 index 0000000..bc16584 --- /dev/null +++ b/collects/tests/racket/uinc3.rktl @@ -0,0 +1,7 @@ + +(define unused 'hello) + +(include (build-path "ttt" "uinc4.rktl")) + + + diff --git a/collects/tests/racket/unit.rkt b/collects/tests/racket/unit.rktl similarity index 99% rename from collects/tests/racket/unit.rkt rename to collects/tests/racket/unit.rktl index 0e70240..3264672 100644 --- a/collects/tests/racket/unit.rkt +++ b/collects/tests/racket/unit.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") (Section 'unit) (require mzlib/unit200) diff --git a/collects/tests/racket/unitsig.rkt b/collects/tests/racket/unitsig.rktl similarity index 99% rename from collects/tests/racket/unitsig.rkt rename to collects/tests/racket/unitsig.rktl index 7dff08d..f47f015 100644 --- a/collects/tests/racket/unitsig.rkt +++ b/collects/tests/racket/unitsig.rktl @@ -1,5 +1,5 @@ -(load-relative "loadtest.rkt") +(load-relative "loadtest.rktl") ;; Hide keywords from scheme/unit.rkt: (define import #f) @@ -178,7 +178,7 @@ () (import) - (include "uinc.rkt"))) + (include "uinc.rktl"))) (test 9 'include (invoke-unit/sig i1@)) @@ -189,7 +189,7 @@ (import) (+ 3 4) - (include "uinc3.rkt"))) + (include "uinc3.rktl"))) (test 9 'include (invoke-unit/sig i1.5@)) @@ -198,9 +198,9 @@ () (import) - (include "uinc.rkt") - (include "uinc2.rkt") - (include "uinc.rkt") + (include "uinc.rktl") + (include "uinc2.rktl") + (include "uinc.rktl") (+ x 2))) (test 10 'include (invoke-unit/sig i2@)) @@ -212,7 +212,7 @@ (unit/sig () (import) (define x 5) - (include "binc.rkt") + (include "binc.rktl") y))) ; Simple: