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

more r6rs work

Browse Source 
svn: r8825
This commit is contained in:
Matthew Flatt 2008-02-29 02:37:00 +00:00
parent fe21ba5274
commit 8ffe707b76
15 changed files with 438 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/r6rs/main.ss
View File

@ -297,33 +297,34 @@ FIXME:
(syntax-case* im (for) symbolic-identifier=?
[(for base-im level ...)
(let* ([levels
(map (lambda (level)
(syntax-case* level (run expand meta) symbolic-identifier=?
[run #'0]
[expand #'1]
[(meta 0) #'0]
[(meta n) #'n]
[_
(raise-syntax-error
#f
"bad `for' level"
orig
level)]))
(syntax->list #'(level ...)))])
(cons
#f
(map (lambda (level)
(syntax-case* level (run expand meta) symbolic-identifier=?
[run #'0]
[expand #'1]
[(meta 0) #'0]
[(meta n) #'n]
[_
(raise-syntax-error
#f
"bad `for' level"
orig
level)]))
(syntax->list #'(level ...))))])
(with-syntax ([is (parse-import-set orig #'base-im)])
(if (null? levels)
#'()
(with-syntax ([(level ...) levels]
[prelims (datum->syntax orig
'r6rs/private/prelims)])
#`((for-meta level is prelims) ...)))))]
(with-syntax ([(level ...) levels]
[prelims (datum->syntax orig
'r6rs/private/prelims)])
#`((for-meta level is prelims) ...))))]
[(for . _)
(raise-syntax-error
#f
"bad `for' import form"
orig
im)]
[_ (list (parse-import-set orig im))]))
[_ (let ([m (parse-import-set orig im)])
(list m `(for-label ,m)))]))
(syntax->list #'(im ...)))]
[prelims (datum->syntax orig
'r6rs/private/prelims)])
@ -402,7 +403,13 @@ FIXME:
(apply
append
(map (lambda (local-id ext-id)
(let* ([l (hash-table-get table (syntax-e local-id) null)]
(let* ([l (hash-table-get table (syntax-e local-id)
(lambda ()
(raise-syntax-error
#f
"no binding for exported identifier"
#'orig
local-id)))]
[l (filter (lambda (e)
(free-identifier=? (car e) local-id (cdr e)))
l)])

2
collects/r6rs/private/io-conds.ss
View File

@ -1,7 +1,7 @@
#!r6rs
(library (r6rs private io-conds)
(export &i/o make-i/o-error i/o-error
(export &i/o make-i/o-error i/o-error?
&i/o-read make-i/o-read-error i/o-read-error?
&i/o-write make-i/o-write-error i/o-write-error?
&i/o-invalid-position make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position

88
collects/r6rs/private/num-inline.ss Normal file
View File

@ -0,0 +1,88 @@
#lang scheme/base
(require (for-syntax scheme/base
r6rs/private/inline-rules))
(provide define-inliner
nocheck
implementation-restriction)
(define-syntax-rule (nocheck v . _)
v)
(define (implementation-restriction who what)
(raise
(make-exn:fail:unsupported
(format "~a: result is out of range: ~e" who what)
(current-continuation-marks))))
(define-syntax-rule (define-inliner define-fx numtype? numtype-str)
(...
(begin
(define-syntax define-an-fx
(syntax-rules ()
[(_ orig fx check-result ([(arg ...) (tmp ...)] ...) . rest)
(begin
(provide fx)
(define fx-proc
(let ([fx (case-lambda
[(arg ...)
(unless (numtype? arg)
(raise-type-error 'fx numtype-str arg))
...
(let ([r (orig arg ...)])
(check-result r (implementation-restriction 'fx r)))]
...
. rest)])
fx))
(define-syntax fx
(inline-rules
fx-proc
[(_ arg ...)
(let ([tmp arg] ...)
(if (and (numtype? tmp) ...)
(let ([v (orig tmp ...)])
(check-result v (fx-proc tmp ...)))
(fx-proc tmp ...)))]
...)))]))
(define-syntax define-an-fx+rest
(syntax-rules ()
[(_ orig fx check clauses)
(define-an-fx orig fx check clauses
[args (for-each (lambda (arg)
(unless (numtype? arg)
(raise-type-error 'fx numtype-str arg)))
args)
(let ([r (apply orig args)])
(check r (implementation-restriction 'fx r))
r)])]))
(define-syntax define-fx
(syntax-rules (...)
[(_ orig fx [(a) (b c)] check)
(define-an-fx orig fx check
([(a) (t1)]
[(b c) (t1 t2)]))]
[(_ orig fx [(a) (b c (... ...))] check)
(define-an-fx+rest orig fx check
([(a) (t1)]
[(b c) (t1 t2)]))]
[(_ orig fx (a b c (... ...)) check)
(define-an-fx+rest orig fx check
([(a b) (t1 t2)]))]
[(_ orig fx (a b (... ...)) check)
(define-an-fx+rest orig fx check
([(a) (t1)]
[(a b) (t1 t2)]
[(a b c) (t1 t2 t3)]))]
[(_ orig fx (a) check)
(define-an-fx+rest orig fx check
([(a) (t1)]))]
[(_ orig fx (a b) check)
(define-an-fx orig fx check
([(a b) (t1 t2)]))]
[(_ orig fx (a b c) check)
(define-an-fx orig fx check
([(a b c) (t1 t2 t3)]))])))))

55
collects/rnrs/arithmetic/bitwise-6.ss
View File

@ -8,10 +8,14 @@
(rename-out [integer-length bitwise-length])
bitwise-first-bit-set
bitwise-bit-set?
bitwise-copy-bit
bitwise-bit-field
(rename-out [arithmetic-shift bitwise-arithmetic-shift])
bitwise-arithmetic-shift-left
bitwise-arithmetic-shift-right
bitwise-copy-bit)
bitwise-copy-bit-field
bitwise-rotate-bit-field
bitwise-reverse-bit-field)
(define (bitwise-if a b c)
@ -36,9 +40,13 @@
pos))))
(define (bitwise-bit-set? b n)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'bitwise-bit-set? "exact nonnegative integer" n))
(eq? 1 (bitwise-and (arithmetic-shift b (- n)) 1)))
(define (bitwise-copy-bit b n bit)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'bitwise-copy-bit "exact nonnegative integer" n))
(unless (or (eq? bit 1)
(eq? bit 0))
(raise-type-error 'bitwise-copy-bit "0 or 1" bit))
@ -47,10 +55,22 @@
(bitwise-xor b (arithmetic-shift 1 n))))
(define (bitwise-bit-field b start end)
(unless (exact-nonnegative-integer? start)
(raise-type-error 'bitwise-bit-field "exact nonnegative integer" start))
(unless (exact-nonnegative-integer? end)
(raise-type-error 'bitwise-bit-field "exact nonnegative integer" end))
(unless (start . <= . end)
(error 'bitwise-bit-field "ending position ~e is not as big a starting position ~e" start end))
(bitwise-and (arithmetic-shift b (- start))
(sub1 (arithmetic-shift 1 (- end start)))))
(define (bitwise-copy-bit-field to start end from)
(unless (exact-nonnegative-integer? start)
(raise-type-error 'bitwise-copy-bit-field "exact nonnegative integer" start))
(unless (exact-nonnegative-integer? end)
(raise-type-error 'bitwise-copy-bit-field "exact nonnegative integer" end))
(unless (start . <= . end)
(error 'bitwise-copy-bit-field "ending position ~e is not as big a starting position ~e" start end))
(let* ([mask1 (arithmetic-shift -1 start)]
[mask2 (bitwise-not (arithmetic-shift -1 end))]
[mask (bitwise-and mask1 mask2)])
@ -63,3 +83,36 @@
(define (bitwise-arithmetic-shift-right v s)
(arithmetic-shift v (- s)))
(define (bitwise-rotate-bit-field n start end count)
(unless (exact-nonnegative-integer? start)
(raise-type-error 'bitwise-rotate-bit-field "exact nonnegative integer" start))
(unless (exact-nonnegative-integer? end)
(raise-type-error 'bitwise-rotate-bit-field "exact nonnegative integer" end))
(unless (start . <= . end)
(error 'bitwise-rotate-bit-field "ending position ~e is not as big a starting position ~e" start end))
(unless (exact-nonnegative-integer? count)
(raise-type-error 'bitwise-rotate-bit-field "exact nonnegative integer" count))
(let* ([width (- end start)]
[count (modulo count width)]
[field0 (bitwise-bit-field n start end)]
[field1 (arithmetic-shift field0 count)]
[field2 (arithmetic-shift field0 (- count width))]
[field (bitwise-ior field1 field2)])
(bitwise-copy-bit-field n start end field)))
(define (bitwise-reverse-bit-field n start end)
(unless (exact-nonnegative-integer? start)
(raise-type-error 'bitwise-rotate-bit-field "exact nonnegative integer" start))
(unless (exact-nonnegative-integer? end)
(raise-type-error 'bitwise-rotate-bit-field "exact nonnegative integer" end))
(unless (start . <= . end)
(error 'bitwise-rotate-bit-field "ending position ~e is not as big a starting position ~e" start end))
(let ([field (bitwise-bit-field n start end)]
[width (- end start)])
(let loop ([old field][new 0][width width])
(cond
[(zero? width) (bitwise-copy-bit-field n start end new)]
[else (loop (arithmetic-shift old -1)
(bitwise-ior (arithmetic-shift new 1)
(bitwise-and old 1))
(sub1 width))]))))

128
collects/rnrs/arithmetic/fixnums-6.ss
View File

@ -3,10 +3,8 @@
(require (only-in rnrs/base-6
div-and-mod div mod
div0-and-mod0 div0 mod0)
(only-in rnrs/arithmetic/bitwise-6
bitwise-if
bitwise-first-bit-set
bitwise-copy-bit)
rnrs/arithmetic/bitwise-6
r6rs/private/num-inline
(for-syntax r6rs/private/inline-rules))
(provide fixnum?
@ -30,82 +28,12 @@
(and (exact-integer? v)
(<= -1073741824 v 1073741823)))]))
(define (implementation-restriction who what)
(error 'who "implementation restriction: ~e" what))
(define-syntax define-an-fx
(syntax-rules ()
[(_ orig fx check-result ([(arg ...) (tmp ...)] ...) . rest)
(begin
(provide fx)
(define fx-proc
(let ([fx (case-lambda
[(arg ...)
(unless (fixnum? arg)
(raise-type-error 'fx "fixnum" arg))
...
(let ([r (orig arg ...)])
(unless (fixnum? r)
(implementation-restriction 'fx r))
r)]
...
. rest)])
fx))
(define-syntax fx
(inline-rules
fx-proc
[(_ arg ...)
(let ([tmp arg] ...)
(if (and (fixnum? tmp) ...)
(let ([v (orig tmp ...)])
(check-result v (fx-proc tmp ...)))
(fx-proc tmp ...)))]
...)))]))
(define-syntax-rule (check v (fx-proc tmp ...))
(define-syntax-rule (check v alt)
(if (fixnum? v)
v
(fx-proc tmp ...)))
alt))
(define-syntax-rule (nocheck v . _)
v)
(define-syntax define-an-fx+rest
(syntax-rules ()
[(_ orig fx check clauses)
(define-an-fx orig fx check clauses
[args (for-each (lambda (arg)
(unless (fixnum? args)
(raise-type-error 'fx "fixnum" arg)))
args)
(let ([r (apply orig args)])
(unless (fixnum? r)
(implementation-restriction 'fx r))
r)])]))
(define-syntax define-fx
(syntax-rules (...)
[(_ orig fx [(a) (b c)] check)
(define-an-fx orig fx check
([(a) (t1)]
[(b c) (t1 t2)]))]
[(_ orig fx (a b c (... ...)) check)
(define-an-fx+rest orig fx check
([(a b) (t1 t2)]))]
[(_ orig fx (a b (... ...)) check)
(define-an-fx+rest orig fx check
([(a) (t1)]
[(a b) (t1 t2)]))]
[(_ orig fx (a) check)
(define-an-fx+rest orig fx check
([(a) (t1)]))]
[(_ orig fx (a b) check)
(define-an-fx orig fx check
([(a b) (t1 t2)]))]
[(_ orig fx (a b c) check)
(define-an-fx orig fx check
([(a b c) (t1 t2 t3)]))]))
(define-inliner define-fx fixnum? "fixnum")
(define-fx = fx=? (a b c ...) nocheck)
(define-fx > fx>? (a b c ...) nocheck)
@ -155,15 +83,37 @@
(define-fx bitwise-and fxand (a b ...) nocheck)
(define-fx bitwise-ior fxior (a b ...) nocheck)
(define-fx bitwise-xor fxxor (a b ...) nocheck)
(define-fx bitwise-first-bit-set fxfirst-bit-set (a) nocheck)
(define-fx bitwise-copy-bit fxcopy-bit (a) nocheck)
(define-syntax-rule (fixnum-bitwise-if a b c)
(bitwise-ior (bitwise-and a b)
(bitwise-and (bitwise-not a) c)))
(define-fx fixnum-bitwise-if fxif (a b c) nocheck)
(define-fx bitwise-length fxlength (a) nocheck)
(define-fx bitwise-first-bit-set fxfirst-bit-set (a) nocheck)
(define (fxbit-set? n bit)
(unless (fixnum? n)
(raise-type-error 'fxbit-set? "fixnum" n))
(bitwise-bit-set? n bit))
(define (fxcopy-bit n pos bit)
(unless (fixnum? n)
(raise-type-error 'fxcopy-bit "fixnum" n))
(unless (and (exact-nonnegative-integer? pos)
(< pos (fixnum-width)))
(raise-type-error 'fxcopy-bit "exact integer in [0, 30]" pos))
(bitwise-copy-bit n pos bit))
(define (fxcopy-bit-field n start end m)
(unless (fixnum? n)
(raise-type-error 'fxrotate-bit-field "fixnum" n))
(unless (and (exact-nonnegative-integer? end)
(< end (fixnum-width)))
(raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" end))
(unless (fixnum? m)
(raise-type-error 'fxrotate-bit-field "fixnum" m))
(bitwise-bit-field n start end m))
(define-syntax-rule (define-shifter fxarithmetic-shift r6rs:fxarithmetic-shift
lower-bound bounds adjust)
@ -198,3 +148,23 @@
0 "exact integer in [0, 30]" values)
(define-shifter fxarithmetic-shift-right r6rs:fxarithmetic-shift-right
0 "exact integer in [0, 30]" -)
(define (fxrotate-bit-field n start end count)
(unless (fixnum? n)
(raise-type-error 'fxrotate-bit-field "fixnum" n))
(unless (and (exact-nonnegative-integer? end)
(< end (fixnum-width)))
(raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" end))
(unless (and (exact-nonnegative-integer? count)
(< count (fixnum-width)))
(raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" count))
(bitwise-rotate-bit-field n start end count))
(define (fxreverse-bit-field n start end)
(unless (fixnum? n)
(raise-type-error 'fxrotate-bit-field "fixnum" n))
(unless (and (exact-nonnegative-integer? end)
(< end (fixnum-width)))
(raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" end))
(bitwise-reverse-bit-field n start end))

102
collects/rnrs/arithmetic/flonums-6.ss Normal file
View File

@ -0,0 +1,102 @@
#lang scheme/base
(require (only-in rnrs/base-6
div-and-mod div mod
div0-and-mod0 div0 mod0
[integer? r6rs:integer?]
finite? infinite? nan?)
(only-in rnrs/arithmetic/fixnums-6
fixnum?)
rnrs/conditions-6
r6rs/private/num-inline
(for-syntax r6rs/private/inline-rules))
(provide flonum?
real->flonum
&no-infinities make-no-infinities-violation no-infinities-violation?
&no-nans make-no-nans-violation no-nans-violation?
fixnum->flonum)
;; More provided via macros
(define (r6rs:flonum? v)
(and (real? v) (inexact? v)))
(define-syntax flonum?
(inline-rules
r6rs:flonum?
[(_ a) (let ([v a])
(and (real? v) (inexact? v)))]))
(define-inliner define-fl flonum? "flonum")
(define-fl = fl=? (a b c ...) nocheck)
(define-fl > fl>? (a b c ...) nocheck)
(define-fl < fl<? (a b c ...) nocheck)
(define-fl <= fl<=? (a b c ...) nocheck)
(define-fl >= fl>=? (a b c ...) nocheck)
(define-fl integer? flinteger? (a) nocheck)
(define-fl zero? flzero? (a) nocheck)
(define-fl positive? flpositive? (a) nocheck)
(define-fl negative? flnegative? (a) nocheck)
(define-fl odd? flodd? (a) nocheck)
(define-fl even? fleven? (a) nocheck)
(define-fl finite? flfinite? (a) nocheck)
(define-fl infinite? flinfinite? (a) nocheck)
(define-fl nan? flnan? (a) nocheck)
(define-fl max flmax (a b ...) nocheck)
(define-fl max flmin (a b ...) nocheck)
(define-fl + fl+ (a b ...) nocheck)
(define-fl * fl* (a b ...) nocheck)
(define-fl - fl- [(a) (a b ...)] nocheck)
(define-fl / fl/ [(a) (a b ...)] nocheck)
(define-fl abs flabs (a) nocheck)
(define-fl div-and-mod fldiv-and-mod (a b) nocheck)
(define-fl div fldiv (a b) nocheck)
(define-fl mod flmod (a b) nocheck)
(define-fl div0-and-mod0 fldiv0-and-mod0 (a b) nocheck)
(define-fl div0 fldiv0 (a b) nocheck)
(define-fl mod0 flmod0 (a b) nocheck)
(define-fl numerator flnumerator (a) nocheck)
(define-fl denominator fldenominator (a) nocheck)
(define-fl floor flfloor (a) nocheck)
(define-fl ceiling flceiling (a) nocheck)
(define-fl truncate fltruncate (a) nocheck)
(define-fl round flround (a) nocheck)
(define-fl exp flexp (a) nocheck)
(define-fl log fllog [(a) (a b)] nocheck)
(define-fl sin flsin (a) nocheck)
(define-fl cos flcos (a) nocheck)
(define-fl tan fltan (a) nocheck)
(define-fl asin flasin (a) nocheck)
(define-fl acos flacos (a) nocheck)
(define-fl atan flatan [(a) (a b)] nocheck)
(define-fl sqrt flsqrt (a) nocheck)
(define-fl expt flexpt (a b) nocheck)
(define-condition-type &no-infinities
&implementation-restriction
make-no-infinities-violation
no-infinities-violation?)
(define-condition-type &no-nans
&implementation-restriction
make-no-nans-violation no-nans-violation?)
(define (real->flonum r)
(unless (real? r)
(raise-type-error 'real->flonum "real" r))
(exact->inexact r))
(define (fixnum->flonum fx)
(unless (fixnum? fx)
(raise-type-error 'fixnum->flonum "fixnum" fx)
(exact->inexact fx)))

2
collects/rnrs/base-6.ss
View File

@ -252,7 +252,7 @@
(define (r6rs:string->number s [radix 10])
(and (regexp-match? rx:number s)
(string->number (regexp-replace* #rx"|[0-9]+" s "") radix)))
(string->number (regexp-replace* #rx"[|][0-9]+" s "") radix)))
(define-syntax-rule (make-mapper what for for-each in-val val-length val->list)
(case-lambda

26
collects/rnrs/bytevectors-6.ss
View File

@ -309,7 +309,7 @@
(values #t 2)]
[(and (eq? #xFF (bytes-ref bstr 0))
(eq? #xFE (bytes-ref bstr 1)))
(values #t 1)]
(values #f 2)]
[else (values (eq? endianness 'big) 0)])]
[else (values (eq? endianness 'big) 0)])])
(list->string
@ -325,7 +325,7 @@
(let ([a (if big? a b)]
[b (if big? b a)])
(cond
[(= (bitwise-and a #xD8) #xD8)
[(= (bitwise-and a #xFC) #xD8)
(if (len . < . (+ pos 4))
;; decoding error
(cons #\uFFFD (loop (+ pos 2)))
@ -335,7 +335,7 @@
(let ([c (if big? c d)]
[d (if big? d c)])
(cond
[(= (bitwise-and c #xDC) #xDC)
[(= (bitwise-and c #xFC) #xDC)
;; A valid surrogate
(let ([v (+ #x10000
(bitwise-ior
@ -347,7 +347,7 @@
[else
;; Invalid surrogate.
(cons #\uFFFD (loop (+ pos 2)))]))))]
[(= (bitwise-and a #xDC) #xDC)
[(= (bitwise-and a #xFC) #xDC)
;; invalid surrogate code
(cons #\uFFFD (loop (+ pos 2)))]
[else
@ -365,16 +365,18 @@
(cond
[skip-bom?
(values (eq? endianness 'big) 0)]
[(and (len . >= . 4)
(eq? #x00 (bytes-ref bstr 0))
(eq? #x00 (bytes-ref bstr 1)))
[(len . >= . 4)
(cond
[(and (eq? #xFE (bytes-ref bstr 2))
[(and (eq? #x00 (bytes-ref bstr 0))
(eq? #x00 (bytes-ref bstr 1))
(eq? #xFE (bytes-ref bstr 2))
(eq? #xFF (bytes-ref bstr 3)))
(values #t 2)]
[(and (eq? #xFF (bytes-ref bstr 2))
(eq? #xFE (bytes-ref bstr 3)))
(values #t 1)]
(values #t 4)]
[(and (eq? #xFF (bytes-ref bstr 0))
(eq? #xFE (bytes-ref bstr 1))
(eq? #x00 (bytes-ref bstr 2))
(eq? #x00 (bytes-ref bstr 3)))
(values #f 4)]
[else (values (eq? endianness 'big) 0)])]
[else (values (eq? endianness 'big) 0)])])
(list->string

16
collects/rnrs/io/ports-6.ss
View File

@ -196,13 +196,15 @@
port
(lambda (bytes start end can-buffer/block? enable-breaks?)
(check-disconnect)
(cond
[enable-breaks?
(parameterize-break #t (write-bytes (subbytes start end) port))]
[can-buffer/block?
(write-bytes (subbytes start end) port)]
[else
(write-bytes-avail* (subbytes start end) port)]))
(if (= start end)
(flush-output port)
(cond
[enable-breaks?
(parameterize-break #t (write-bytes (subbytes start end) port))]
[can-buffer/block?
(write-bytes (subbytes start end) port)]
[else
(write-bytes-avail* (subbytes start end) port)])))
(lambda ()
(unless disconnected?
(close-output-port port)))

33
collects/rnrs/main-6.ss Normal file
View File

@ -0,0 +1,33 @@
#lang scheme/base
(define-syntax re-export
(syntax-rules ()
[(_) (re-export rnrs/base-6
rnrs/exceptions-6
rnrs/programs-6
rnrs/files-6
rnrs/bytevectors-6
rnrs/hashtables-6
rnrs/sorting-6
rnrs/syntax-case-6
rnrs/conditions-6
rnrs/unicode-6
rnrs/control-6
rnrs/lists-6
rnrs/enums-6
rnrs/arithmetic/bitwise-6
rnrs/arithmetic/fixnums-6
rnrs/arithmetic/flonums-6
rnrs/io/ports-6
rnrs/io/simple-6
rnrs/records/inspection-6
rnrs/records/syntactic-6
rnrs/records/procedural-6)]
[(_ id) (begin
(require id)
(provide (all-from-out id)))]
[(_ id ...)
(begin (re-export id) ...)]))
(re-export)

7
collects/rnrs/main.ss Normal file
View File

@ -0,0 +1,7 @@
#lang scheme/base
(define-syntax-rule (bounce)
(begin
(require rnrs/main-6)
(provide (all-from-out rnrs/main-6))))
(bounce)

3
collects/rnrs/mutable-strings-6.ss Normal file
View File

@ -0,0 +1,3 @@
#lang scheme/base
(provide string-set! string-fill!)

15
collects/rnrs/r5rs-6.ss Normal file
View File

@ -0,0 +1,15 @@
#lang scheme/base
(require (prefix-in r5rs: r5rs))
(provide exact->inexact
inexact->exact
quotient
remainder
modulo
(rename-out [r5rs:delay delay]
[r5rs:force force]
[r5rs:null-environment null-environment]
[r5rs:scheme-report-environment scheme-report-environment]))

34
collects/scheme/mpair.ss
View File

@ -1,5 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base))
(provide mmap
mfor-each
mlist
@ -66,14 +68,30 @@
[(null? l) null]
[else (cons (mcar l) (mlist->list (mcdr l)))]))
(define mlist
(case-lambda
[() null]
[(a) (mcons a null)]
[(a b) (mcons a (mcons b null))]
[(a b c) (mcons a (mcons b (mcons c null)))]
[(a b c d) (mcons a (mcons b (mcons c (mcons d null))))]
[l (list->mlist l)]))
(define-syntax mlist
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! id . _) (raise-syntax-error #f
"cannot mutate imported variable"
stx
#'id)]
[(_ a) #'(mcons a null)]
[(_ a b) #'(mcons a (mcons b null))]
[(_ a b c) #'(mcons a (mcons b (mcons c null)))]
[(_ arg ...) #'(-mlist arg ...)]
[_ #'-mlist]))))
(define -mlist
(let ([mlist
(case-lambda
[() null]
[(a) (mcons a null)]
[(a b) (mcons a (mcons b null))]
[(a b c) (mcons a (mcons b (mcons c null)))]
[(a b c d) (mcons a (mcons b (mcons c (mcons d null))))]
[l (list->mlist l)])])
mlist))
(define (mlist? l)
(cond

12
collects/scribblings/reference/stx-trans.scrbl
View File

@ -403,8 +403,8 @@ and a module-contextless version of @scheme[id-stx] otherwise.
@defproc[(syntax-local-certifier [active? boolean? #f])
(syntax? (any/c (or/c procedure? false/c))
. opt-> . syntax?)]{
((syntax?) (any/c (or/c procedure? false/c))
. ->* . syntax?)]{
Returns a procedure that captures any certificates currently available
for @scheme[syntax-local-value] or @scheme[local-expand]. The
@ -611,7 +611,9 @@ instantiated or visited even if no binding is imported into a module.
}}
@defproc[(syntax-local-require-certifier) (syntax? . -> . syntax?)]{
@defproc[(syntax-local-require-certifier)
((syntax?) (or/c false/c (syntax? . -> . syntax?))
. ->* . syntax?)]{
Like @scheme[syntax-local-certifier], but to certify @tech{syntax
objects} that correspond to @scheme[require] sub-forms, so that
@ -703,7 +705,9 @@ A structure representing a single imported identifier:
}}
@defproc[(syntax-local-provide-certifier) (syntax? . -> . syntax?)]{
@defproc[(syntax-local-provide-certifier)
((syntax?) (or/c false/c (syntax? . -> . syntax?))
. ->* . syntax?)]{
Like @scheme[syntax-local-certifier], but to certify @tech{syntax
objects} that correspond to @scheme[provide] sub-forms, so that