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 |1| mzscheme
(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)))
#lang s-exp srfi/provider srfi/1/list #:unprefix s:

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

@ -36,7 +36,8 @@
(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!])
(rename-out [my-remove remove] [my-remove remove!]))
@ -45,6 +46,13 @@
;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
;; 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
;; elements. If Scheme had multi-continuation calls, they could be
;; made more efficient.

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

@ -220,7 +220,7 @@
"misc.ss"
(rename-in "fold.ss" [map s:map] [for-each s:for-each])
(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"
(rename-in "alist.ss" [assoc s:assoc])
"lset.ss")
@ -231,8 +231,7 @@
(all-from-out "misc.ss")
(all-from-out "fold.ss")
(all-from-out "search.ss")
(except-out (all-from-out "filter.ss") s:filter)
(rename-out [s:filter filter])
(all-from-out "filter.ss")
(all-from-out "delete.ss")
(all-from-out "alist.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)
"delete.ss"
"predicate.ss"
(except-in "filter.ss" remove filter))
(only-in "filter.ss" [filter-with-sharing s:filter] partition))
(provide lset<=
lset=

4
collects/srfi/11.ss
View File

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

10
collects/srfi/13.ss
View File

@ -1,10 +1,2 @@
;; module loader for SRFI-13
(module |13| mzscheme
(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)))
#lang s-exp srfi/provider srfi/13/string #:unprefix s:

4
collects/srfi/14.ss
View File

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

4
collects/srfi/16.ss
View File

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

6
collects/srfi/17.ss
View File

@ -1,6 +1,2 @@
;; module loader for SRFI-17
(module |17| mzscheme
(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!)))
#lang s-exp srfi/provider srfi/17/set #:unprefix s:

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

@ -7,8 +7,8 @@
;;;
;;; Based on the implementation for Scheme48.
(module set mzscheme
(provide (rename my-set! set!)
#lang scheme/base
(provide (rename-out [my-set! s:set!])
setter
set-setter!
getter-with-setter)
@ -93,4 +93,3 @@
(cons cddddr (cdr-setter cdddr))
|#
))
)

3
collects/srfi/18.ss
View File

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

23
collects/srfi/19.ss
View File

@ -1,23 +1,2 @@
;; module loader for SRFI-19
(module |19| mzscheme
(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)))
#lang s-exp srfi/provider srfi/19/time #:unprefix srfi:

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

@ -97,33 +97,33 @@
(test-case
"TAI-Date Conversions"
(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)
(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)
(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)
(make-srfi:date 0 0 0 0 1 1 1999 0)))
(srfi:make-date 0 0 0 0 1 1 1999 0)))
(test-case
"Date-UTC Conversions"
(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))
(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.
(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))
(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))
(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
"TZ Offset conversions"
(let ((ct-utc (make-time time-utc 6320000 1045944859))
(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-tai (date->time-tai cd))))
@ -132,7 +132,7 @@
;; to change the test case to match the implementation...
(test-case
"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")
"~ @ 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
"[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 (make-srfi: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 (make-srfi: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 (make-srfi: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 (make-srfi: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 123456789 2 3 4 5 6 2007 0) "~N") "123456789")
(check-equal? (date->string (srfi:make-date 12345678 2 3 4 5 6 2007 0) "~N") "012345678")
(check-equal? (date->string (srfi:make-date 1234567 2 3 4 5 6 2007 0) "~N") "001234567")
(check-equal? (date->string (srfi:make-date 123456 2 3 4 5 6 2007 0) "~N") "000123456")
(check-equal? (date->string (srfi:make-date 12345 2 3 4 5 6 2007 0) "~N") "000012345")
(check-equal? (date->string (srfi:make-date 1234 2 3 4 5 6 2007 0) "~N") "000001234")
(check-equal? (date->string (srfi:make-date 123 2 3 4 5 6 2007 0) "~N") "000000123")
(check-equal? (date->string (srfi:make-date 12 2 3 4 5 6 2007 0) "~N") "000000012")
(check-equal? (date->string (srfi:make-date 1 2 3 4 5 6 2007 0) "~N") "000000001"))
(test-case
"[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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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.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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (srfi:make-date 1 0 0 12 #t #t #t 0) "check 18"))
(test-case
"date<->julian-day conversion"
(check = 365 (- (date->julian-day (make-srfi:date 0 0 0 0 1 1 2004 0))
(date->julian-day (make-srfi:date 0 0 0 0 1 1 2003 0))))
(let ([test-date (make-srfi:date 0 0 0 0 1 1 2003 -7200)])
(check = 365 (- (date->julian-day (srfi:make-date 0 0 0 0 1 1 2004 0))
(date->julian-day (srfi:make-date 0 0 0 0 1 1 2003 0))))
(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))))
(test-case
"date->modified-julian-day conversion"
(check = 365 (- (date->modified-julian-day (make-srfi:date 0 0 0 0 1 1 2004 0))
(date->modified-julian-day (make-srfi:date 0 0 0 0 1 1 2003 0))))
(let ([test-date (make-srfi:date 0 0 0 0 1 1 2003 -7200)])
(check = 365 (- (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2004 0))
(date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2003 0))))
(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))))
))

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

@ -74,7 +74,7 @@
time-difference time-difference! add-duration add-duration! subtract-duration subtract-duration!
;; Date object and accessors
;; 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
srfi:date-year date-zone-offset
;; This are not part of the date structure (as they are in the original PLT Scheme's date)
@ -582,7 +582,7 @@
time-in)
;; -- 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
'tm:date #f 8 0 #f null (make-inspector) #f null))
;; PLT Scheme date structure has the following:
@ -702,7 +702,7 @@
(rem (remainder secs (* 60 60)))
(minutes (quotient rem 60))
(seconds (remainder rem 60)) )
(make-srfi:date (time-nanosecond time)
(srfi:make-date (time-nanosecond time)
seconds
minutes
hours
@ -794,7 +794,7 @@
(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)
(let* ( (first-day (make-srfi:date 0 0 0 0
(let* ( (first-day (srfi:make-date 0 0 0 0
1
1
(srfi:date-year date)
@ -1480,7 +1480,7 @@
(srfi:date-month date)
(srfi:date-year 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
0
template-string

4
collects/srfi/2.ss
View File

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

4
collects/srfi/23.ss
View File

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

4
collects/srfi/25.ss
View File

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

5
collects/srfi/26.ss
View File

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

5
collects/srfi/27.ss
View File

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

4
collects/srfi/28.ss
View File

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

4
collects/srfi/29.ss
View File

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

4
collects/srfi/30.ss
View File

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

6
collects/srfi/31.ss
View File

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

5
collects/srfi/32.ss
View File

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

4
collects/srfi/34.ss
View File

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

4
collects/srfi/35.ss
View File

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

6
collects/srfi/38.ss
View File

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

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:
(module |39| mzscheme
(provide make-parameter parameterize))
#lang scheme/base
(provide make-parameter parameterize)

4
collects/srfi/40.ss
View File

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

4
collects/srfi/42.ss
View File

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

8
collects/srfi/43.ss
View File

@ -1,8 +1,2 @@
;; module loader for SRFI-43
(module |43| mzscheme
(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)))
#lang s-exp srfi/provider srfi/43/vector-lib #:unprefix s:

10
collects/srfi/45.ss
View File

@ -1,10 +1,2 @@
;; module loader for SRFI-45
(module |45| mzscheme
(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?)))
#lang s-exp srfi/provider srfi/45/lazy

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

@ -1,38 +1,12 @@
; SRFI 45
; Zhu Chongkai mrmathematica@yahoo.com
; 25-May-2005
(module lazy mzscheme
#lang scheme/base
(provide lazy
eager
s:delay
s:force
srfi-45-promise?)
;; scheme/promise has srfi-45-style primitives
(require scheme/promise)
(provide (all-from-out scheme/promise))
(define-struct srfi-45-promise (content))
(define-syntax lazy
(syntax-rules ()
((_ exp)
(make-srfi-45-promise (mcons #f (lambda () exp))))))
(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))))
;; 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
;; "library approach" in scheme/promise and see the post-finalization
;; discussion on the srfi-45 list. I (Eli) showed at some point how the
;; "language approach" primitives can be used to implement the other, and this
;; needs to be done here too.

4
collects/srfi/48.ss
View File

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

4
collects/srfi/5.ss
View File

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

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

@ -10,28 +10,29 @@
;;; Copyright (C) Andy Gaynor (1999-2003)
;;;
;;; 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
(provide (rename my-let let))
#lang scheme/base
(provide s:let)
(define-syntax my-let
(define-syntax s:let
(syntax-rules ()
;; standard
((my-let () body ...)
((s:let () body ...)
(let () body ...))
((my-let ((var val) ...) body ...)
((s:let ((var val) ...) body ...)
(let ((var val) ...) body ...))
;; rest style
((my-let ((var val) . bindings) body ...)
((s:let ((var val) . bindings) body ...)
(let-loop #f bindings (var) (val) (body ...)))
;; signature style
((my-let (name bindings ...) body ...)
((s:let (name bindings ...) body ...)
(let-loop name (bindings ...) () () (body ...)))
;; standard named style
((my-let name (bindings ...) body ...)
((s:let name (bindings ...) body ...)
(let-loop name (bindings ...) () () (body ...)))
))
@ -41,46 +42,45 @@
(define-syntax let-loop
(syntax-rules ()
; No more bindings - make a LETREC.
;; No more bindings - make a LETREC.
((let-loop name () (vars ...) (vals ...) body)
((letrec ((name (lambda (vars ...) . body)))
name)
vals ...))
; Rest binding, no name
;; Rest binding, no name
((let-loop #f (rest-var rest-val ...) (var ...) (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 (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)
((letrec ((name (lambda (vars ... . rest-var) . body)))
name)
vals ... rest-vals ...))))
; Four loops - normal and `signature-style', each with and without a rest
; binding.
;
;(let fibonacci ((n 10) (i 0) (f0 0) (f1 1))
; (if (= i n)
; f0
; (fibonacci n (+ i 1) f1 (+ f0 f1))))
;
;(let (fibonacci (n 10) (i 0) (f0 0) (f1 1))
; (if (= i n)
; f0
; (fibonacci n (+ i 1) f1 (+ f0 f1))))
;
;(let fibonacci ((n 10) (i 0) . (f 0 1))
; (if (= i n)
; (car f)
; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f)))))
;
;(let (fibonacci (n 10) (i 0) . (f 0 1))
; (if (= i n)
; (car f)
; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f)))))
)
;; Four loops - normal and `signature-style', each with and without a rest
;; binding.
;;
;;(let fibonacci ((n 10) (i 0) (f0 0) (f1 1))
;; (if (= i n)
;; f0
;; (fibonacci n (+ i 1) f1 (+ f0 f1))))
;;
;;(let (fibonacci (n 10) (i 0) (f0 0) (f1 1))
;; (if (= i n)
;; f0
;; (fibonacci n (+ i 1) f1 (+ f0 f1))))
;;
;;(let fibonacci ((n 10) (i 0) . (f 0 1))
;; (if (= i n)
;; (car f)
;; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f)))))
;;
;;(let (fibonacci (n 10) (i 0) . (f 0 1))
;; (if (= i n)
;; (car 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 |54| mzscheme
(require srfi/54/cat)
(provide (all-from srfi/54/cat)))
#lang s-exp srfi/provider srfi/54/cat

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

@ -1,9 +1,12 @@
;; based on soo's (the author of the SRFI) R6RS implemenations
(module cat mzscheme
#lang scheme/base
(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)
(let ((left (car take)))
@ -946,4 +949,3 @@
(if port
(display str port)
str)))))
)

4
collects/srfi/57.ss
View File

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

4
collects/srfi/59.ss
View File

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

4
collects/srfi/6.ss
View File

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

6
collects/srfi/60.ss
View File

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

4
collects/srfi/61.ss
View File

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

6
collects/srfi/63.ss
View File

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

4
collects/srfi/64.ss
View File

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

5
collects/srfi/67.ss
View File

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

10
collects/srfi/69.ss
View File

@ -1,10 +1,2 @@
;; module loader for SRFI-69
(module |69| mzscheme
(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)))
#lang s-exp srfi/provider srfi/69/hash #:unprefix s:

4
collects/srfi/7.ss
View File

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

14
collects/srfi/71.ss
View File

@ -1,14 +1,2 @@
;; module loader for SRFI-71
(module |71| mzscheme
(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*)))
#lang s-exp srfi/provider srfi/71/letvalues #:unprefix srfi-

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

@ -1,9 +1,7 @@
; Reference implementation of SRFI-71 using PLT 208's modules
; Sebastian.Egner@philips.com, 29-Apr-2005
(module letvalues mzscheme
(provide (all-from mzscheme))
#lang scheme/base
(provide srfi-let
srfi-let*
@ -228,5 +226,3 @@
(call-with-values (lambda () x) vector))))
; --- textual copy of 'letvalues.scm' ends here ---
) ; module letvalues

5
collects/srfi/74.ss
View File

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

5
collects/srfi/78.ss
View File

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

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

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

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

@ -1,4 +1,4 @@
(module check mzscheme
#lang scheme/base
(require mzlib/include
srfi/23
srfi/42
@ -11,4 +11,4 @@
check-report
check-set-mode!
check-reset!
check-passed?))
check-passed?)

4
collects/srfi/8.ss
View File

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

6
collects/srfi/86.ss
View File

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

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

@ -1,9 +1,6 @@
(module |86| mzscheme
#lang mzscheme
(provide (all-from mzscheme))
(provide mu nu
alet alet*)
(provide mu nu alet alet*)
;;; mu & nu
(define-syntax mu
@ -51,7 +48,8 @@
(bn ...) bd ...))
((%alet "dot" (p ...) (nv ...) (values t ...) (() c) (bn ...) bd ...)
(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 ...)
((lambda (t ...) (%alet (p ...) (nv ...) (bn ...) bd ...)) c ...))
((%alet "dot" (p ...) (nv ...) (values t ...) (b c) (bn ...) bd ...)
@ -184,7 +182,8 @@
(bn ...) bd ...))
((%alet "not" (p ...) (nv ...) (values t ...) (z) (bn ...) bd ...)
(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 "not" (p ...) (nv ... (a t)) (t) (b c ...) (bn ...) bd ...))
@ -305,10 +304,12 @@
(%alet* "one" (p ...) (n ... a) (values r ... a) (b c) (bn ...) bd ...))
((%alet* "one" (p ...) (n ...) (values r ...) (() c) (bn ...) bd ...)
(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 ...)
(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* "dot" (p ...) (n ...) (b c d ...) (bn ...) bd ...))
@ -1135,4 +1136,3 @@
(error "alet*: too many arguments" z)))
((%alet-key* z (o ...) () e (kk ...) bd ...)
(let ((e z)) bd ...))))
)

5
collects/srfi/87.ss
View File

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

4
collects/srfi/9.ss
View File

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

24
collects/srfi/features.ss
View File

@ -1,20 +1,15 @@
(module features mzscheme
(provide feature-present?
feature->require-clause)
#lang scheme/base
(provide feature-present? feature->require-clause)
(define *feature-alist*
'())
(define (srfi-id? id)
(let ((string-id (symbol->string id)))
(and (> (string-length string-id) 5)
(string=? "srfi-"
(substring string-id 0 5)))))
(regexp-match? #rx"^srfi-[0-9]+$" (symbol->string id)))
(define (srfi-id->filename srfi-id)
(let ((string-id (symbol->string srfi-id)))
(string-append (substring string-id 5 (string-length string-id))
".ss")))
(regexp-replace #rx"^srfi-([0-9]+)$" (symbol->string srfi-id) "\\1/\\1.ss"))
(define (srfi-id-present? srfi-id)
(file-exists? (build-path (collection-path "srfi")
@ -25,6 +20,9 @@
(and (assq id *feature-alist*) #t)))
(define (feature->require-clause id)
(if (and (srfi-id? id) (srfi-id-present? id))
(cons 'lib (list (srfi-id->filename id) "srfi"))
(cdr (assq id *feature-alist*)))))
(cond [(and (srfi-id? id) (srfi-id-present? id))
(string->symbol (regexp-replace #rx"^srfi-([0-9]+)$"
(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. :-)
;;
#lang mzscheme
(provide :optional
let-optionals*
check-arg
)
#lang scheme/base
(require (for-syntax scheme/base))
(provide :optional let-optionals* check-arg)
;; (function (check-arg predicate value caller))
;;
;;
;; Checks parameter values.
(define check-arg
(lambda (pred val caller)
(define (check-arg pred val caller)
(if (not (pred val))
(let ([expected-string
(cond [(eq? pred number? ) "expected number, "]
@ -67,7 +66,7 @@
[(eq? pred vector?) "expected vector, "]
[else ""])])
(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))]))))