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

* Helper for reproviding stuff from srfi/N/... subdirectories

Browse Source 
* Switch srfi/1 and a few other packages (and optionals.ss) to
  scheme/base
* Make srfi/1 etc reprovide `filter' from scheme/private/list
* Organize a few modules that were unnecessarily providing a full
  language.
* srfi/45 reprovides stuff from scheme/promise (see comments in
  "srfi/45/lazy.ss")

svn: r8999
This commit is contained in:
Eli Barzilay 2008-03-17 10:05:50 +00:00
parent 9ba432ab9c
commit 2ea73fbc6a
63 changed files with 2750 additions and 2852 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/srfi/1.ss
View File

@ -1,14 +1,2 @@
;; module loader for SRFI-1 ;; module loader for SRFI-1
(module |1| mzscheme #lang s-exp srfi/provider srfi/1/list #:unprefix s:
(require srfi/1/list)
(provide (all-from-except srfi/1/list
s:map s:for-each
s:member
s:assoc)
(rename s:map map)
(rename s:for-each for-each)
(rename s:member member)
(rename s:assoc assoc)))

10
collects/srfi/1/filter.ss
View File

@ -36,7 +36,8 @@
(require srfi/optional "predicate.ss") (require srfi/optional "predicate.ss")
(provide (rename-out [my-filter filter] [my-filter filter!]) (provide filter (rename-out [filter filter!])
(rename-out [my-filter filter-with-sharing]) ; see comment below
partition (rename-out [partition partition!]) partition (rename-out [partition partition!])
(rename-out [my-remove remove] [my-remove remove!])) (rename-out [my-remove remove] [my-remove remove!]))
@ -45,6 +46,13 @@
;; FILTER, REMOVE, PARTITION and their destructive counterparts do not ;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
;; disorder the elements of their argument. ;; disorder the elements of their argument.
;; The following version of filter is not really needed, so we reprovide the
;; one from "scheme/private/list.ss". That one does not keep the longest tail,
;; but running a few benchmarks (on v3.99.0.18) shows that on long lists the
;; code below is slower, and on short lists it is a little faster, but not by
;; much. However, seems that "lset.ss" relies on tail-sharing, so it is
;; provided under an alternative name above.
;; This FILTER shares the longest tail of L that has no deleted ;; This FILTER shares the longest tail of L that has no deleted
;; elements. If Scheme had multi-continuation calls, they could be ;; elements. If Scheme had multi-continuation calls, they could be
;; made more efficient. ;; made more efficient.

5
collects/srfi/1/list.ss
View File

@ -220,7 +220,7 @@
"misc.ss" "misc.ss"
(rename-in "fold.ss" [map s:map] [for-each s:for-each]) (rename-in "fold.ss" [map s:map] [for-each s:for-each])
(rename-in "search.ss" [member s:member]) (rename-in "search.ss" [member s:member])
(rename-in "filter.ss" [filter s:filter] [remove s:remove]) (rename-in "filter.ss" [remove s:remove])
"delete.ss" "delete.ss"
(rename-in "alist.ss" [assoc s:assoc]) (rename-in "alist.ss" [assoc s:assoc])
"lset.ss") "lset.ss")
@ -231,8 +231,7 @@
(all-from-out "misc.ss") (all-from-out "misc.ss")
(all-from-out "fold.ss") (all-from-out "fold.ss")
(all-from-out "search.ss") (all-from-out "search.ss")
(except-out (all-from-out "filter.ss") s:filter) (all-from-out "filter.ss")
(rename-out [s:filter filter])
(all-from-out "delete.ss") (all-from-out "delete.ss")
(all-from-out "alist.ss") (all-from-out "alist.ss")
(all-from-out "lset.ss")) (all-from-out "lset.ss"))

2
collects/srfi/1/lset.ss
View File

@ -39,7 +39,7 @@
(except-in "fold.ss" map for-each) (except-in "fold.ss" map for-each)
"delete.ss" "delete.ss"
"predicate.ss" "predicate.ss"
(except-in "filter.ss" remove filter)) (only-in "filter.ss" [filter-with-sharing s:filter] partition))
(provide lset<= (provide lset<=
lset= lset=

4
collects/srfi/11.ss
View File

@ -1,3 +1,3 @@
;; Supported by core PLT: ;; Supported by core PLT:
(module |11| mzscheme #lang scheme/base
(provide let-values let*-values)) (provide let-values let*-values)

10
collects/srfi/13.ss
View File

@ -1,10 +1,2 @@
;; module loader for SRFI-13 ;; module loader for SRFI-13
(module |13| mzscheme #lang s-exp srfi/provider srfi/13/string #:unprefix s:
(require srfi/13/string)
(provide (all-from-except srfi/13/string
s:string-upcase s:string-downcase s:string-titlecase)
(rename s:string-upcase string-upcase)
(rename s:string-downcase string-downcase)
(rename s:string-titlecase string-titlecase)))

4
collects/srfi/14.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-14 ;; module loader for SRFI-14
(module |14| mzscheme #lang s-exp srfi/provider srfi/14/char-set
(require srfi/14/char-set)
(provide (all-from srfi/14/char-set)))

4
collects/srfi/16.ss
View File

@ -1,3 +1,3 @@
;; Supported by core PLT: ;; Supported by core PLT:
(module |16| mzscheme #lang scheme/base
(provide case-lambda)) (provide case-lambda)

6
collects/srfi/17.ss
View File

@ -1,6 +1,2 @@
;; module loader for SRFI-17 ;; module loader for SRFI-17
(module |17| mzscheme #lang s-exp srfi/provider srfi/17/set #:unprefix s:
(require (all-except srfi/17/set set!)
(rename srfi/17/set my-set! set!))
(provide (all-from-except srfi/17/set my-set!)
(rename my-set! set!)))

19
collects/srfi/17/set.ss
View File

@ -7,31 +7,31 @@
;;; ;;;
;;; Based on the implementation for Scheme48. ;;; Based on the implementation for Scheme48.
(module set mzscheme #lang scheme/base
(provide (rename my-set! set!) (provide (rename-out [my-set! s:set!])
setter setter
set-setter! set-setter!
getter-with-setter) getter-with-setter)
(define-syntax my-set! (define-syntax my-set!
(syntax-rules () (syntax-rules ()
((my-set! (?e0 ?e1 ...) ?v) ((my-set! (?e0 ?e1 ...) ?v)
((setter ?e0) ?e1 ... ?v)) ((setter ?e0) ?e1 ... ?v))
((my-set! ?i ?v) ((my-set! ?i ?v)
(set! ?i ?v)))) (set! ?i ?v))))
(define (getter-with-setter get set) (define (getter-with-setter get set)
(let ((proc (lambda args (apply get args)))) (let ((proc (lambda args (apply get args))))
(set-setter! proc set) (set-setter! proc set)
proc)) proc))
(define (setter proc) (define (setter proc)
(let ((probe (assv proc setters))) (let ((probe (assv proc setters)))
(if probe (if probe
(cdr probe) (cdr probe)
(error (object-name proc) "No setter found")))) (error (object-name proc) "No setter found"))))
(define (set-setter! proc setter) (define (set-setter! proc setter)
(set! setters (set! setters
(let loop ([setters setters]) (let loop ([setters setters])
(cond (cond
@ -44,16 +44,16 @@
(loop (cdr setters)))])))) (loop (cdr setters)))]))))
#| #|
(define (car-setter proc) (define (car-setter proc)
(lambda (p v) (lambda (p v)
(set-car! (proc p) v))) (set-car! (proc p) v)))
(define (cdr-setter proc) (define (cdr-setter proc)
(lambda (p v) (lambda (p v)
(set-cdr! (proc p) v))) (set-cdr! (proc p) v)))
|# |#
(define setters (define setters
(list (cons setter set-setter!) (list (cons setter set-setter!)
(cons vector-ref vector-set!) (cons vector-ref vector-set!)
(cons string-ref string-set!) (cons string-ref string-set!)
@ -93,4 +93,3 @@
(cons cddddr (cdr-setter cdddr)) (cons cddddr (cdr-setter cdddr))
|# |#
)) ))
)

5
collects/srfi/18.ss
View File

@ -1,4 +1,3 @@
;; Supported by core PLT: ;; Supported by core PLT:
(module |18| mzscheme #lang scheme/base
(provide thread) (provide thread)
)

23
collects/srfi/19.ss
View File

@ -1,23 +1,2 @@
;; module loader for SRFI-19 ;; module loader for SRFI-19
(module |19| mzscheme #lang s-exp srfi/provider srfi/19/time #:unprefix srfi:
(require srfi/19/time)
(provide (all-from-except srfi/19/time
make-srfi:date srfi:date?
srfi:date-second
srfi:date-minute
srfi:date-hour
srfi:date-day
srfi:date-month
srfi:date-year
srfi:date-year-day
srfi:date-week-day)
(rename make-srfi:date make-date)
(rename srfi:date? date?)
(rename srfi:date-second date-second)
(rename srfi:date-minute date-minute)
(rename srfi:date-hour date-hour)
(rename srfi:date-day date-day)
(rename srfi:date-month date-month)
(rename srfi:date-year date-year)
(rename srfi:date-year-day date-year-day)
(rename srfi:date-week-day date-week-day)))

88
collects/srfi/19/tests.ss
View File

@ -97,33 +97,33 @@
(test-case (test-case
"TAI-Date Conversions" "TAI-Date Conversions"
(check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
(make-srfi:date 0 58 59 23 31 12 1998 0)) (srfi:make-date 0 58 59 23 31 12 1998 0))
(check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
(make-srfi:date 0 59 59 23 31 12 1998 0)) (srfi:make-date 0 59 59 23 31 12 1998 0))
(check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0)
(make-srfi:date 0 60 59 23 31 12 1998 0)) (srfi:make-date 0 60 59 23 31 12 1998 0))
(check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
(make-srfi:date 0 0 0 0 1 1 1999 0))) (srfi:make-date 0 0 0 0 1 1 1999 0)))
(test-case (test-case
"Date-UTC Conversions" "Date-UTC Conversions"
(check time=? (make-time time-utc 0 (- 915148800 2)) (check time=? (make-time time-utc 0 (- 915148800 2))
(date->time-utc (make-srfi:date 0 58 59 23 31 12 1998 0))) (date->time-utc (srfi:make-date 0 58 59 23 31 12 1998 0)))
(check time=? (make-time time-utc 0 (- 915148800 1)) (check time=? (make-time time-utc 0 (- 915148800 1))
(date->time-utc (make-srfi:date 0 59 59 23 31 12 1998 0))) (date->time-utc (srfi:make-date 0 59 59 23 31 12 1998 0)))
;; yes, I think this is actually right. ;; yes, I think this is actually right.
(check time=? (make-time time-utc 0 (- 915148800 0)) (check time=? (make-time time-utc 0 (- 915148800 0))
(date->time-utc (make-srfi:date 0 60 59 23 31 12 1998 0))) (date->time-utc (srfi:make-date 0 60 59 23 31 12 1998 0)))
(check time=? (make-time time-utc 0 (- 915148800 0)) (check time=? (make-time time-utc 0 (- 915148800 0))
(date->time-utc (make-srfi:date 0 0 0 0 1 1 1999 0))) (date->time-utc (srfi:make-date 0 0 0 0 1 1 1999 0)))
(check time=? (make-time time-utc 0 (+ 915148800 1)) (check time=? (make-time time-utc 0 (+ 915148800 1))
(date->time-utc (make-srfi:date 0 1 0 0 1 1 1999 0)))) (date->time-utc (srfi:make-date 0 1 0 0 1 1 1999 0))))
(test-case (test-case
"TZ Offset conversions" "TZ Offset conversions"
(let ((ct-utc (make-time time-utc 6320000 1045944859)) (let ((ct-utc (make-time time-utc 6320000 1045944859))
(ct-tai (make-time time-tai 6320000 1045944891)) (ct-tai (make-time time-tai 6320000 1045944891))
(cd (make-srfi:date 6320000 19 14 15 22 2 2003 -18000))) (cd (srfi:make-date 6320000 19 14 15 22 2 2003 -18000)))
(check time=? ct-utc (date->time-utc cd)) (check time=? ct-utc (date->time-utc cd))
(check time=? ct-tai (date->time-tai cd)))) (check time=? ct-tai (date->time-tai cd))))
@ -132,7 +132,7 @@
;; to change the test case to match the implementation... ;; to change the test case to match the implementation...
(test-case (test-case
"date->string conversions" "date->string conversions"
(check-equal? (date->string (make-srfi:date 1000 2 3 4 5 6 2007 (* 60 -120)) (check-equal? (date->string (srfi:make-date 1000 2 3 4 5 6 2007 (* 60 -120))
"~~ @ ~a @ ~A @ ~b @ ~B @ ~c @ ~d @ ~D @ ~e @ ~f @ ~h @ ~H") "~~ @ ~a @ ~A @ ~b @ ~B @ ~c @ ~d @ ~D @ ~e @ ~f @ ~h @ ~H")
"~ @ Tue @ Tuesday @ Jun @ June @ Tue Jun 05 04:03:02-0200 2007 @ 05 @ 06/05/07 @ 5 @ 02.000001 @ Jun @ 04")) "~ @ Tue @ Tuesday @ Jun @ June @ Tue Jun 05 04:03:02-0200 2007 @ 05 @ 06/05/07 @ 5 @ 02.000001 @ Jun @ 04"))
@ -140,49 +140,49 @@
(test-case (test-case
"[DJG] date->string conversions of dates with nanosecond components" "[DJG] date->string conversions of dates with nanosecond components"
(check-equal? (date->string (make-srfi:date 123456789 2 3 4 5 6 2007 0) "~N") "123456789") (check-equal? (date->string (srfi:make-date 123456789 2 3 4 5 6 2007 0) "~N") "123456789")
(check-equal? (date->string (make-srfi:date 12345678 2 3 4 5 6 2007 0) "~N") "012345678") (check-equal? (date->string (srfi:make-date 12345678 2 3 4 5 6 2007 0) "~N") "012345678")
(check-equal? (date->string (make-srfi:date 1234567 2 3 4 5 6 2007 0) "~N") "001234567") (check-equal? (date->string (srfi:make-date 1234567 2 3 4 5 6 2007 0) "~N") "001234567")
(check-equal? (date->string (make-srfi:date 123456 2 3 4 5 6 2007 0) "~N") "000123456") (check-equal? (date->string (srfi:make-date 123456 2 3 4 5 6 2007 0) "~N") "000123456")
(check-equal? (date->string (make-srfi:date 12345 2 3 4 5 6 2007 0) "~N") "000012345") (check-equal? (date->string (srfi:make-date 12345 2 3 4 5 6 2007 0) "~N") "000012345")
(check-equal? (date->string (make-srfi:date 1234 2 3 4 5 6 2007 0) "~N") "000001234") (check-equal? (date->string (srfi:make-date 1234 2 3 4 5 6 2007 0) "~N") "000001234")
(check-equal? (date->string (make-srfi:date 123 2 3 4 5 6 2007 0) "~N") "000000123") (check-equal? (date->string (srfi:make-date 123 2 3 4 5 6 2007 0) "~N") "000000123")
(check-equal? (date->string (make-srfi:date 12 2 3 4 5 6 2007 0) "~N") "000000012") (check-equal? (date->string (srfi:make-date 12 2 3 4 5 6 2007 0) "~N") "000000012")
(check-equal? (date->string (make-srfi:date 1 2 3 4 5 6 2007 0) "~N") "000000001")) (check-equal? (date->string (srfi:make-date 1 2 3 4 5 6 2007 0) "~N") "000000001"))
(test-case (test-case
"[DJG] string->date conversions of dates with nanosecond components" "[DJG] string->date conversions of dates with nanosecond components"
(check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (make-srfi:date 123456789 0 0 12 #t #t #t 0) "check 1") (check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (srfi:make-date 123456789 0 0 12 #t #t #t 0) "check 1")
(check-equal? (string->date "12:00:00.12345678" "~H:~M:~S.~N") (make-srfi:date 123456780 0 0 12 #t #t #t 0) "check 2") (check-equal? (string->date "12:00:00.12345678" "~H:~M:~S.~N") (srfi:make-date 123456780 0 0 12 #t #t #t 0) "check 2")
(check-equal? (string->date "12:00:00.1234567" "~H:~M:~S.~N") (make-srfi:date 123456700 0 0 12 #t #t #t 0) "check 3") (check-equal? (string->date "12:00:00.1234567" "~H:~M:~S.~N") (srfi:make-date 123456700 0 0 12 #t #t #t 0) "check 3")
(check-equal? (string->date "12:00:00.123456" "~H:~M:~S.~N") (make-srfi:date 123456000 0 0 12 #t #t #t 0) "check 4") (check-equal? (string->date "12:00:00.123456" "~H:~M:~S.~N") (srfi:make-date 123456000 0 0 12 #t #t #t 0) "check 4")
(check-equal? (string->date "12:00:00.12345" "~H:~M:~S.~N") (make-srfi:date 123450000 0 0 12 #t #t #t 0) "check 5") (check-equal? (string->date "12:00:00.12345" "~H:~M:~S.~N") (srfi:make-date 123450000 0 0 12 #t #t #t 0) "check 5")
(check-equal? (string->date "12:00:00.1234" "~H:~M:~S.~N") (make-srfi:date 123400000 0 0 12 #t #t #t 0) "check 6") (check-equal? (string->date "12:00:00.1234" "~H:~M:~S.~N") (srfi:make-date 123400000 0 0 12 #t #t #t 0) "check 6")
(check-equal? (string->date "12:00:00.123" "~H:~M:~S.~N") (make-srfi:date 123000000 0 0 12 #t #t #t 0) "check 7") (check-equal? (string->date "12:00:00.123" "~H:~M:~S.~N") (srfi:make-date 123000000 0 0 12 #t #t #t 0) "check 7")
(check-equal? (string->date "12:00:00.12" "~H:~M:~S.~N") (make-srfi:date 120000000 0 0 12 #t #t #t 0) "check 8") (check-equal? (string->date "12:00:00.12" "~H:~M:~S.~N") (srfi:make-date 120000000 0 0 12 #t #t #t 0) "check 8")
(check-equal? (string->date "12:00:00.1" "~H:~M:~S.~N") (make-srfi:date 100000000 0 0 12 #t #t #t 0) "check 9") (check-equal? (string->date "12:00:00.1" "~H:~M:~S.~N") (srfi:make-date 100000000 0 0 12 #t #t #t 0) "check 9")
(check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (make-srfi:date 123456789 0 0 12 #t #t #t 0) "check 10") (check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (srfi:make-date 123456789 0 0 12 #t #t #t 0) "check 10")
(check-equal? (string->date "12:00:00.012345678" "~H:~M:~S.~N") (make-srfi:date 12345678 0 0 12 #t #t #t 0) "check 11") (check-equal? (string->date "12:00:00.012345678" "~H:~M:~S.~N") (srfi:make-date 12345678 0 0 12 #t #t #t 0) "check 11")
(check-equal? (string->date "12:00:00.001234567" "~H:~M:~S.~N") (make-srfi:date 1234567 0 0 12 #t #t #t 0) "check 12") (check-equal? (string->date "12:00:00.001234567" "~H:~M:~S.~N") (srfi:make-date 1234567 0 0 12 #t #t #t 0) "check 12")
(check-equal? (string->date "12:00:00.000123456" "~H:~M:~S.~N") (make-srfi:date 123456 0 0 12 #t #t #t 0) "check 13") (check-equal? (string->date "12:00:00.000123456" "~H:~M:~S.~N") (srfi:make-date 123456 0 0 12 #t #t #t 0) "check 13")
(check-equal? (string->date "12:00:00.000012345" "~H:~M:~S.~N") (make-srfi:date 12345 0 0 12 #t #t #t 0) "check 14") (check-equal? (string->date "12:00:00.000012345" "~H:~M:~S.~N") (srfi:make-date 12345 0 0 12 #t #t #t 0) "check 14")
(check-equal? (string->date "12:00:00.000001234" "~H:~M:~S.~N") (make-srfi:date 1234 0 0 12 #t #t #t 0) "check 15") (check-equal? (string->date "12:00:00.000001234" "~H:~M:~S.~N") (srfi:make-date 1234 0 0 12 #t #t #t 0) "check 15")
(check-equal? (string->date "12:00:00.000000123" "~H:~M:~S.~N") (make-srfi:date 123 0 0 12 #t #t #t 0) "check 16") (check-equal? (string->date "12:00:00.000000123" "~H:~M:~S.~N") (srfi:make-date 123 0 0 12 #t #t #t 0) "check 16")
(check-equal? (string->date "12:00:00.000000012" "~H:~M:~S.~N") (make-srfi:date 12 0 0 12 #t #t #t 0) "check 17") (check-equal? (string->date "12:00:00.000000012" "~H:~M:~S.~N") (srfi:make-date 12 0 0 12 #t #t #t 0) "check 17")
(check-equal? (string->date "12:00:00.000000001" "~H:~M:~S.~N") (make-srfi:date 1 0 0 12 #t #t #t 0) "check 18")) (check-equal? (string->date "12:00:00.000000001" "~H:~M:~S.~N") (srfi:make-date 1 0 0 12 #t #t #t 0) "check 18"))
(test-case (test-case
"date<->julian-day conversion" "date<->julian-day conversion"
(check = 365 (- (date->julian-day (make-srfi:date 0 0 0 0 1 1 2004 0)) (check = 365 (- (date->julian-day (srfi:make-date 0 0 0 0 1 1 2004 0))
(date->julian-day (make-srfi:date 0 0 0 0 1 1 2003 0)))) (date->julian-day (srfi:make-date 0 0 0 0 1 1 2003 0))))
(let ([test-date (make-srfi:date 0 0 0 0 1 1 2003 -7200)]) (let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)])
(check tm:date= test-date (julian-day->date (date->julian-day test-date) -7200)))) (check tm:date= test-date (julian-day->date (date->julian-day test-date) -7200))))
(test-case (test-case
"date->modified-julian-day conversion" "date->modified-julian-day conversion"
(check = 365 (- (date->modified-julian-day (make-srfi:date 0 0 0 0 1 1 2004 0)) (check = 365 (- (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2004 0))
(date->modified-julian-day (make-srfi:date 0 0 0 0 1 1 2003 0)))) (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2003 0))))
(let ([test-date (make-srfi:date 0 0 0 0 1 1 2003 -7200)]) (let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)])
(check tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200)))) (check tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200))))
)) ))

10
collects/srfi/19/time.ss
View File

@ -74,7 +74,7 @@
time-difference time-difference! add-duration add-duration! subtract-duration subtract-duration! time-difference time-difference! add-duration add-duration! subtract-duration subtract-duration!
;; Date object and accessors ;; Date object and accessors
;; date structure is provided by core PLT Scheme, we just extended tu support miliseconds: ;; date structure is provided by core PLT Scheme, we just extended tu support miliseconds:
make-srfi:date srfi:date? srfi:make-date srfi:date?
date-nanosecond srfi:date-second srfi:date-minute srfi:date-hour srfi:date-day srfi:date-month date-nanosecond srfi:date-second srfi:date-minute srfi:date-hour srfi:date-day srfi:date-month
srfi:date-year date-zone-offset srfi:date-year date-zone-offset
;; This are not part of the date structure (as they are in the original PLT Scheme's date) ;; This are not part of the date structure (as they are in the original PLT Scheme's date)
@ -582,7 +582,7 @@
time-in) time-in)
;; -- Date Structures ;; -- Date Structures
(define-values (tm:date make-srfi:date srfi:date? tm:date-ref tm:date-set!) (define-values (tm:date srfi:make-date srfi:date? tm:date-ref tm:date-set!)
(make-struct-type (make-struct-type
'tm:date #f 8 0 #f null (make-inspector) #f null)) 'tm:date #f 8 0 #f null (make-inspector) #f null))
;; PLT Scheme date structure has the following: ;; PLT Scheme date structure has the following:
@ -702,7 +702,7 @@
(rem (remainder secs (* 60 60))) (rem (remainder secs (* 60 60)))
(minutes (quotient rem 60)) (minutes (quotient rem 60))
(seconds (remainder rem 60)) ) (seconds (remainder rem 60)) )
(make-srfi:date (time-nanosecond time) (srfi:make-date (time-nanosecond time)
seconds seconds
minutes minutes
hours hours
@ -794,7 +794,7 @@
(tm:week-day (srfi:date-day date) (srfi:date-month date) (srfi:date-year date))) (tm:week-day (srfi:date-day date) (srfi:date-month date) (srfi:date-year date)))
(define (tm:days-before-first-week date day-of-week-starting-week) (define (tm:days-before-first-week date day-of-week-starting-week)
(let* ( (first-day (make-srfi:date 0 0 0 0 (let* ( (first-day (srfi:make-date 0 0 0 0
1 1
1 1
(srfi:date-year date) (srfi:date-year date)
@ -1480,7 +1480,7 @@
(srfi:date-month date) (srfi:date-month date)
(srfi:date-year date) (srfi:date-year date)
(date-zone-offset date))) (date-zone-offset date)))
(let ( (newdate (make-srfi:date 0 0 0 0 #t #t #t (tm:local-tz-offset))) ) (let ( (newdate (srfi:make-date 0 0 0 0 #t #t #t (tm:local-tz-offset))) )
(tm:string->date newdate (tm:string->date newdate
0 0
template-string template-string

4
collects/srfi/2.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-2 ;; module loader for SRFI-2
(module |2| mzscheme #lang s-exp srfi/provider srfi/2/and-let
(require srfi/2/and-let)
(provide (all-from srfi/2/and-let)))

4
collects/srfi/23.ss
View File

@ -1,3 +1,3 @@
;; Supported by core PLT: ;; Supported by core PLT:
(module |23| mzscheme #lang scheme/base
(provide error)) (provide error)

4
collects/srfi/25.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-25 ;; module loader for SRFI-25
(module |25| mzscheme #lang s-exp srfi/provider srfi/25/array
(require srfi/25/array)
(provide (all-from srfi/25/array)))

5
collects/srfi/26.ss
View File

@ -1,5 +1,2 @@
;; module loader for SRFI-26 ;; module loader for SRFI-26
#lang scheme/base #lang s-exp srfi/provider srfi/26/cut
(require srfi/26/cut)
(provide (all-from-out srfi/26/cut))

5
collects/srfi/27.ss
View File

@ -1,3 +1,2 @@
(module |27| mzscheme ;; module loader for SRFI-27
(require srfi/27/random-bits) #lang s-exp srfi/provider srfi/27/random-bits
(provide (all-from srfi/27/random-bits)))

4
collects/srfi/28.ss
View File

@ -1,3 +1,3 @@
;; Supported by core PLT: ;; Supported by core PLT:
(module |28| mzscheme #lang scheme/base
(provide format)) (provide format)

4
collects/srfi/29.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-29 ;; module loader for SRFI-29
(module |29| mzscheme #lang s-exp srfi/provider srfi/29/localization
(require srfi/29/localization)
(provide (all-from srfi/29/localization)))

4
collects/srfi/30.ss
View File

@ -1,2 +1,2 @@
;; Supported by core PLT: ;; Supported by core PLT, nothing to provide:
(module |30| mzscheme) #lang scheme/base

6
collects/srfi/31.ss
View File

@ -1,4 +1,2 @@
;; SRFI 31: A special form rec for recursive evaluation ;; module loader for SRFI-31: A special form rec for recursive evaluation
(module |31| mzscheme #lang s-exp srfi/provider srfi/31/rec
(require srfi/31/rec)
(provide rec))

5
collects/srfi/32.ss
View File

@ -1,3 +1,2 @@
(module |32| mzscheme ;; module loader for SRFI-32
(require (lib "srfi/32/sort.scm")) #lang s-exp srfi/provider "32/sort.scm"
(provide (all-from (lib "srfi/32/sort.scm"))))

4
collects/srfi/34.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-34 ;; module loader for SRFI-34
(module |34| mzscheme #lang s-exp srfi/provider srfi/34/exception
(require srfi/34/exception)
(provide (all-from srfi/34/exception)))

4
collects/srfi/35.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-35 ;; module loader for SRFI-35
(module |35| mzscheme #lang s-exp srfi/provider srfi/35/condition
(require srfi/35/condition)
(provide (all-from srfi/35/condition)))

6
collects/srfi/38.ss
View File

@ -1,4 +1,2 @@
;; Supported by core PLT: ;; module loader for SRFI-38
(module |38| mzscheme #lang s-exp srfi/provider srfi/38/38 #:unprefix s:
(provide (rename write write-with-shared-structure)
(rename read read-with-shared-structure)))

8
collects/srfi/38/38.ss Normal file
View File

@ -0,0 +1,8 @@
#lang scheme/base
(provide s:read s:write)
(define (s:write . args)
(parameterize ([print-graph #t]) (apply write args)))
(define (s:read . args)
(parameterize ([read-accept-graph #t]) (apply read args)))

4
collects/srfi/39.ss
View File

@ -1,3 +1,3 @@
;; Supported by core PLT: ;; Supported by core PLT:
(module |39| mzscheme #lang scheme/base
(provide make-parameter parameterize)) (provide make-parameter parameterize)

4
collects/srfi/40.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-40 ;; module loader for SRFI-40
(module |40| mzscheme #lang s-exp srfi/provider srfi/40/stream
(require srfi/40/stream)
(provide (all-from srfi/40/stream)))

4
collects/srfi/42.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-42 ;; module loader for SRFI-42
(module |42| mzscheme #lang s-exp srfi/provider srfi/42/comprehensions
(require srfi/42/comprehensions)
(provide (all-from srfi/42/comprehensions)))

8
collects/srfi/43.ss
View File

@ -1,8 +1,2 @@
;; module loader for SRFI-43 ;; module loader for SRFI-43
(module |43| mzscheme #lang s-exp srfi/provider srfi/43/vector-lib #:unprefix s:
(require srfi/43/vector-lib)
(provide (all-from-except srfi/43/vector-lib
s:vector-fill!
s:vector->list)
(rename s:vector-fill! vector-fill!)
(rename s:vector->list vector->list)))

10
collects/srfi/45.ss
View File

@ -1,10 +1,2 @@
;; module loader for SRFI-45 ;; module loader for SRFI-45
(module |45| mzscheme #lang s-exp srfi/provider srfi/45/lazy
(require srfi/45/lazy)
(provide (all-from-except srfi/45/lazy
s:delay
s:force
srfi-45-promise?)
(rename s:delay delay)
(rename s:force force)
(rename srfi-45-promise? promise?)))

46
collects/srfi/45/lazy.ss
View File

@ -1,38 +1,12 @@
; SRFI 45 #lang scheme/base
; Zhu Chongkai mrmathematica@yahoo.com
; 25-May-2005
(module lazy mzscheme
(provide lazy ;; scheme/promise has srfi-45-style primitives
eager (require scheme/promise)
s:delay (provide (all-from-out scheme/promise))
s:force
srfi-45-promise?)
(define-struct srfi-45-promise (content)) ;; TODO: there is a small difference between the primitives in srfi-45 and the
;; ones provided by scheme/promise (the latter is a bit more permissive). See
(define-syntax lazy ;; "library approach" in scheme/promise and see the post-finalization
(syntax-rules () ;; discussion on the srfi-45 list. I (Eli) showed at some point how the
((_ exp) ;; "language approach" primitives can be used to implement the other, and this
(make-srfi-45-promise (mcons #f (lambda () exp)))))) ;; needs to be done here too.
(define (eager x)
(make-srfi-45-promise (mcons #t x)))
(define-syntax s:delay
(syntax-rules ()
((_ exp) (lazy (eager exp)))))
(define (s:force promise)
(if (srfi-45-promise? promise)
(let ((content (srfi-45-promise-content promise)))
(if (mcar content)
(mcdr content)
(let* ((promise* ((mcdr content)))
(content (srfi-45-promise-content promise)))
(unless (mcar content)
(set-mcar! content (mcar (srfi-45-promise-content promise*)))
(set-mcdr! content (mcdr (srfi-45-promise-content promise*)))
(set-srfi-45-promise-content! promise* content))
(s:force promise))))
(raise-type-error 'force "srfi-45-promise" promise))))

4
collects/srfi/48.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-48 ;; module loader for SRFI-48
(module |48| mzscheme #lang s-exp srfi/provider srfi/48/format
(require srfi/48/format)
(provide (rename s:format format)))

4
collects/srfi/5.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-5 ;; module loader for SRFI-5
(module |5| mzscheme #lang s-exp srfi/provider srfi/5/let #:unprefix s:
(require (rename srfi/5/let my-let let))
(provide (rename my-let let)))

74
collects/srfi/5/let.ss
View File

@ -10,77 +10,77 @@
;;; Copyright (C) Andy Gaynor (1999-2003) ;;; Copyright (C) Andy Gaynor (1999-2003)
;;; ;;;
;;; The version of my-let here was cleaned up by: Paul Schlie <schlie@attbi.com>. ;;; The version of my-let here was cleaned up by: Paul Schlie <schlie@attbi.com>.
;;; Renamed to s:let by Eli Barzilay
(module let mzscheme #lang scheme/base
(provide (rename my-let let)) (provide s:let)
(define-syntax my-let (define-syntax s:let
(syntax-rules () (syntax-rules ()
;; standard ;; standard
((my-let () body ...) ((s:let () body ...)
(let () body ...)) (let () body ...))
((my-let ((var val) ...) body ...) ((s:let ((var val) ...) body ...)
(let ((var val) ...) body ...)) (let ((var val) ...) body ...))
;; rest style ;; rest style
((my-let ((var val) . bindings) body ...) ((s:let ((var val) . bindings) body ...)
(let-loop #f bindings (var) (val) (body ...))) (let-loop #f bindings (var) (val) (body ...)))
;; signature style ;; signature style
((my-let (name bindings ...) body ...) ((s:let (name bindings ...) body ...)
(let-loop name (bindings ...) () () (body ...))) (let-loop name (bindings ...) () () (body ...)))
;; standard named style ;; standard named style
((my-let name (bindings ...) body ...) ((s:let name (bindings ...) body ...)
(let-loop name (bindings ...) () () (body ...))) (let-loop name (bindings ...) () () (body ...)))
)) ))
;; A loop to walk down the list of bindings. ;; A loop to walk down the list of bindings.
(define-syntax let-loop (define-syntax let-loop
(syntax-rules () (syntax-rules ()
; No more bindings - make a LETREC. ;; No more bindings - make a LETREC.
((let-loop name () (vars ...) (vals ...) body) ((let-loop name () (vars ...) (vals ...) body)
((letrec ((name (lambda (vars ...) . body))) ((letrec ((name (lambda (vars ...) . body)))
name) name)
vals ...)) vals ...))
; Rest binding, no name ;; Rest binding, no name
((let-loop #f (rest-var rest-val ...) (var ...) (val ...) body) ((let-loop #f (rest-var rest-val ...) (var ...) (val ...) body)
(let ((var val) ... (rest-var (list rest-val ...))) . body)) (let ((var val) ... (rest-var (list rest-val ...))) . body))
; Process a (var val) pair. ;; Process a (var val) pair.
((let-loop name ((var val) more ...) (vars ...) (vals ...) body) ((let-loop name ((var val) more ...) (vars ...) (vals ...) body)
(let-loop name (more ...) (vars ... var) (vals ... val) body)) (let-loop name (more ...) (vars ... var) (vals ... val) body))
; End with a rest variable - make a LETREC. ;; End with a rest variable - make a LETREC.
((let-loop name (rest-var rest-vals ...) (vars ...) (vals ...) body) ((let-loop name (rest-var rest-vals ...) (vars ...) (vals ...) body)
((letrec ((name (lambda (vars ... . rest-var) . body))) ((letrec ((name (lambda (vars ... . rest-var) . body)))
name) name)
vals ... rest-vals ...)))) vals ... rest-vals ...))))
; Four loops - normal and `signature-style', each with and without a rest ;; Four loops - normal and `signature-style', each with and without a rest
; binding. ;; binding.
; ;;
;(let fibonacci ((n 10) (i 0) (f0 0) (f1 1)) ;;(let fibonacci ((n 10) (i 0) (f0 0) (f1 1))
; (if (= i n) ;; (if (= i n)
; f0 ;; f0
; (fibonacci n (+ i 1) f1 (+ f0 f1)))) ;; (fibonacci n (+ i 1) f1 (+ f0 f1))))
; ;;
;(let (fibonacci (n 10) (i 0) (f0 0) (f1 1)) ;;(let (fibonacci (n 10) (i 0) (f0 0) (f1 1))
; (if (= i n) ;; (if (= i n)
; f0 ;; f0
; (fibonacci n (+ i 1) f1 (+ f0 f1)))) ;; (fibonacci n (+ i 1) f1 (+ f0 f1))))
; ;;
;(let fibonacci ((n 10) (i 0) . (f 0 1)) ;;(let fibonacci ((n 10) (i 0) . (f 0 1))
; (if (= i n) ;; (if (= i n)
; (car f) ;; (car f)
; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f))))) ;; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f)))))
; ;;
;(let (fibonacci (n 10) (i 0) . (f 0 1)) ;;(let (fibonacci (n 10) (i 0) . (f 0 1))
; (if (= i n) ;; (if (= i n)
; (car f) ;; (car f)
; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f))))) ;; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f)))))
)

4
collects/srfi/54.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-54 ;; module loader for SRFI-54
(module |54| mzscheme #lang s-exp srfi/provider srfi/54/cat
(require srfi/54/cat)
(provide (all-from srfi/54/cat)))

58
collects/srfi/54/cat.ss
View File

@ -1,11 +1,14 @@
;; based on soo's (the author of the SRFI) R6RS implemenations ;; based on soo's (the author of the SRFI) R6RS implemenations
(module cat mzscheme #lang scheme/base
(provide cat) (provide cat)
(require (only mzlib/string expr->string)) (define (expr->string v writer)
(let ([port (open-output-string)])
(writer v port)
(get-output-string port)))
(define (take-both-end str take) (define (take-both-end str take)
(let ((left (car take))) (let ((left (car take)))
(cond (cond
((string? left) ((string? left)
@ -113,7 +116,7 @@
lt-str (substring str (- len right) len)) lt-str (substring str (- len right) len))
(string-append lt-str str))))))))))))) (string-append lt-str str)))))))))))))
(define (str-char-index str char start end) (define (str-char-index str char start end)
(let lp ((n start)) (let lp ((n start))
(if (= n end) (if (= n end)
#f #f
@ -121,7 +124,7 @@
n n
(lp (+ n 1)))))) (lp (+ n 1))))))
(define (str-numeric-index str start end) (define (str-numeric-index str start end)
(let lp ((n start)) (let lp ((n start))
(if (= n end) (if (= n end)
#f #f
@ -129,7 +132,7 @@
n n
(lp (+ n 1)))))) (lp (+ n 1))))))
(define (str-numeric? str start end) (define (str-numeric? str start end)
(let lp ((n start)) (let lp ((n start))
(if (= n end) (if (= n end)
#t #t
@ -137,7 +140,7 @@
(lp (+ n 1)) (lp (+ n 1))
#f)))) #f))))
(define (fixnum-string-separate str sep num sig) (define (fixnum-string-separate str sep num sig)
(let* ((len (string-length str)) (let* ((len (string-length str))
(dot-index (str-char-index str #\. 1 len))) (dot-index (str-char-index str #\. 1 len)))
(if dot-index (if dot-index
@ -206,7 +209,7 @@
(list (substring str ini len))))) (list (substring str ini len)))))
str))))) str)))))
(define (separate str sep num) (define (separate str sep num)
(let ((len (string-length str)) (let ((len (string-length str))
(n (abs num))) (n (abs num)))
(apply string-append (apply string-append
@ -220,7 +223,7 @@
(cons sep (loop pos (+ pos n)))) (cons sep (loop pos (+ pos n))))
(list (substring str ini len))))))) (list (substring str ini len)))))))
(define (every? pred ls) ;not for list but for pair & others (define (every? pred ls) ;not for list but for pair & others
(let lp ((ls ls)) (let lp ((ls ls))
(if (pair? ls) (if (pair? ls)
(if (pred (car ls)) (if (pred (car ls))
@ -232,7 +235,7 @@
#t #t
#f))))) #f)))))
(define (every-within-number? pred ls n) ;not for list but for pair & others (define (every-within-number? pred ls n) ;not for list but for pair & others
(let lp ((ls ls) (num 0)) (let lp ((ls ls) (num 0))
(if (pair? ls) (if (pair? ls)
(if (and (< num n) (pred (car ls))) (if (and (< num n) (pred (car ls)))
@ -244,12 +247,12 @@
#t #t
#f))))) #f)))))
(define (exact-integer/string? ns) (define (exact-integer/string? ns)
(or (and (integer? ns) (or (and (integer? ns)
(exact? ns)) (exact? ns))
(string? ns))) (string? ns)))
(define (mold str pre) (define (mold str pre)
(let* ((len (string-length str)) (let* ((len (string-length str))
(ind (str-char-index str #\. 1 (- len 1)))) (ind (str-char-index str #\. 1 (- len 1))))
(if ind (if ind
@ -291,7 +294,7 @@
(substring str 0 (+ 1 ind pre))))) (substring str 0 (+ 1 ind pre)))))
(string-append str "." (make-string pre #\0))))) (string-append str "." (make-string pre #\0)))))
(define (mold-non-finites str pre) (define (mold-non-finites str pre)
(let* ((len (string-length str)) (let* ((len (string-length str))
(ind (str-char-index str #\. 1 (- len 1))) (ind (str-char-index str #\. 1 (- len 1)))
(d-len (- len (+ ind 1)))) (d-len (- len (+ ind 1))))
@ -333,7 +336,7 @@
(substring str 0 (+ 1 ind pre)))) (substring str 0 (+ 1 ind pre))))
(error "cat: infinities or nans cannot have precisions")))) (error "cat: infinities or nans cannot have precisions"))))
(define (e-mold str pre) (define (e-mold str pre)
(let* ((len (string-length str)) (let* ((len (string-length str))
(e-index (str-char-index str #\e 1 (- len 1)))) (e-index (str-char-index str #\e 1 (- len 1))))
(if e-index (if e-index
@ -341,13 +344,13 @@
(substring str e-index len)) (substring str e-index len))
(mold-non-finites str pre)))) (mold-non-finites str pre))))
(define (flonum-mold str pre) (define (flonum-mold str pre)
(let* ((len (string-length str)) (let* ((len (string-length str))
(e-index (str-char-index str #\e 1 (- len 1)))) (e-index (str-char-index str #\e 1 (- len 1))))
(string-append (mold (substring str 0 e-index) pre) (string-append (mold (substring str 0 e-index) pre)
(substring str e-index len)))) (substring str e-index len))))
#;(define (remove-zero str len negative) #;(define (remove-zero str len negative)
(if negative (if negative
(let lp ((n 1)) (let lp ((n 1))
(let ((c (string-ref str n))) (let ((c (string-ref str n)))
@ -374,7 +377,7 @@
str str
(substring str n len)))))))) (substring str n len))))))))
(define (real->fixnum-string n) (define (real->fixnum-string n)
(let* ((str (number->string (exact->inexact n))) (let* ((str (number->string (exact->inexact n)))
(len (string-length str)) (len (string-length str))
(e-index (str-char-index str #\e 1 (- len 1)))) (e-index (str-char-index str #\e 1 (- len 1))))
@ -473,26 +476,26 @@
str str
(error "cat: infinities or nans cannot be changed into fixed-point numbers")))))) (error "cat: infinities or nans cannot be changed into fixed-point numbers"))))))
(define (non-0-index str start) (define (non-0-index str start)
(let lp ((n start)) (let lp ((n start))
(if (char=? #\0 (string-ref str n)) (if (char=? #\0 (string-ref str n))
(lp (+ 1 n)) (lp (+ 1 n))
n))) n)))
(define (non-0-index-right str end) (define (non-0-index-right str end)
(let lp ((n (- end 1))) (let lp ((n (- end 1)))
(if (char=? #\0 (string-ref str n)) (if (char=? #\0 (string-ref str n))
(lp (- n 1)) (lp (- n 1))
n))) n)))
#;(define (non-0-dot-index-right str end) #;(define (non-0-dot-index-right str end)
(let lp ((n (- end 1))) (let lp ((n (- end 1)))
(let ((c (string-ref str n))) (let ((c (string-ref str n)))
(if (or (char=? #\0 c) (char=? #\. c)) (if (or (char=? #\0 c) (char=? #\. c))
(lp (- n 1)) (lp (- n 1))
n)))) n))))
(define (real->flonum-string n) (define (real->flonum-string n)
(let* ((str (number->string (exact->inexact n))) (let* ((str (number->string (exact->inexact n)))
(len (string-length str)) (len (string-length str))
(e-index (str-char-index str #\e 1 (- len 1)))) (e-index (str-char-index str #\e 1 (- len 1))))
@ -551,7 +554,7 @@
"e+" "e+"
(number->string (- d-index 1))))))))))) (number->string (- d-index 1)))))))))))
(define-syntax wow-cat-end (define-syntax wow-cat-end
(syntax-rules () (syntax-rules ()
((wow-cat-end z n) ((wow-cat-end z n)
(car z)) (car z))
@ -565,7 +568,7 @@
(let ((n (car z))) (let ((n (car z)))
(if t ts fs))))) (if t ts fs)))))
(define-syntax wow-cat! (define-syntax wow-cat!
(syntax-rules () (syntax-rules ()
((wow-cat! z n d) ((wow-cat! z n d)
(let ((n (car z))) (let ((n (car z)))
@ -599,7 +602,7 @@
(begin (set! z (cdr z)) ts) (begin (set! z (cdr z)) ts)
(begin (set! z (cdr z)) fs)))))) (begin (set! z (cdr z)) fs))))))
(define-syntax %alet-cat* (define-syntax %alet-cat*
(syntax-rules () (syntax-rules ()
((%alet-cat* z ((n d t ...)) bd ...) ((%alet-cat* z ((n d t ...)) bd ...)
(let ((n (if (null? z) (let ((n (if (null? z)
@ -616,13 +619,13 @@
((%alet-cat* z e bd ...) ((%alet-cat* z e bd ...)
(let ((e z)) bd ...)))) (let ((e z)) bd ...))))
(define-syntax alet-cat* (define-syntax alet-cat*
(syntax-rules () (syntax-rules ()
((alet-cat* z (a . e) bd ...) ((alet-cat* z (a . e) bd ...)
(let ((y z)) (let ((y z))
(%alet-cat* y (a . e) bd ...))))) (%alet-cat* y (a . e) bd ...)))))
(define (cat object . rest) (define (cat object . rest)
(if (null? rest) (if (null? rest)
(cond (cond
((number? object) (number->string object)) ((number? object) (number->string object))
@ -946,4 +949,3 @@
(if port (if port
(display str port) (display str port)
str))))) str)))))
)

4
collects/srfi/57.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-57 ;; module loader for SRFI-57
(module |57| mzscheme #lang s-exp srfi/provider srfi/57/records
(require srfi/57/records)
(provide (all-from srfi/57/records)))

4
collects/srfi/59.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-59 ;; module loader for SRFI-59
(module |59| mzscheme #lang s-exp srfi/provider srfi/59/vicinity
(require srfi/59/vicinity)
(provide (all-from srfi/59/vicinity)))

4
collects/srfi/6.ss
View File

@ -1,3 +1,3 @@
;; Supported by core PLT: ;; Supported by core PLT:
(module |6| mzscheme #lang scheme/base
(provide get-output-string open-input-string open-output-string)) (provide get-output-string open-input-string open-output-string)

6
collects/srfi/60.ss
View File

@ -1,5 +1 @@
(module |60| mzscheme #lang s-exp srfi/provider srfi/60/60
(require srfi/60/60)
(provide (all-from srfi/60/60))
)

4
collects/srfi/61.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-61 ;; module loader for SRFI-61
(module |61| mzscheme #lang s-exp srfi/provider srfi/61/cond #:unprefix srfi:
(require srfi/61/cond)
(provide (rename srfi:cond cond)))

6
collects/srfi/63.ss
View File

@ -1,4 +1,2 @@
(module |63| mzscheme ;; module loader for SRFI-1
(require srfi/63/63) #lang s-exp srfi/provider srfi/63/63 #:unprefix s:
(provide (all-from-except srfi/63/63 s:equal?)
(rename s:equal? equal?)))

4
collects/srfi/64.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-64 ;; module loader for SRFI-64
(module |64| mzscheme #lang s-exp srfi/provider srfi/64/testing
(require srfi/64/testing)
(provide (all-from srfi/64/testing)))

5
collects/srfi/67.ss
View File

@ -1,3 +1,2 @@
(module |67| mzscheme ;; module loader for SRFI-67
(require srfi/67/compare) #lang s-exp srfi/provider srfi/67/compare
(provide (all-from srfi/67/compare)))

10
collects/srfi/69.ss
View File

@ -1,10 +1,2 @@
;; module loader for SRFI-69 ;; module loader for SRFI-69
(module |69| mzscheme #lang s-exp srfi/provider srfi/69/hash #:unprefix s:
(require srfi/69/hash)
(provide (all-from-except srfi/69/hash
s:make-hash-table
s:hash-table?
s:hash-table-copy)
(rename s:make-hash-table make-hash-table)
(rename s:hash-table? hash-table?)
(rename s:hash-table-copy hash-table-copy)))

4
collects/srfi/7.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-7 ;; module loader for SRFI-7
(module |7| mzscheme #lang s-exp srfi/provider srfi/7/program
(require srfi/7/program)
(provide (all-from srfi/7/program)))

14
collects/srfi/71.ss
View File

@ -1,14 +1,2 @@
;; module loader for SRFI-71 ;; module loader for SRFI-71
(module |71| mzscheme #lang s-exp srfi/provider srfi/71/letvalues #:unprefix srfi-
(require srfi/71/letvalues)
(provide (all-from-except srfi/71/letvalues
let
let*
letrec
srfi-let
srfi-let*
srfi-letrec))
(provide (rename srfi-let let)
(rename srfi-let* let*)
(rename srfi-letrec letrec)
(rename srfi-letrec letrec*)))

110
collects/srfi/71/letvalues.ss
View File

@ -1,11 +1,9 @@
; Reference implementation of SRFI-71 using PLT 208's modules ; Reference implementation of SRFI-71 using PLT 208's modules
; Sebastian.Egner@philips.com, 29-Apr-2005 ; Sebastian.Egner@philips.com, 29-Apr-2005
(module letvalues mzscheme #lang scheme/base
(provide (all-from mzscheme)) (provide srfi-let
(provide srfi-let
srfi-let* srfi-let*
srfi-letrec srfi-letrec
srfi-letrec* srfi-letrec*
@ -14,43 +12,43 @@
uncons-2 uncons-3 uncons-4 uncons-2 uncons-3 uncons-4
uncons-cons) uncons-cons)
; --- textual copy of 'letvalues.scm' starts here --- ; --- textual copy of 'letvalues.scm' starts here ---
; Reference implementation of SRFI-71 (generic part) ; Reference implementation of SRFI-71 (generic part)
; Sebastian.Egner@philips.com, 20-May-2005, PLT 208 ; Sebastian.Egner@philips.com, 20-May-2005, PLT 208
; ;
; In order to avoid conflicts with the existing let etc. ; In order to avoid conflicts with the existing let etc.
; the macros defined here are called srfi-let etc., ; the macros defined here are called srfi-let etc.,
; and they are defined in terms of r5rs-let etc. ; and they are defined in terms of r5rs-let etc.
; It is up to the actual implementation to save let/*/rec ; It is up to the actual implementation to save let/*/rec
; in r5rs-let/*/rec first and redefine let/*/rec ; in r5rs-let/*/rec first and redefine let/*/rec
; by srfi-let/*/rec then. ; by srfi-let/*/rec then.
; ;
; There is also a srfi-letrec* being defined (in view of R6RS.) ; There is also a srfi-letrec* being defined (in view of R6RS.)
; ;
; Macros used internally are named i:<something>. ; Macros used internally are named i:<something>.
; ;
; Abbreviations for macro arguments: ; Abbreviations for macro arguments:
; bs - <binding spec> ; bs - <binding spec>
; b - component of a binding spec (values, <variable>, or <expression>) ; b - component of a binding spec (values, <variable>, or <expression>)
; v - <variable> ; v - <variable>
; vr - <variable> for rest list ; vr - <variable> for rest list
; x - <expression> ; x - <expression>
; t - newly introduced temporary variable ; t - newly introduced temporary variable
; vx - (<variable> <expression>) ; vx - (<variable> <expression>)
; rec - flag if letrec is produced (and not let) ; rec - flag if letrec is produced (and not let)
; cwv - call-with-value skeleton of the form (x formals) ; cwv - call-with-value skeleton of the form (x formals)
; (call-with-values (lambda () x) (lambda formals /payload/)) ; (call-with-values (lambda () x) (lambda formals /payload/))
; where /payload/ is of the form (let (vx ...) body1 body ...). ; where /payload/ is of the form (let (vx ...) body1 body ...).
; ;
; Remark (*): ; Remark (*):
; We bind the variables of a letrec to i:undefined since there is ; We bind the variables of a letrec to i:undefined since there is
; no portable (R5RS) way of binding a variable to a values that ; no portable (R5RS) way of binding a variable to a values that
; raises an error when read uninitialized. ; raises an error when read uninitialized.
(define i:undefined 'undefined) (define i:undefined 'undefined)
(define-syntax srfi-letrec* ; -> srfi-letrec (define-syntax srfi-letrec* ; -> srfi-letrec
(syntax-rules () (syntax-rules ()
((srfi-letrec* () body1 body ...) ((srfi-letrec* () body1 body ...)
(srfi-letrec () body1 body ...)) (srfi-letrec () body1 body ...))
@ -59,12 +57,12 @@
((srfi-letrec* (bs1 bs2 bs ...) body1 body ...) ((srfi-letrec* (bs1 bs2 bs ...) body1 body ...)
(srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...))))) (srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...)))))
(define-syntax srfi-letrec ; -> i:let (define-syntax srfi-letrec ; -> i:let
(syntax-rules () (syntax-rules ()
((srfi-letrec ((b1 b2 b ...) ...) body1 body ...) ((srfi-letrec ((b1 b2 b ...) ...) body1 body ...)
(i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...))))) (i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...)))))
(define-syntax srfi-let* ; -> srfi-let (define-syntax srfi-let* ; -> srfi-let
(syntax-rules () (syntax-rules ()
((srfi-let* () body1 body ...) ((srfi-let* () body1 body ...)
(srfi-let () body1 body ...)) (srfi-let () body1 body ...))
@ -73,14 +71,14 @@
((srfi-let* (bs1 bs2 bs ...) body1 body ...) ((srfi-let* (bs1 bs2 bs ...) body1 body ...)
(srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...))))) (srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...)))))
(define-syntax srfi-let ; -> i:let or i:named-let (define-syntax srfi-let ; -> i:let or i:named-let
(syntax-rules () (syntax-rules ()
((srfi-let ((b1 b2 b ...) ...) body1 body ...) ((srfi-let ((b1 b2 b ...) ...) body1 body ...)
(i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...))) (i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...)))
((srfi-let tag ((b1 b2 b ...) ...) body1 body ...) ((srfi-let tag ((b1 b2 b ...) ...) body1 body ...)
(i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...))))) (i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...)))))
(define-syntax i:let (define-syntax i:let
(syntax-rules (values) (syntax-rules (values)
; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...)) ; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...))
@ -177,7 +175,7 @@
)) ))
(define-syntax i:named-let (define-syntax i:named-let
(syntax-rules (values) (syntax-rules (values)
; (i:named-let tag (vx ...) body (bs ...)) ; (i:named-let tag (vx ...) body (bs ...))
@ -192,41 +190,39 @@
((i:named-let tag (vx ...) body ((v x) bs ...)) ((i:named-let tag (vx ...) body ((v x) bs ...))
(i:named-let tag (vx ... (v x)) body (bs ...))))) (i:named-let tag (vx ... (v x)) body (bs ...)))))
; --- standard procedures --- ; --- standard procedures ---
(define (uncons pair) (define (uncons pair)
(values (car pair) (cdr pair))) (values (car pair) (cdr pair)))
(define (uncons-2 list) (define (uncons-2 list)
(values (car list) (cadr list) (cddr list))) (values (car list) (cadr list) (cddr list)))
(define (uncons-3 list) (define (uncons-3 list)
(values (car list) (cadr list) (caddr list) (cdddr list))) (values (car list) (cadr list) (caddr list) (cdddr list)))
(define (uncons-4 list) (define (uncons-4 list)
(values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list))) (values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list)))
(define (uncons-cons alist) (define (uncons-cons alist)
(values (caar alist) (cdar alist) (cdr alist))) (values (caar alist) (cdar alist) (cdr alist)))
(define (unlist list) (define (unlist list)
(apply values list)) (apply values list))
(define (unvector vector) (define (unvector vector)
(apply values (vector->list vector))) (apply values (vector->list vector)))
; --- standard macros --- ; --- standard macros ---
(define-syntax values->list (define-syntax values->list
(syntax-rules () (syntax-rules ()
((values->list x) ((values->list x)
(call-with-values (lambda () x) list)))) (call-with-values (lambda () x) list))))
(define-syntax values->vector (define-syntax values->vector
(syntax-rules () (syntax-rules ()
((values->vector x) ((values->vector x)
(call-with-values (lambda () x) vector)))) (call-with-values (lambda () x) vector))))
; --- textual copy of 'letvalues.scm' ends here --- ; --- textual copy of 'letvalues.scm' ends here ---
) ; module letvalues

5
collects/srfi/74.ss
View File

@ -1,3 +1,2 @@
(module |74| mzscheme ;; module loader for SRFI-13
(require srfi/74/74) #lang s-exp srfi/provider srfi/74/74
(provide (all-from srfi/74/74)))

5
collects/srfi/78.ss
View File

@ -1,3 +1,2 @@
(module |78| mzscheme ;; module loader for SRFI-78
(require srfi/78/check) #lang s-exp srfi/provider srfi/78/check
(provide (all-from srfi/78/check)))

33
collects/srfi/78/check-reference.scm
View File

@ -99,10 +99,10 @@
(define (check:report-correct cases) (define (check:report-correct cases)
(display "correct") (display "correct")
(if (not (= cases 1)) (unless (= cases 1)
(begin (display " (") (display " (")
(display cases) (display cases)
(display " cases checked)"))) (display " cases checked)"))
(newline)) (newline))
(define (check:report-failed expected-result) (define (check:report-failed expected-result)
@ -113,8 +113,7 @@
(newline)) (newline))
(define (check-report) (define (check-report)
(if (>= check:mode 1) (when (>= check:mode 1)
(begin
(newline) (newline)
(display "; *** checks *** : ") (display "; *** checks *** : ")
(display check:correct) (display check:correct)
@ -131,7 +130,7 @@
(newline) (newline)
(check:report-expression expression) (check:report-expression expression)
(check:report-actual-result actual-result) (check:report-actual-result actual-result)
(check:report-failed expected-result)))))) (check:report-failed expected-result)))))
(define (check-passed? expected-total-count) (define (check-passed? expected-total-count)
(and (= (length check:failed) 0) (and (= (length check:failed) 0)
@ -168,14 +167,14 @@
actual-result actual-result
expected-result))))) expected-result)))))
(else (error "unrecognized check:mode" check:mode))) (else (error "unrecognized check:mode" check:mode)))
(if #f #f)) (void))
(define-syntax check (define-syntax check
(syntax-rules (=>) (syntax-rules (=>)
((check expr => expected) ((check expr => expected)
(check expr (=> equal?) expected)) (check expr (=> equal?) expected))
((check expr (=> equal) expected) ((check expr (=> equal) expected)
(if (>= check:mode 1) (when (>= check:mode 1)
(check:proc 'expr (lambda () expr) equal expected))))) (check:proc 'expr (lambda () expr) equal expected)))))
; -- parametric checks -- ; -- parametric checks --
@ -187,15 +186,15 @@
(expected-result (cadddr w)) (expected-result (cadddr w))
(cases (car (cddddr w)))) (cases (car (cddddr w))))
(if correct? (if correct?
(begin (if (>= check:mode 100) (begin (when (>= check:mode 100)
(begin (check:report-expression expression) (check:report-expression expression)
(check:report-actual-result actual-result) (check:report-actual-result actual-result)
(check:report-correct cases))) (check:report-correct cases))
(check:add-correct!)) (check:add-correct!))
(begin (if (>= check:mode 10) (begin (when (>= check:mode 10)
(begin (check:report-expression expression) (check:report-expression expression)
(check:report-actual-result actual-result) (check:report-actual-result actual-result)
(check:report-failed expected-result))) (check:report-failed expected-result))
(check:add-failed! expression (check:add-failed! expression
actual-result actual-result
expected-result))))) expected-result)))))
@ -203,7 +202,7 @@
(define-syntax check-ec:make (define-syntax check-ec:make
(syntax-rules (=>) (syntax-rules (=>)
((check-ec:make qualifiers expr (=> equal) expected (arg ...)) ((check-ec:make qualifiers expr (=> equal) expected (arg ...))
(if (>= check:mode 1) (when (>= check:mode 1)
(check:proc-ec (check:proc-ec
(let ((cases 0)) (let ((cases 0))
(let ((w (first-ec (let ((w (first-ec
@ -226,8 +225,8 @@
'(check-ec qualifiers '(check-ec qualifiers
expr (=> equal) expr (=> equal)
expected (arg ...)) expected (arg ...))
(if #f #f) (void)
(if #f #f) (void)
cases))))))))) cases)))))))))
; (*) is a compile-time check that (arg ...) is a list ; (*) is a compile-time check that (arg ...) is a list

10
collects/srfi/78/check.ss
View File

@ -1,14 +1,14 @@
(module check mzscheme #lang scheme/base
(require mzlib/include (require mzlib/include
srfi/23 srfi/23
srfi/42 srfi/42
mzlib/pretty) mzlib/pretty)
(include "check-reference.scm") (include "check-reference.scm")
(provide check (provide check
check-ec check-ec
check-report check-report
check-set-mode! check-set-mode!
check-reset! check-reset!
check-passed?)) check-passed?)

4
collects/srfi/8.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-8 ;; module loader for SRFI-8
(module |8| mzscheme #lang s-exp srfi/provider srfi/8/receive
(require srfi/8/receive)
(provide (all-from srfi/8/receive)))

6
collects/srfi/86.ss
View File

@ -1,4 +1,2 @@
(module |86| mzscheme ;; module loader for SRFI-86
(require srfi/86/86) #lang s-exp srfi/provider srfi/86/86
(provide (all-from srfi/86/86))
)

234
collects/srfi/86/86.ss
View File

@ -1,30 +1,27 @@
(module |86| mzscheme #lang mzscheme
(provide (all-from mzscheme)) (provide mu nu alet alet*)
(provide mu nu ;;; mu & nu
alet alet*) (define-syntax mu
;;; mu & nu
(define-syntax mu
(syntax-rules () (syntax-rules ()
((mu argument ...) ((mu argument ...)
(lambda (f) (f argument ...))))) (lambda (f) (f argument ...)))))
(define-syntax nu (define-syntax nu
(syntax-rules () (syntax-rules ()
((nu argument ...) ((nu argument ...)
(lambda (f) (apply f argument ...))))) (lambda (f) (apply f argument ...)))))
;;; alet ;;; alet
(define-syntax alet (define-syntax alet
(syntax-rules () (syntax-rules ()
((alet (bn ...) bd ...) ((alet (bn ...) bd ...)
(%alet () () (bn ...) bd ...)) (%alet () () (bn ...) bd ...))
((alet var (bn ...) bd ...) ((alet var (bn ...) bd ...)
(%alet (var) () (bn ...) bd ...)))) (%alet (var) () (bn ...) bd ...))))
(define-syntax %alet (define-syntax %alet
(syntax-rules (opt cat key rec and values) (syntax-rules (opt cat key rec and values)
((%alet () ((n v) ...) () bd ...) ((%alet () ((n v) ...) () bd ...)
((lambda (n ...) bd ...) v ...)) ((lambda (n ...) bd ...) v ...))
@ -51,7 +48,8 @@
(bn ...) bd ...)) (bn ...) bd ...))
((%alet "dot" (p ...) (nv ...) (values t ...) (() c) (bn ...) bd ...) ((%alet "dot" (p ...) (nv ...) (values t ...) (() c) (bn ...) bd ...)
(call-with-values (lambda () c) (call-with-values (lambda () c)
(lambda (t ...) (%alet (p ...) (nv ...) (bn ...) bd ...)))) (lambda (t ...)
(%alet (p ...) (nv ...) (bn ...) bd ...))))
((%alet "dot" (p ...) (nv ...) (values t ...) (() c ...) (bn ...) bd ...) ((%alet "dot" (p ...) (nv ...) (values t ...) (() c ...) (bn ...) bd ...)
((lambda (t ...) (%alet (p ...) (nv ...) (bn ...) bd ...)) c ...)) ((lambda (t ...) (%alet (p ...) (nv ...) (bn ...) bd ...)) c ...))
((%alet "dot" (p ...) (nv ...) (values t ...) (b c) (bn ...) bd ...) ((%alet "dot" (p ...) (nv ...) (values t ...) (b c) (bn ...) bd ...)
@ -184,7 +182,8 @@
(bn ...) bd ...)) (bn ...) bd ...))
((%alet "not" (p ...) (nv ...) (values t ...) (z) (bn ...) bd ...) ((%alet "not" (p ...) (nv ...) (values t ...) (z) (bn ...) bd ...)
(call-with-values (lambda () z) (call-with-values (lambda () z)
(lambda (t ...) (%alet (p ...) (nv ...) (bn ...) bd ...)))) (lambda (t ...)
(%alet (p ...) (nv ...) (bn ...) bd ...))))
((%alet (p ...) (nv ...) ((a b c ...) bn ...) bd ...) ((%alet (p ...) (nv ...) ((a b c ...) bn ...) bd ...)
(%alet "not" (p ...) (nv ... (a t)) (t) (b c ...) (bn ...) bd ...)) (%alet "not" (p ...) (nv ... (a t)) (t) (b c ...) (bn ...) bd ...))
@ -207,8 +206,8 @@
((%alet (p ...) (nv ...) (a b bn ...) bd ...) ((%alet (p ...) (nv ...) (a b bn ...) bd ...)
(b (lambda t (%alet (p ...) (nv ... (a t)) (bn ...) bd ...)))))) (b (lambda t (%alet (p ...) (nv ... (a t)) (bn ...) bd ...))))))
;;; alet* ;;; alet*
(define-syntax alet* (define-syntax alet*
(syntax-rules (opt cat key rec and values) (syntax-rules (opt cat key rec and values)
((alet* () bd ...) ((alet* () bd ...)
((lambda () bd ...))) ((lambda () bd ...)))
@ -278,7 +277,7 @@
((alet* var (bn ...) bd ...) ((alet* var (bn ...) bd ...)
(%alet* (var) () (bn ...) bd ...)))) (%alet* (var) () (bn ...) bd ...))))
(define-syntax %alet* (define-syntax %alet*
(syntax-rules (opt cat key rec and values) (syntax-rules (opt cat key rec and values)
((%alet* (var) (n ...) () bd ...) ((%alet* (var) (n ...) () bd ...)
((letrec ((var (lambda* (n ...) bd ...))) ((letrec ((var (lambda* (n ...) bd ...)))
@ -305,10 +304,12 @@
(%alet* "one" (p ...) (n ... a) (values r ... a) (b c) (bn ...) bd ...)) (%alet* "one" (p ...) (n ... a) (values r ... a) (b c) (bn ...) bd ...))
((%alet* "one" (p ...) (n ...) (values r ...) (() c) (bn ...) bd ...) ((%alet* "one" (p ...) (n ...) (values r ...) (() c) (bn ...) bd ...)
(call-with-values (lambda () c) (call-with-values (lambda () c)
(lambda* (r ...) (%alet* (p ...) (n ...) (bn ...) bd ...)))) (lambda* (r ...)
(%alet* (p ...) (n ...) (bn ...) bd ...))))
((%alet* "one" (p ...) (n ...) (values r ...) (b c) (bn ...) bd ...) ((%alet* "one" (p ...) (n ...) (values r ...) (b c) (bn ...) bd ...)
(call-with-values (lambda () c) (call-with-values (lambda () c)
(lambda* (r ... . b) (%alet* (p ...) (n ... b) (bn ...) bd ...)))) (lambda* (r ... . b)
(%alet* (p ...) (n ... b) (bn ...) bd ...))))
((%alet* (p ...) (n ...) (((values . b) c d ...) bn ...) bd ...) ((%alet* (p ...) (n ...) (((values . b) c d ...) bn ...) bd ...)
(%alet* "dot" (p ...) (n ...) (b c d ...) (bn ...) bd ...)) (%alet* "dot" (p ...) (n ...) (b c d ...) (bn ...) bd ...))
@ -447,8 +448,8 @@
((%alet* (p ...) (n ...) (a b bn ...) bd ...) ((%alet* (p ...) (n ...) (a b bn ...) bd ...)
(b (lambda a (%alet* (p ...) (n ... a) (bn ...) bd ...)))))) (b (lambda a (%alet* (p ...) (n ... a) (bn ...) bd ...))))))
;;; auxiliaries ;;; auxiliaries
(define-syntax lambda* (define-syntax lambda*
(syntax-rules () (syntax-rules ()
((lambda* (a . e) bd ...) ((lambda* (a . e) bd ...)
(lambda* "star" (ta) (a) e bd ...)) (lambda* "star" (ta) (a) e bd ...))
@ -463,7 +464,7 @@
((lambda* e bd ...) ((lambda* e bd ...)
(lambda e bd ...)))) (lambda e bd ...))))
(define-syntax alet-and (define-syntax alet-and
(syntax-rules () (syntax-rules ()
((alet-and ((n v t ...) ...) bd ...) ((alet-and ((n v t ...) ...) bd ...)
(alet-and "and" () ((n v t ...) ...) bd ...)) (alet-and "and" () ((n v t ...) ...) bd ...))
@ -477,7 +478,7 @@
((alet-and "and" ((n t) ...) () bd ...) ((alet-and "and" ((n t) ...) () bd ...)
((lambda (n ...) bd ...) t ...)))) ((lambda (n ...) bd ...) t ...))))
(define-syntax alet-and* (define-syntax alet-and*
(syntax-rules () (syntax-rules ()
((alet-and* () bd ...) ((alet-and* () bd ...)
((lambda () bd ...))) ((lambda () bd ...)))
@ -488,7 +489,7 @@
(let ((n v)) (let ((n v))
(and t (alet-and* (nvt ...) bd ...)))))) (and t (alet-and* (nvt ...) bd ...))))))
(define-syntax alet-rec (define-syntax alet-rec
(syntax-rules () (syntax-rules ()
((alet-rec ((n v) ...) bd ...) ((alet-rec ((n v) ...) bd ...)
(alet-rec "rec" () ((n v) ...) bd ...)) (alet-rec "rec" () ((n v) ...) bd ...))
@ -502,7 +503,7 @@
;; bd ...)))))) ;; bd ...))))))
bd ...))))) bd ...)))))
(define-syntax alet-rec* (define-syntax alet-rec*
(syntax-rules () (syntax-rules ()
((alet-rec* ((n v) ...) bd ...) ((alet-rec* ((n v) ...) bd ...)
(let* ((n '<undefined>) ...) (let* ((n '<undefined>) ...)
@ -511,7 +512,7 @@
;; bd ...))))) ;; bd ...)))))
bd ...)))) bd ...))))
(define-syntax wow-opt (define-syntax wow-opt
(syntax-rules () (syntax-rules ()
((wow-opt n v) ((wow-opt n v)
v) v)
@ -525,7 +526,7 @@
(let ((n v)) (let ((n v))
(if t ts fs))))) (if t ts fs)))))
(define-syntax wow-opt! (define-syntax wow-opt!
(syntax-rules () (syntax-rules ()
((wow-opt! z n) ((wow-opt! z n)
(let ((n (car z))) (let ((n (car z)))
@ -547,7 +548,7 @@
(begin (set! z (cdr z)) ts) (begin (set! z (cdr z)) ts)
(begin (set! z (cdr z)) fs)))))) (begin (set! z (cdr z)) fs))))))
(define-syntax wow-cat-end (define-syntax wow-cat-end
(syntax-rules () (syntax-rules ()
((wow-cat-end z n) ((wow-cat-end z n)
(car z)) (car z))
@ -561,7 +562,7 @@
(let ((n (car z))) (let ((n (car z)))
(if t ts fs))))) (if t ts fs)))))
(define-syntax wow-cat (define-syntax wow-cat
(syntax-rules () (syntax-rules ()
((wow-cat z n d) ((wow-cat z n d)
z) z)
@ -593,7 +594,7 @@
(cons ts (cdr z)) (cons ts (cdr z))
(cons fs (cdr z))))))) (cons fs (cdr z)))))))
(define-syntax wow-cat! (define-syntax wow-cat!
(syntax-rules () (syntax-rules ()
((wow-cat! z n d) ((wow-cat! z n d)
(let ((n (car z))) (let ((n (car z)))
@ -627,7 +628,7 @@
(begin (set! z (cdr z)) ts) (begin (set! z (cdr z)) ts)
(begin (set! z (cdr z)) fs)))))) (begin (set! z (cdr z)) fs))))))
(define-syntax wow-key! (define-syntax wow-key!
(syntax-rules () (syntax-rules ()
((wow-key! z () (kk ...) (n key) d) ((wow-key! z () (kk ...) (n key) d)
(let ((x (car z)) (let ((x (car z))
@ -983,12 +984,12 @@
(cons x head)) (cons x head))
(if m (cdr y) y))))))))))))))) (if m (cdr y) y)))))))))))))))
(define-syntax alet-opt* (define-syntax alet-opt*
(syntax-rules () (syntax-rules ()
((alet-opt* z (a . e) bd ...) ((alet-opt* z (a . e) bd ...)
(let ((y z)) (let ((y z))
(%alet-opt* y (a . e) bd ...))))) (%alet-opt* y (a . e) bd ...)))))
(define-syntax %alet-opt* (define-syntax %alet-opt*
(syntax-rules () (syntax-rules ()
((%alet-opt* z ((n d t ...)) bd ...) ((%alet-opt* z ((n d t ...)) bd ...)
(let ((n (if (null? z) (let ((n (if (null? z)
@ -1005,69 +1006,69 @@
(%alet-opt* y e bd ...))) (%alet-opt* y e bd ...)))
((%alet-opt* z e bd ...) ((%alet-opt* z e bd ...)
(let ((e z)) bd ...)))) (let ((e z)) bd ...))))
;; (define-syntax %alet-opt* ;; (define-syntax %alet-opt*
;; (syntax-rules () ;; (syntax-rules ()
;; ((%alet-opt* z ((n d t ...)) bd ...) ;; ((%alet-opt* z ((n d t ...)) bd ...)
;; (let ((n (if (null? z) ;; (let ((n (if (null? z)
;; d ;; d
;; (if (null? (cdr z)) ;; (if (null? (cdr z))
;; (wow-opt n (car z) t ...) ;; (wow-opt n (car z) t ...)
;; (error "alet*: too many arguments" (cdr z)))))) ;; (error "alet*: too many arguments" (cdr z))))))
;; bd ...)) ;; bd ...))
;; ((%alet-opt* z ((n d t ...) . e) bd ...) ;; ((%alet-opt* z ((n d t ...) . e) bd ...)
;; (let ((n (if (null? z) ;; (let ((n (if (null? z)
;; d ;; d
;; (wow-opt! z n t ...)))) ;; (wow-opt! z n t ...))))
;; (%alet-opt* z e bd ...))) ;; (%alet-opt* z e bd ...)))
;; ((%alet-opt* z e bd ...) ;; ((%alet-opt* z e bd ...)
;; (let ((e z)) bd ...)))) ;; (let ((e z)) bd ...))))
;; (define-syntax %alet-opt* ;; (define-syntax %alet-opt*
;; (syntax-rules () ;; (syntax-rules ()
;; ((%alet-opt* z (ndt ...) (a . e) bd ...) ;; ((%alet-opt* z (ndt ...) (a . e) bd ...)
;; (%alet-opt* z (ndt ... a) e bd ...)) ;; (%alet-opt* z (ndt ... a) e bd ...))
;; ((%alet-opt* z ((n d t ...) (nn dd tt ...) ...) () bd ...) ;; ((%alet-opt* z ((n d t ...) (nn dd tt ...) ...) () bd ...)
;; (if (null? z) ;; (if (null? z)
;; (let* ((n d) (nn dd) ...) bd ...) ;; (let* ((n d) (nn dd) ...) bd ...)
;; (let ((y (cdr z)) ;; (let ((y (cdr z))
;; (n (wow-opt n (car z) t ...))) ;; (n (wow-opt n (car z) t ...)))
;; (%alet-opt* y ((nn dd tt ...) ...) () bd ...)))) ;; (%alet-opt* y ((nn dd tt ...) ...) () bd ...))))
;; ((%alet-opt* z () () bd ...) ;; ((%alet-opt* z () () bd ...)
;; (if (null? z) ;; (if (null? z)
;; (let () bd ...) ;; (let () bd ...)
;; (error "alet*: too many arguments" z))) ;; (error "alet*: too many arguments" z)))
;; ((%alet-opt* z ((n d t ...) (nn dd tt ...) ...) e bd ...) ;; ((%alet-opt* z ((n d t ...) (nn dd tt ...) ...) e bd ...)
;; (if (null? z) ;; (if (null? z)
;; (let* ((n d) (nn dd) ... (e z)) bd ...) ;; (let* ((n d) (nn dd) ... (e z)) bd ...)
;; (let ((y (cdr z)) ;; (let ((y (cdr z))
;; (n (wow-opt n (car z) t ...))) ;; (n (wow-opt n (car z) t ...)))
;; (%alet-opt* y ((nn dd tt ...) ...) e bd ...)))) ;; (%alet-opt* y ((nn dd tt ...) ...) e bd ...))))
;; ((%alet-opt* z () e bd ...) ;; ((%alet-opt* z () e bd ...)
;; (let ((e z)) bd ...)))) ;; (let ((e z)) bd ...))))
(define-syntax alet-cat* (define-syntax alet-cat*
(syntax-rules () (syntax-rules ()
((alet-cat* z (a . e) bd ...) ((alet-cat* z (a . e) bd ...)
(let ((y z)) (let ((y z))
(%alet-cat* y (a . e) bd ...))))) (%alet-cat* y (a . e) bd ...)))))
;; (define-syntax %alet-cat* ;; (define-syntax %alet-cat*
;; (syntax-rules () ;; (syntax-rules ()
;; ((%alet-cat* z ((n d t ...)) bd ...) ;; ((%alet-cat* z ((n d t ...)) bd ...)
;; (let ((n (if (null? z) ;; (let ((n (if (null? z)
;; d ;; d
;; (if (null? (cdr z)) ;; (if (null? (cdr z))
;; (wow-cat-end z n t ...) ;; (wow-cat-end z n t ...)
;; (error "alet*: too many arguments" (cdr z)))))) ;; (error "alet*: too many arguments" (cdr z))))))
;; bd ...)) ;; bd ...))
;; ((%alet-cat* z ((n d t ...) . e) bd ...) ;; ((%alet-cat* z ((n d t ...) . e) bd ...)
;; (let* ((w (if (null? z) ;; (let* ((w (if (null? z)
;; (cons d z) ;; (cons d z)
;; (wow-cat z n d t ...))) ;; (wow-cat z n d t ...)))
;; (n (car w)) ;; (n (car w))
;; (y (cdr w))) ;; (y (cdr w)))
;; (%alet-cat* y e bd ...))) ;; (%alet-cat* y e bd ...)))
;; ((%alet-cat* z e bd ...) ;; ((%alet-cat* z e bd ...)
;; (let ((e z)) bd ...)))) ;; (let ((e z)) bd ...))))
(define-syntax %alet-cat* (define-syntax %alet-cat*
(syntax-rules () (syntax-rules ()
((%alet-cat* z ((n d t ...)) bd ...) ((%alet-cat* z ((n d t ...)) bd ...)
(let ((n (if (null? z) (let ((n (if (null? z)
@ -1083,37 +1084,37 @@
(%alet-cat* z e bd ...))) (%alet-cat* z e bd ...)))
((%alet-cat* z e bd ...) ((%alet-cat* z e bd ...)
(let ((e z)) bd ...)))) (let ((e z)) bd ...))))
;; (define-syntax %alet-cat* ;; (define-syntax %alet-cat*
;; (syntax-rules () ;; (syntax-rules ()
;; ((%alet-cat* z (ndt ...) (a . e) bd ...) ;; ((%alet-cat* z (ndt ...) (a . e) bd ...)
;; (%alet-cat* z (ndt ... a) e bd ...)) ;; (%alet-cat* z (ndt ... a) e bd ...))
;; ((%alet-cat* z ((n d t ...) (nn dd tt ...) ...) () bd ...) ;; ((%alet-cat* z ((n d t ...) (nn dd tt ...) ...) () bd ...)
;; (if (null? z) ;; (if (null? z)
;; (let* ((n d) (nn dd) ...) bd ...) ;; (let* ((n d) (nn dd) ...) bd ...)
;; (let* ((w (wow-cat z n d t ...)) ;; (let* ((w (wow-cat z n d t ...))
;; (n (car w)) ;; (n (car w))
;; (y (cdr w))) ;; (y (cdr w)))
;; (%alet-cat* y ((nn dd tt ...) ...) () bd ...)))) ;; (%alet-cat* y ((nn dd tt ...) ...) () bd ...))))
;; ((%alet-cat* z () () bd ...) ;; ((%alet-cat* z () () bd ...)
;; (if (null? z) ;; (if (null? z)
;; (let () bd ...) ;; (let () bd ...)
;; (error "alet*: too many arguments" z))) ;; (error "alet*: too many arguments" z)))
;; ((%alet-cat* z ((n d t ...) (nn dd tt ...) ...) e bd ...) ;; ((%alet-cat* z ((n d t ...) (nn dd tt ...) ...) e bd ...)
;; (if (null? z) ;; (if (null? z)
;; (let* ((n d) (nn dd) ... (e z)) bd ...) ;; (let* ((n d) (nn dd) ... (e z)) bd ...)
;; (let* ((w (wow-cat z n d t ...)) ;; (let* ((w (wow-cat z n d t ...))
;; (n (car w)) ;; (n (car w))
;; (y (cdr w))) ;; (y (cdr w)))
;; (%alet-cat* y ((nn dd tt ...) ...) e bd ...)))) ;; (%alet-cat* y ((nn dd tt ...) ...) e bd ...))))
;; ((%alet-cat* z () e bd ...) ;; ((%alet-cat* z () e bd ...)
;; (let ((e z)) bd ...)))) ;; (let ((e z)) bd ...))))
(define-syntax alet-key* (define-syntax alet-key*
(syntax-rules () (syntax-rules ()
((alet-key* z (a . e) bd ...) ((alet-key* z (a . e) bd ...)
(let ((y z)) (let ((y z))
(%alet-key* y () () (a . e) () bd ...))))) (%alet-key* y () () (a . e) () bd ...)))))
(define-syntax %alet-key* (define-syntax %alet-key*
(syntax-rules () (syntax-rules ()
((%alet-key* z () (ndt ...) (((n k) d t ...) . e) (kk ...) bd ...) ((%alet-key* z () (ndt ...) (((n k) d t ...) . e) (kk ...) bd ...)
(%alet-key* z () (ndt ... ((n k) d t ...)) e (kk ... k) bd ...)) (%alet-key* z () (ndt ... ((n k) d t ...)) e (kk ... k) bd ...))
@ -1135,4 +1136,3 @@
(error "alet*: too many arguments" z))) (error "alet*: too many arguments" z)))
((%alet-key* z (o ...) () e (kk ...) bd ...) ((%alet-key* z (o ...) () e (kk ...) bd ...)
(let ((e z)) bd ...)))) (let ((e z)) bd ...))))
)

5
collects/srfi/87.ss
View File

@ -1,3 +1,2 @@
(module |87| mzscheme ;; module loader for SRFI-87
(require srfi/87/case) #lang s-exp srfi/provider srfi/87/case #:unprefix srfi:
(provide (rename srfi:case case)))

4
collects/srfi/9.ss
View File

@ -1,4 +1,2 @@
;; module loader for SRFI-9 ;; module loader for SRFI-9
(module |9| mzscheme #lang s-exp srfi/provider srfi/9/record
(require srfi/9/record)
(provide (all-from srfi/9/record)))

36
collects/srfi/features.ss
View File

@ -1,30 +1,28 @@
(module features mzscheme #lang scheme/base
(provide feature-present?
feature->require-clause)
(define *feature-alist* (provide feature-present? feature->require-clause)
(define *feature-alist*
'()) '())
(define (srfi-id? id) (define (srfi-id? id)
(let ((string-id (symbol->string id))) (regexp-match? #rx"^srfi-[0-9]+$" (symbol->string id)))
(and (> (string-length string-id) 5)
(string=? "srfi-"
(substring string-id 0 5)))))
(define (srfi-id->filename srfi-id) (define (srfi-id->filename srfi-id)
(let ((string-id (symbol->string srfi-id))) (regexp-replace #rx"^srfi-([0-9]+)$" (symbol->string srfi-id) "\\1/\\1.ss"))
(string-append (substring string-id 5 (string-length string-id))
".ss")))
(define (srfi-id-present? srfi-id) (define (srfi-id-present? srfi-id)
(file-exists? (build-path (collection-path "srfi") (file-exists? (build-path (collection-path "srfi")
(srfi-id->filename srfi-id)))) (srfi-id->filename srfi-id))))
(define (feature-present? id) (define (feature-present? id)
(or (and (srfi-id? id) (srfi-id-present? id)) (or (and (srfi-id? id) (srfi-id-present? id))
(and (assq id *feature-alist*) #t))) (and (assq id *feature-alist*) #t)))
(define (feature->require-clause id) (define (feature->require-clause id)
(if (and (srfi-id? id) (srfi-id-present? id)) (cond [(and (srfi-id? id) (srfi-id-present? id))
(cons 'lib (list (srfi-id->filename id) "srfi")) (string->symbol (regexp-replace #rx"^srfi-([0-9]+)$"
(cdr (assq id *feature-alist*))))) (symbol->string id)
"srfi/\\1/\\1"))]
[(assq id *feature-alist*) => cdr]
[else (error 'feature->require-clause "unknown feature: ~e" id)]))

15
collects/srfi/optional.ss
View File

@ -45,18 +45,17 @@
;; macros. :-) ;; macros. :-)
;; ;;
#lang mzscheme #lang scheme/base
(provide :optional
let-optionals* (require (for-syntax scheme/base))
check-arg
) (provide :optional let-optionals* check-arg)
;; (function (check-arg predicate value caller)) ;; (function (check-arg predicate value caller))
;; ;;
;; ;;
;; Checks parameter values. ;; Checks parameter values.
(define check-arg (define (check-arg pred val caller)
(lambda (pred val caller)
(if (not (pred val)) (if (not (pred val))
(let ([expected-string (let ([expected-string
(cond [(eq? pred number? ) "expected number, "] (cond [(eq? pred number? ) "expected number, "]
@ -67,7 +66,7 @@
[(eq? pred vector?) "expected vector, "] [(eq? pred vector?) "expected vector, "]
[else ""])]) [else ""])])
(error caller (string-append expected-string "given ~s") val)) (error caller (string-append expected-string "given ~s") val))
val))) val))

53
collects/srfi/provider.ss Normal file
View File

@ -0,0 +1,53 @@
#lang scheme/base
(require (for-syntax scheme/base scheme/provide-transform))
;; This is a utility for many srfi/N.ss files that simply reprovide stuff from
;; some other file. It is used as a module, for example, the "srfi/1.ss"
;; loader has:
;; #lang s-exp srfi/provider srfi/1/list #:unprefix s:
;; which makes it require `srfi/1/list', then reprovide everything from there,
;; removing any `s:' prefixes that it uses (since `srfi/1/list' does not
;; collide with `scheme/base'). It is used in most files here, and the
;; unprefix facility is used in a few similar situations. You can add a
;; `#:debug' flag to have the unprefixer print its renamings, to check that you
;; get the right bindings.
(provide (rename-out [module-begin #%module-begin]))
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ srfi-req . more)
(let ([pfx #f] [debug #f])
(let loop ([more #'more])
(syntax-case more ()
[(#:unprefix pfx-id . more) (set! pfx #'pfx-id) (loop #'more)]
[(#:debug . more) (set! debug #t) (loop #'more)]
[() (void)]))
#`(#%module-begin
(require srfi-req)
(provide (all-from-unprefix-out #,pfx srfi-req #,debug))))]))
(define-syntax all-from-unprefix-out
(make-provide-transformer
(lambda (stx modes)
(syntax-case stx ()
[(_ pfx spec debug?)
(map (if (identifier? #'pfx)
(let ([rx (string-append
"^"
(regexp-quote (symbol->string (syntax-e #'pfx))))]
[debug? (syntax-e #'debug?)])
(lambda (e)
(let* ([s (symbol->string (export-out-sym e))]
[m (regexp-match-positions rx s)])
(when (and m debug?)
(printf "Renaming: ~a -> ~a\n" s (substring s (cdar m))))
(if m
(make-export (export-local-id e)
(string->symbol (substring s (cdar m)))
(export-mode e)
(export-protect? e)
(export-orig-stx e))
e))))
values)
(expand-export #'(all-from-out spec) modes))]))))