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

change 'define-struct' to bind the type name as a constructor, add an #:extra-constructor-name option, etc.

Browse Source 
original commit: 616080c7c4bc10f3f758a198c6e94c394e051038
This commit is contained in:
Matthew Flatt 2010-04-25 12:10:36 -06:00
commit a4948a39a4
25 changed files with 290 additions and 229 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/class.ss
View File

@ -1,3 +1,3 @@
(module class mzscheme
(require scheme/private/class-internal)
(require racket/private/class-internal)
(provide-public-names))

30
collects/mzlib/contract.ss
View File

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

4
collects/mzlib/etc.ss
View File

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

30
collects/mzlib/list.ss
View File

@ -1,31 +1,13 @@
#lang mzscheme
#lang scheme/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

6
collects/mzlib/match.ss
View File

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

4
collects/mzlib/plt-match.ss
View File

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

65
collects/mzlib/port.ss
View File

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

4
collects/mzlib/private/contract-arr-checks.ss
View File

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

2
collects/mzlib/private/contract-arr-obj-helpers.ss
View File

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

12
collects/mzlib/private/contract-arrow.ss
View File

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

8
collects/mzlib/private/contract-define.ss
View File

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

10
collects/mzlib/private/contract-object.ss
View File

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

4
collects/mzlib/serialize.ss
View File

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

314
collects/mzlib/unit.ss
View File

@ -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"
@ -142,19 +142,22 @@
(syntax-case stx ()
[(_ arg ...) (datum->syntax
stx
(cons (self-name-struct-info-id me)
(cons ((self-name-struct-info-id me))
#'(arg ...))
stx
stx)]
[_ (let ([id (self-name-struct-info-id me)])
[_ (let ([id ((self-name-struct-info-id me))])
(datum->syntax id
(syntax-e id)
stx
stx))]))
#:omit-define-syntaxes))
(define-for-syntax option-keywords
"#:mutable, #:constructor-name, #:extra-constructor-name, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
;; Replacement `struct' signature form for `scheme/unit':
(define-for-syntax (do-struct~ stx type-as-ctr?)
(define-for-syntax (do-struct~ stx extra-make?)
(syntax-case stx ()
((_ name (field ...) opt ...)
(begin
@ -175,53 +178,85 @@
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)]))))]
[(tmp-name) (and type-as-ctr?
(car (generate-temporaries #'(name))))])
(let*-values ([(no-ctr? mutable? no-stx? no-rt? opt-cname)
(let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f]
[mutable? #f]
[no-stx? #f]
[no-rt? #f]
[cname #f])
(if (null? opts)
(values no-ctr? mutable? no-stx? no-rt? cname)
(let ([opt (car opts)])
(case (syntax-e opt)
[(#:constructor-name #:extra-constructor-name)
(if cname
(raise-syntax-error #f
"redundant option"
stx
opt)
(if (null? (cdr opts))
(raise-syntax-error #f
"missing identifier after option"
stx
opt)
(if (identifier? (cadr opts))
(loop (cddr opts) #f mutable? no-stx? no-rt?
(if (eq? (syntax-e opt) '#:extra-constructor-name)
(list (cadr opts))
(cadr opts)))
(raise-syntax-error #f
"not an identifier for a constructor name"
stx
(cadr opts)))))]
[(#:omit-constructor)
(if no-ctr?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) #t mutable? no-stx? no-rt? cname))]
[(#:mutable)
(if mutable?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))]
[(#:omit-define-syntaxes)
(if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt? cname))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t cname))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
option-keywords)
stx
opt)]))))]
[(def-cname) (cond
[opt-cname (if (pair? opt-cname)
(car opt-cname)
opt-cname)]
[extra-make? #f]
[else (car (generate-temporaries #'(name)))])]
[(cname) (cond
[opt-cname (if (pair? opt-cname)
(cons def-cname #'name)
(cons opt-cname opt-cname))]
[extra-make? #f]
[else (cons def-cname #'name)])]
[(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))])
(cons
#`(define-syntaxes (name)
#,(let ([e (build-struct-expand-info
@ -229,19 +264,19 @@
#f (not mutable?)
#f '(#f) '(#f)
#:omit-constructor? no-ctr?
#:constructor-name (and type-as-ctr? (cons #'name tmp-name)))])
(if type-as-ctr?
#:constructor-name def-cname)])
(if self-ctr?
#`(make-self-name-struct-info
(lambda () #,e)
(quote-syntax #,tmp-name))
(lambda () (quote-syntax #,def-cname)))
e)))
(let ([names (build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?)
#:constructor-name (and type-as-ctr?
(cons #'name tmp-name)))])
#:constructor-name def-cname)])
(cond
[no-ctr? (cons (car names) (cddr names))]
[tmp-name (cons #`(define-values-for-export (#,tmp-name) name) names)]
[self-ctr? (cons #`(define-values-for-export (#,def-cname) name)
names)]
[else names]))))))
((_ name fields opt ...)
(raise-syntax-error #f
@ -258,9 +293,9 @@
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~r stx)
(do-struct~ stx #f))
(define-signature-form (struct/ctc stx)
(parameterize ((error-syntax stx))
@ -347,7 +382,7 @@
(raise-stx-err "missing name and fields")))))
;; Replacement struct/ctc form for `scheme/unit':
(define-for-syntax (do-struct~/ctc stx type-as-ctr?)
(define-for-syntax (do-struct~/ctc stx extra-make?)
(syntax-case stx ()
((_ name ([field ctc] ...) opt ...)
(begin
@ -368,53 +403,85 @@
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)]))))]
[(tmp-name) (and type-as-ctr?
(car (generate-temporaries #'(name))))])
(let*-values ([(no-ctr? mutable? no-stx? no-rt? opt-cname)
(let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f]
[mutable? #f]
[no-stx? #f]
[no-rt? #f]
[cname #f])
(if (null? opts)
(values no-ctr? mutable? no-stx? no-rt? cname)
(let ([opt (car opts)])
(case (syntax-e opt)
[(#:constructor-name #:extra-constructor-name)
(if cname
(raise-syntax-error #f
"redundant option"
stx
opt)
(if (null? (cdr opts))
(raise-syntax-error #f
"missing identifier after option"
stx
opt)
(if (identifier? (cadr opts))
(loop (cddr opts) #f mutable? no-stx? no-rt?
(if (eq? (syntax-e opt) '#:extra-constructor-name)
(list (cadr opts))
(cadr opts)))
(raise-syntax-error #f
"not an identifier for a constructor name"
stx
(cadr opts)))))]
[(#:omit-constructor)
(if no-ctr?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) #t mutable? no-stx? no-rt? cname))]
[(#:mutable)
(if mutable?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))]
[(#:omit-define-syntaxes)
(if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt? cname))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t cname))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
option-keywords)
stx
opt)]))))]
[(def-cname) (cond
[opt-cname (if (pair? opt-cname)
(car opt-cname)
opt-cname)]
[extra-make? #f]
[else (car (generate-temporaries #'(name)))])]
[(cname) (cond
[opt-cname (if (pair? opt-cname)
(cons def-cname #'name)
(cons def-cname def-cname))]
[extra-make? #f]
[else (cons def-cname #'name)])]
[(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))])
(define (add-contracts l)
(let* ([pred (caddr l)]
[ctor-ctc #`(-> ctc ... #,pred)]
@ -435,20 +502,29 @@
(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?
#:constructor-name (and type-as-ctr? (cons #'name tmp-name))))
#,(let ([e (build-struct-expand-info
#'name (syntax->list #'(field ...))
#f (not mutable?)
#f '(#f) '(#f)
#:omit-constructor? no-ctr?
#:constructor-name def-cname)])
(if self-ctr?
#`(make-self-name-struct-info
(lambda () #,e)
(lambda () (quote-syntax #,def-cname)))
e)))
(let* ([names (add-contracts
(build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?)
#:constructor-name (and type-as-ctr?
(cons #'name tmp-name))))]
#:constructor-name def-cname))]
[cpairs (cons 'contracted
(if no-ctr? (cddr names) (cdr names)))])
(list (car names) cpairs))))))
(cond
[no-ctr? (cddr names)]
[else (cdr names)]))]
[l (list (car names) cpairs)])
(if self-ctr?
(cons #`(define-values-for-export (#,def-cname) name) l)
l))))))
((_ name fields opt ...)
(raise-syntax-error #f
"bad syntax; expected a parenthesized sequence of fields"
@ -464,9 +540,9 @@
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))
(define-signature-form (struct~r/ctc stx)
(do-struct~/ctc stx #f))
;; build-val+macro-defs : sig -> (list syntax-object^3)
(define-for-syntax (build-val+macro-defs sig)

0
collects/scheme/mpair.ss → collects/racket/mpair.rkt
View File

0
collects/scheme/package.ss → collects/racket/package.rkt
View File

0
collects/scheme/private/old-ds.ss → collects/racket/private/old-ds.rkt
View File

0
collects/scheme/private/old-if.ss → collects/racket/private/old-if.rkt
View File

10
collects/scheme/private/old-procs.ss → collects/racket/private/old-procs.rkt
View File

@ -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=?*

2
collects/scheme/private/old-rp.ss → collects/racket/private/old-rp.rkt
View File

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

4
collects/scheme/private/stxmz-body.ss → collects/racket/private/stxmz-body.rkt
View File

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

2
collects/scheme/mpair.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang scheme/private/provider
racket/mpair

2
collects/scheme/package.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang scheme/private/provider
racket/package

2
collects/tests/mzscheme/unit.ss
View File

@ -231,7 +231,7 @@
(export)))
(test (string-append "(5 #<a> #<struct-type:a> (proc: y)"
" (proc: make-x) (proc: x?)"
" (proc: x) (proc: x?)"
" (proc: x-z) (proc: both))"
"(5 #t #<a> #t #f #<x> #t #t #f #t)")
get-output-string p))

2
collects/tests/mzscheme/unitsig.ss
View File

@ -334,7 +334,7 @@
M@)])
(export)))
(test (string-append "(5 #(struct:a 5 6) #<struct-type:a> (proc: y)"
" (proc: make-x) (proc: x?)"
" (proc: x) (proc: x?)"
" (proc: x-z) (proc: both) (proc: a?))"
"(5 #t #(struct:a 5 6) #t #f #(struct:x 1 2 ...) #t #t #f #t)")
get-output-string p)))