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:

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

@ -7,90 +7,89 @@
;;;
;;; Based on the implementation for Scheme48.
(module set mzscheme
(provide (rename my-set! set!)
setter
set-setter!
getter-with-setter)
#lang scheme/base
(provide (rename-out [my-set! s:set!])
setter
set-setter!
getter-with-setter)
(define-syntax my-set!
(syntax-rules ()
((my-set! (?e0 ?e1 ...) ?v)
((setter ?e0) ?e1 ... ?v))
((my-set! ?i ?v)
(set! ?i ?v))))
(define-syntax my-set!
(syntax-rules ()
((my-set! (?e0 ?e1 ...) ?v)
((setter ?e0) ?e1 ... ?v))
((my-set! ?i ?v)
(set! ?i ?v))))
(define (getter-with-setter get set)
(let ((proc (lambda args (apply get args))))
(set-setter! proc set)
proc))
(define (getter-with-setter get set)
(let ((proc (lambda args (apply get args))))
(set-setter! proc set)
proc))
(define (setter proc)
(let ((probe (assv proc setters)))
(if probe
(cdr probe)
(error (object-name proc) "No setter found"))))
(define (setter proc)
(let ((probe (assv proc setters)))
(if probe
(cdr probe)
(error (object-name proc) "No setter found"))))
(define (set-setter! proc setter)
(set! setters
(let loop ([setters setters])
(cond
[(null? setters)
(list (cons proc setter))]
[(eqv? proc (caar setters))
(cons (cons proc setter)
(cdr setters))]
[else (cons (car setters)
(loop (cdr setters)))]))))
(define (set-setter! proc setter)
(set! setters
(let loop ([setters setters])
(cond
[(null? setters)
(list (cons proc setter))]
[(eqv? proc (caar setters))
(cons (cons proc setter)
(cdr setters))]
[else (cons (car setters)
(loop (cdr setters)))]))))
#|
(define (car-setter proc)
(lambda (p v)
(set-car! (proc p) v)))
(define (car-setter proc)
(lambda (p v)
(set-car! (proc p) v)))
(define (cdr-setter proc)
(lambda (p v)
(set-cdr! (proc p) v)))
(define (cdr-setter proc)
(lambda (p v)
(set-cdr! (proc p) v)))
|#
(define setters
(list (cons setter set-setter!)
(cons vector-ref vector-set!)
(cons string-ref string-set!)
(define setters
(list (cons setter set-setter!)
(cons vector-ref vector-set!)
(cons string-ref string-set!)
#|
(cons car set-car!)
(cons cdr set-cdr!)
(cons car set-car!)
(cons cdr set-cdr!)
(cons caar (car-setter car))
(cons cdar (cdr-setter car))
(cons cadr (car-setter cdr))
(cons cddr (cdr-setter cdr))
(cons caar (car-setter car))
(cons cdar (cdr-setter car))
(cons cadr (car-setter cdr))
(cons cddr (cdr-setter cdr))
(cons caaar (car-setter caar))
(cons cdaar (cdr-setter caar))
(cons cadar (car-setter cdar))
(cons cddar (cdr-setter cdar))
(cons caadr (car-setter cadr))
(cons cdadr (cdr-setter cadr))
(cons caddr (car-setter cddr))
(cons cdddr (cdr-setter cddr))
(cons caaar (car-setter caar))
(cons cdaar (cdr-setter caar))
(cons cadar (car-setter cdar))
(cons cddar (cdr-setter cdar))
(cons caadr (car-setter cadr))
(cons cdadr (cdr-setter cadr))
(cons caddr (car-setter cddr))
(cons cdddr (cdr-setter cddr))
(cons caaaar (car-setter caaar))
(cons cdaaar (cdr-setter caaar))
(cons cadaar (car-setter cdaar))
(cons cddaar (cdr-setter cdaar))
(cons caadar (car-setter cadar))
(cons cdadar (cdr-setter cadar))
(cons caddar (car-setter cddar))
(cons cdddar (cdr-setter cddar))
(cons caaadr (car-setter caadr))
(cons cdaadr (cdr-setter caadr))
(cons cadadr (car-setter cdadr))
(cons cddadr (cdr-setter cdadr))
(cons caaddr (car-setter caddr))
(cons cdaddr (cdr-setter caddr))
(cons cadddr (car-setter cdddr))
(cons cddddr (cdr-setter cdddr))
(cons caaaar (car-setter caaar))
(cons cdaaar (cdr-setter caaar))
(cons cadaar (car-setter cdaar))
(cons cddaar (cdr-setter cdaar))
(cons caadar (car-setter cadar))
(cons cdadar (cdr-setter cadar))
(cons caddar (car-setter cddar))
(cons cdddar (cdr-setter cddar))
(cons caaadr (car-setter caadr))
(cons cdaadr (cdr-setter caadr))
(cons cadadr (car-setter cdadr))
(cons cddadr (cdr-setter cdadr))
(cons caaddr (car-setter caddr))
(cons cdaddr (cdr-setter caddr))
(cons cadddr (car-setter cdddr))
(cons cddddr (cdr-setter cdddr))
|#
))
)
))

5
collects/srfi/18.ss
View File

@ -1,4 +1,3 @@
;; Supported by core PLT:
(module |18| mzscheme
(provide thread)
)
#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:

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

@ -10,77 +10,77 @@
;;; 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
(syntax-rules ()
;; standard
((my-let () body ...)
(let () body ...))
((my-let ((var val) ...) body ...)
(let ((var val) ...) body ...))
(define-syntax s:let
(syntax-rules ()
;; standard
((s:let () body ...)
(let () body ...))
((s:let ((var val) ...) body ...)
(let ((var val) ...) body ...))
;; rest style
((my-let ((var val) . bindings) body ...)
(let-loop #f bindings (var) (val) (body ...)))
;; rest style
((s:let ((var val) . bindings) body ...)
(let-loop #f bindings (var) (val) (body ...)))
;; signature style
((my-let (name bindings ...) body ...)
(let-loop name (bindings ...) () () (body ...)))
;; signature style
((s:let (name bindings ...) body ...)
(let-loop name (bindings ...) () () (body ...)))
;; standard named style
((my-let name (bindings ...) body ...)
(let-loop name (bindings ...) () () (body ...)))
;; standard named style
((s:let 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
(syntax-rules ()
(define-syntax let-loop
(syntax-rules ()
; No more bindings - make a LETREC.
((let-loop name () (vars ...) (vals ...) body)
((letrec ((name (lambda (vars ...) . body)))
name)
vals ...))
; 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.
((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.
((let-loop name (rest-var rest-vals ...) (vars ...) (vals ...) body)
((letrec ((name (lambda (vars ... . rest-var) . body)))
;; No more bindings - make a LETREC.
((let-loop name () (vars ...) (vals ...) body)
((letrec ((name (lambda (vars ...) . body)))
name)
vals ... rest-vals ...))))
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)))))
)
;; 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.
((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.
((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)))))

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

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

File diff suppressed because it is too large Load Diff

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-

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

@ -1,232 +1,228 @@
; Reference implementation of SRFI-71 using PLT 208's modules
; Sebastian.Egner@philips.com, 29-Apr-2005
(module letvalues mzscheme
#lang scheme/base
(provide (all-from mzscheme))
(provide srfi-let
srfi-let*
srfi-letrec
srfi-letrec*
uncons unlist unvector
values->list values->vector
uncons-2 uncons-3 uncons-4
uncons-cons)
(provide srfi-let
srfi-let*
srfi-letrec
srfi-letrec*
uncons unlist unvector
values->list values->vector
uncons-2 uncons-3 uncons-4
uncons-cons)
; --- textual copy of 'letvalues.scm' starts here ---
; --- textual copy of 'letvalues.scm' starts here ---
; Reference implementation of SRFI-71 (generic part)
; Sebastian.Egner@philips.com, 20-May-2005, PLT 208
;
; In order to avoid conflicts with the existing let etc.
; the macros defined here are called srfi-let etc.,
; and they are defined in terms of r5rs-let etc.
; It is up to the actual implementation to save let/*/rec
; in r5rs-let/*/rec first and redefine let/*/rec
; by srfi-let/*/rec then.
;
; There is also a srfi-letrec* being defined (in view of R6RS.)
;
; Macros used internally are named i:<something>.
;
; Abbreviations for macro arguments:
; bs - <binding spec>
; b - component of a binding spec (values, <variable>, or <expression>)
; v - <variable>
; vr - <variable> for rest list
; x - <expression>
; t - newly introduced temporary variable
; vx - (<variable> <expression>)
; rec - flag if letrec is produced (and not let)
; cwv - call-with-value skeleton of the form (x formals)
; (call-with-values (lambda () x) (lambda formals /payload/))
; where /payload/ is of the form (let (vx ...) body1 body ...).
;
; Remark (*):
; 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
; raises an error when read uninitialized.
; Reference implementation of SRFI-71 (generic part)
; Sebastian.Egner@philips.com, 20-May-2005, PLT 208
;
; In order to avoid conflicts with the existing let etc.
; the macros defined here are called srfi-let etc.,
; and they are defined in terms of r5rs-let etc.
; It is up to the actual implementation to save let/*/rec
; in r5rs-let/*/rec first and redefine let/*/rec
; by srfi-let/*/rec then.
;
; There is also a srfi-letrec* being defined (in view of R6RS.)
;
; Macros used internally are named i:<something>.
;
; Abbreviations for macro arguments:
; bs - <binding spec>
; b - component of a binding spec (values, <variable>, or <expression>)
; v - <variable>
; vr - <variable> for rest list
; x - <expression>
; t - newly introduced temporary variable
; vx - (<variable> <expression>)
; rec - flag if letrec is produced (and not let)
; cwv - call-with-value skeleton of the form (x formals)
; (call-with-values (lambda () x) (lambda formals /payload/))
; where /payload/ is of the form (let (vx ...) body1 body ...).
;
; Remark (*):
; 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
; raises an error when read uninitialized.
(define i:undefined 'undefined)
(define i:undefined 'undefined)
(define-syntax srfi-letrec* ; -> srfi-letrec
(syntax-rules ()
((srfi-letrec* () body1 body ...)
(srfi-letrec () body1 body ...))
((srfi-letrec* (bs) body1 body ...)
(srfi-letrec (bs) body1 body ...))
((srfi-letrec* (bs1 bs2 bs ...) body1 body ...)
(srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...)))))
(define-syntax srfi-letrec* ; -> srfi-letrec
(syntax-rules ()
((srfi-letrec* () body1 body ...)
(srfi-letrec () body1 body ...))
((srfi-letrec* (bs) body1 body ...)
(srfi-letrec (bs) body1 body ...))
((srfi-letrec* (bs1 bs2 bs ...) body1 body ...)
(srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...)))))
(define-syntax srfi-letrec ; -> i:let
(syntax-rules ()
((srfi-letrec ((b1 b2 b ...) ...) body1 body ...)
(i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...)))))
(define-syntax srfi-letrec ; -> i:let
(syntax-rules ()
((srfi-letrec ((b1 b2 b ...) ...) body1 body ...)
(i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...)))))
(define-syntax srfi-let* ; -> srfi-let
(syntax-rules ()
((srfi-let* () body1 body ...)
(srfi-let () body1 body ...))
((srfi-let* (bs) body1 body ...)
(srfi-let (bs) body1 body ...))
((srfi-let* (bs1 bs2 bs ...) body1 body ...)
(srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...)))))
(define-syntax srfi-let* ; -> srfi-let
(syntax-rules ()
((srfi-let* () body1 body ...)
(srfi-let () body1 body ...))
((srfi-let* (bs) body1 body ...)
(srfi-let (bs) body1 body ...))
((srfi-let* (bs1 bs2 bs ...) body1 body ...)
(srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...)))))
(define-syntax srfi-let ; -> i:let or i:named-let
(syntax-rules ()
((srfi-let ((b1 b2 b ...) ...) body1 body ...)
(i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...)))
((srfi-let tag ((b1 b2 b ...) ...) body1 body ...)
(i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...)))))
(define-syntax srfi-let ; -> i:let or i:named-let
(syntax-rules ()
((srfi-let ((b1 b2 b ...) ...) body1 body ...)
(i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...)))
((srfi-let tag ((b1 b2 b ...) ...) body1 body ...)
(i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...)))))
(define-syntax i:let
(syntax-rules (values)
(define-syntax i:let
(syntax-rules (values)
; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...))
; processes the binding specs bs ... by adding call-with-values
; skeletons to cwv ... and bindings to vx ..., and afterwards
; wrapping the skeletons around the payload (let (vx ...) . body).
; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...))
; processes the binding specs bs ... by adding call-with-values
; skeletons to cwv ... and bindings to vx ..., and afterwards
; wrapping the skeletons around the payload (let (vx ...) . body).
; no more bs to process -> wrap call-with-values skeletons
((i:let "bs" rec (cwv ...) vxs body ())
(i:let "wrap" rec vxs body cwv ...))
; no more bs to process -> wrap call-with-values skeletons
((i:let "bs" rec (cwv ...) vxs body ())
(i:let "wrap" rec vxs body cwv ...))
; recognize form1 without variable -> dummy binding for side-effects
((i:let "bs" rec cwvs (vx ...) body (((values) x) bs ...))
(i:let "bs" rec cwvs (vx ... (dummy (begin x #f))) body (bs ...)))
; recognize form1 without variable -> dummy binding for side-effects
((i:let "bs" rec cwvs (vx ...) body (((values) x) bs ...))
(i:let "bs" rec cwvs (vx ... (dummy (begin x #f))) body (bs ...)))
; recognize form1 with single variable -> just extend vx ...
((i:let "bs" rec cwvs (vx ...) body (((values v) x) bs ...))
(i:let "bs" rec cwvs (vx ... (v x)) body (bs ...)))
; recognize form1 with single variable -> just extend vx ...
((i:let "bs" rec cwvs (vx ...) body (((values v) x) bs ...))
(i:let "bs" rec cwvs (vx ... (v x)) body (bs ...)))
; recognize form1 without rest arg -> generate cwv
((i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...))
(i:let "form1" rec cwvs vxs body (bs ...) (x ()) (values v ...)))
; recognize form1 without rest arg -> generate cwv
((i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...))
(i:let "form1" rec cwvs vxs body (bs ...) (x ()) (values v ...)))
; recognize form1 with rest arg -> generate cwv
((i:let "bs" rec cwvs vxs body (((values . vs) x) bs ...))
(i:let "form1+" rec cwvs vxs body (bs ...) (x ()) (values . vs)))
; recognize form1 with rest arg -> generate cwv
((i:let "bs" rec cwvs vxs body (((values . vs) x) bs ...))
(i:let "form1+" rec cwvs vxs body (bs ...) (x ()) (values . vs)))
; recognize form2 with single variable -> just extend vx ...
((i:let "bs" rec cwvs (vx ...) body ((v x) bs ...))
(i:let "bs" rec cwvs (vx ... (v x)) body (bs ...)))
; recognize form2 with single variable -> just extend vx ...
((i:let "bs" rec cwvs (vx ...) body ((v x) bs ...))
(i:let "bs" rec cwvs (vx ... (v x)) body (bs ...)))
; recognize form2 with >=2 variables -> transform to form1
((i:let "bs" rec cwvs vxs body ((b1 b2 b3 b ...) bs ...))
(i:let "form2" rec cwvs vxs body (bs ...) (b1 b2) (b3 b ...)))
; recognize form2 with >=2 variables -> transform to form1
((i:let "bs" rec cwvs vxs body ((b1 b2 b3 b ...) bs ...))
(i:let "form2" rec cwvs vxs body (bs ...) (b1 b2) (b3 b ...)))
; (i:let "form1" rec cwvs vxs body bss (x (t ...)) (values v1 v2 v ...))
; processes the variables in v1 v2 v ... adding them to (t ...)
; and producing a cwv when finished. There is not rest argument.
; (i:let "form1" rec cwvs vxs body bss (x (t ...)) (values v1 v2 v ...))
; processes the variables in v1 v2 v ... adding them to (t ...)
; and producing a cwv when finished. There is not rest argument.
((i:let "form1" rec (cwv ...) vxs body bss (x ts) (values))
(i:let "bs" rec (cwv ... (x ts)) vxs body bss))
((i:let "form1" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v ...))
(i:let "form1" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v ...)))
((i:let "form1" rec (cwv ...) vxs body bss (x ts) (values))
(i:let "bs" rec (cwv ... (x ts)) vxs body bss))
((i:let "form1" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v ...))
(i:let "form1" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v ...)))
; (i:let "form1+" rec cwvs vxs body bss (x (t ...)) (values v ... . vr))
; processes the variables in v ... . vr adding them to (t ...)
; and producing a cwv when finished. The rest arg is vr.
; (i:let "form1+" rec cwvs vxs body bss (x (t ...)) (values v ... . vr))
; processes the variables in v ... . vr adding them to (t ...)
; and producing a cwv when finished. The rest arg is vr.
((i:let "form1+" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v2 . vs))
(i:let "form1+" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v2 . vs)))
((i:let "form1+" rec (cwv ...) (vx ...) body bss (x (t ...)) (values v1 . vr))
(i:let "bs" rec (cwv ... (x (t ... t1 . tr))) (vx ... (v1 t1) (vr tr)) body bss))
((i:let "form1+" rec (cwv ...) (vx ...) body bss (x ()) (values . vr))
(i:let "bs" rec (cwv ... (x tr)) (vx ... (vr tr)) body bss))
((i:let "form1+" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v2 . vs))
(i:let "form1+" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v2 . vs)))
((i:let "form1+" rec (cwv ...) (vx ...) body bss (x (t ...)) (values v1 . vr))
(i:let "bs" rec (cwv ... (x (t ... t1 . tr))) (vx ... (v1 t1) (vr tr)) body bss))
((i:let "form1+" rec (cwv ...) (vx ...) body bss (x ()) (values . vr))
(i:let "bs" rec (cwv ... (x tr)) (vx ... (vr tr)) body bss))
; (i:let "form2" rec cwvs vxs body bss (v ...) (b ... x))
; processes the binding items (b ... x) from form2 as in
; (v ... b ... x) into ((values v ... b ...) x), i.e. form1.
; Then call "bs" recursively.
; (i:let "form2" rec cwvs vxs body bss (v ...) (b ... x))
; processes the binding items (b ... x) from form2 as in
; (v ... b ... x) into ((values v ... b ...) x), i.e. form1.
; Then call "bs" recursively.
((i:let "form2" rec cwvs vxs body (bs ...) (v ...) (x))
(i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...)))
((i:let "form2" rec cwvs vxs body bss (v ...) (b1 b2 b ...))
(i:let "form2" rec cwvs vxs body bss (v ... b1) (b2 b ...)))
((i:let "form2" rec cwvs vxs body (bs ...) (v ...) (x))
(i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...)))
((i:let "form2" rec cwvs vxs body bss (v ...) (b1 b2 b ...))
(i:let "form2" rec cwvs vxs body bss (v ... b1) (b2 b ...)))
; (i:let "wrap" rec ((v x) ...) (body ...) cwv ...)
; wraps cwv ... around the payload generating the actual code.
; For letrec this is of course different than for let.
; (i:let "wrap" rec ((v x) ...) (body ...) cwv ...)
; wraps cwv ... around the payload generating the actual code.
; For letrec this is of course different than for let.
((i:let "wrap" #f vxs body)
(let vxs . body))
((i:let "wrap" #f vxs body (x formals) cwv ...)
(call-with-values
(lambda () x)
(lambda formals (i:let "wrap" #f vxs body cwv ...))))
((i:let "wrap" #f vxs body)
(let vxs . body))
((i:let "wrap" #f vxs body (x formals) cwv ...)
(call-with-values
(lambda () x)
(lambda formals (i:let "wrap" #f vxs body cwv ...))))
((i:let "wrap" #t vxs body)
(letrec vxs . body))
((i:let "wrap" #t ((v t) ...) body cwv ...)
(let ((v i:undefined) ...) ; (*)
(i:let "wraprec" ((v t) ...) body cwv ...)))
((i:let "wrap" #t vxs body)
(letrec vxs . body))
((i:let "wrap" #t ((v t) ...) body cwv ...)
(let ((v i:undefined) ...) ; (*)
(i:let "wraprec" ((v t) ...) body cwv ...)))
; (i:let "wraprec" ((v t) ...) body cwv ...)
; generate the inner code for a letrec. The variables v ...
; are the user-visible variables (bound outside), and t ...
; are the temporary variables bound by the cwv consumers.
; (i:let "wraprec" ((v t) ...) body cwv ...)
; generate the inner code for a letrec. The variables v ...
; are the user-visible variables (bound outside), and t ...
; are the temporary variables bound by the cwv consumers.
((i:let "wraprec" ((v t) ...) (body ...))
(begin (set! v t) ... (let () body ...)))
((i:let "wraprec" vxs body (x formals) cwv ...)
(call-with-values
(lambda () x)
(lambda formals (i:let "wraprec" vxs body cwv ...))))
((i:let "wraprec" ((v t) ...) (body ...))
(begin (set! v t) ... (let () body ...)))
((i:let "wraprec" vxs body (x formals) cwv ...)
(call-with-values
(lambda () x)
(lambda formals (i:let "wraprec" vxs body cwv ...))))
))
))
(define-syntax i:named-let
(syntax-rules (values)
(define-syntax i:named-let
(syntax-rules (values)
; (i:named-let tag (vx ...) body (bs ...))
; processes the binding specs bs ... by extracting the variable
; and expression, adding them to vx and turning the result into
; an ordinary named let.
; (i:named-let tag (vx ...) body (bs ...))
; processes the binding specs bs ... by extracting the variable
; and expression, adding them to vx and turning the result into
; an ordinary named let.
((i:named-let tag vxs body ())
(let tag vxs . body))
((i:named-let tag (vx ...) body (((values v) x) bs ...))
(i:named-let tag (vx ... (v x)) body (bs ...)))
((i:named-let tag (vx ...) body ((v x) bs ...))
(i:named-let tag (vx ... (v x)) body (bs ...)))))
((i:named-let tag vxs body ())
(let tag vxs . body))
((i:named-let tag (vx ...) body (((values v) x) bs ...))
(i:named-let tag (vx ... (v x)) body (bs ...)))
((i:named-let tag (vx ...) body ((v x) bs ...))
(i:named-let tag (vx ... (v x)) body (bs ...)))))
; --- standard procedures ---
; --- standard procedures ---
(define (uncons pair)
(values (car pair) (cdr pair)))
(define (uncons pair)
(values (car pair) (cdr pair)))
(define (uncons-2 list)
(values (car list) (cadr list) (cddr list)))
(define (uncons-2 list)
(values (car list) (cadr list) (cddr list)))
(define (uncons-3 list)
(values (car list) (cadr list) (caddr list) (cdddr list)))
(define (uncons-3 list)
(values (car list) (cadr list) (caddr list) (cdddr list)))
(define (uncons-4 list)
(values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list)))
(define (uncons-4 list)
(values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list)))
(define (uncons-cons alist)
(values (caar alist) (cdar alist) (cdr alist)))
(define (uncons-cons alist)
(values (caar alist) (cdar alist) (cdr alist)))
(define (unlist list)
(apply values list))
(define (unlist list)
(apply values list))
(define (unvector vector)
(apply values (vector->list vector)))
(define (unvector vector)
(apply values (vector->list vector)))
; --- standard macros ---
; --- standard macros ---
(define-syntax values->list
(syntax-rules ()
((values->list x)
(call-with-values (lambda () x) list))))
(define-syntax values->list
(syntax-rules ()
((values->list x)
(call-with-values (lambda () x) list))))
(define-syntax values->vector
(syntax-rules ()
((values->vector x)
(call-with-values (lambda () x) vector))))
(define-syntax values->vector
(syntax-rules ()
((values->vector x)
(call-with-values (lambda () x) vector))))
; --- textual copy of 'letvalues.scm' ends here ---
) ; module letvalues
; --- textual copy of 'letvalues.scm' ends here ---

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

117
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 " (")
(display cases)
(display " cases checked)")))
(unless (= cases 1)
(display " (")
(display cases)
(display " cases checked)"))
(newline))
(define (check:report-failed expected-result)
@ -113,25 +113,24 @@
(newline))
(define (check-report)
(if (>= check:mode 1)
(begin
(when (>= check:mode 1)
(newline)
(display "; *** checks *** : ")
(display check:correct)
(display " correct, ")
(display (length check:failed))
(display " failed.")
(if (or (null? check:failed) (<= check:mode 1))
(newline)
(let* ((w (car (reverse check:failed)))
(expression (car w))
(actual-result (cadr w))
(expected-result (caddr w)))
(display " First failed example:")
(newline)
(display "; *** checks *** : ")
(display check:correct)
(display " correct, ")
(display (length check:failed))
(display " failed.")
(if (or (null? check:failed) (<= check:mode 1))
(newline)
(let* ((w (car (reverse check:failed)))
(expression (car w))
(actual-result (cadr w))
(expected-result (caddr w)))
(display " First failed example:")
(newline)
(check:report-expression expression)
(check:report-actual-result actual-result)
(check:report-failed expected-result))))))
(check:report-expression expression)
(check:report-actual-result actual-result)
(check:report-failed expected-result)))))
(define (check-passed? expected-total-count)
(and (= (length check:failed) 0)
@ -168,15 +167,15 @@
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)
(check:proc 'expr (lambda () expr) equal expected)))))
(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)
(check:report-actual-result actual-result)
(check:report-correct cases)))
(begin (when (>= check:mode 100)
(check:report-expression expression)
(check:report-actual-result actual-result)
(check:report-correct cases))
(check:add-correct!))
(begin (if (>= check:mode 10)
(begin (check:report-expression expression)
(check:report-actual-result actual-result)
(check:report-failed expected-result)))
(begin (when (>= check:mode 10)
(check:report-expression expression)
(check:report-actual-result actual-result)
(check:report-failed expected-result))
(check:add-failed! expression
actual-result
expected-result)))))
@ -203,32 +202,32 @@
(define-syntax check-ec:make
(syntax-rules (=>)
((check-ec:make qualifiers expr (=> equal) expected (arg ...))
(if (>= check:mode 1)
(check:proc-ec
(let ((cases 0))
(let ((w (first-ec
#f
qualifiers
(:let equal-pred equal)
(:let expected-result expected)
(:let actual-result
(let ((arg arg) ...) ; (*)
expr))
(begin (set! cases (+ cases 1)))
(if (not (equal-pred actual-result expected-result)))
(list (list 'let (list (list 'arg arg) ...) 'expr)
actual-result
expected-result
cases))))
(if w
(cons #f w)
(list #t
'(check-ec qualifiers
expr (=> equal)
expected (arg ...))
(if #f #f)
(if #f #f)
cases)))))))))
(when (>= check:mode 1)
(check:proc-ec
(let ((cases 0))
(let ((w (first-ec
#f
qualifiers
(:let equal-pred equal)
(:let expected-result expected)
(:let actual-result
(let ((arg arg) ...) ; (*)
expr))
(begin (set! cases (+ cases 1)))
(if (not (equal-pred actual-result expected-result)))
(list (list 'let (list (list 'arg arg) ...) 'expr)
actual-result
expected-result
cases))))
(if w
(cons #f w)
(list #t
'(check-ec qualifiers
expr (=> equal)
expected (arg ...))
(void)
(void)
cases)))))))))
; (*) is a compile-time check that (arg ...) is a list
; of pairwise disjoint bound variables at this point.

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

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

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

File diff suppressed because it is too large Load Diff

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

46
collects/srfi/features.ss
View File

@ -1,30 +1,28 @@
(module features mzscheme
(provide feature-present?
feature->require-clause)
#lang scheme/base
(define *feature-alist*
'())
(provide feature-present? feature->require-clause)
(define (srfi-id? id)
(let ((string-id (symbol->string id)))
(and (> (string-length string-id) 5)
(string=? "srfi-"
(substring string-id 0 5)))))
(define *feature-alist*
'())
(define (srfi-id->filename srfi-id)
(let ((string-id (symbol->string srfi-id)))
(string-append (substring string-id 5 (string-length string-id))
".ss")))
(define (srfi-id? id)
(regexp-match? #rx"^srfi-[0-9]+$" (symbol->string id)))
(define (srfi-id-present? srfi-id)
(file-exists? (build-path (collection-path "srfi")
(srfi-id->filename srfi-id))))
(define (srfi-id->filename srfi-id)
(regexp-replace #rx"^srfi-([0-9]+)$" (symbol->string srfi-id) "\\1/\\1.ss"))
(define (feature-present? id)
(or (and (srfi-id? id) (srfi-id-present? id))
(and (assq id *feature-alist*) #t)))
(define (srfi-id-present? srfi-id)
(file-exists? (build-path (collection-path "srfi")
(srfi-id->filename srfi-id))))
(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*)))))
(define (feature-present? id)
(or (and (srfi-id? id) (srfi-id-present? id))
(and (assq id *feature-alist*) #t)))
(define (feature->require-clause id)
(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)]))

35
collects/srfi/optional.ss
View File

@ -45,29 +45,28 @@
;; 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)
(if (not (pred val))
(let ([expected-string
(cond [(eq? pred number? ) "expected number, "]
[(eq? pred integer?) "expected integer, "]
[(eq? pred pair?) "expected pair, "]
[(eq? pred procedure?) "expected procedure, "]
[(eq? pred string?) "expected string, "]
[(eq? pred vector?) "expected vector, "]
[else ""])])
(error caller (string-append expected-string "given ~s") val))
val)))
(define (check-arg pred val caller)
(if (not (pred val))
(let ([expected-string
(cond [(eq? pred number? ) "expected number, "]
[(eq? pred integer?) "expected integer, "]
[(eq? pred pair?) "expected pair, "]
[(eq? pred procedure?) "expected procedure, "]
[(eq? pred string?) "expected string, "]
[(eq? pred vector?) "expected vector, "]
[else ""])])
(error caller (string-append expected-string "given ~s") 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))]))))