Add srfis from the Schematics repository
svn: r1090
This commit is contained in:
Noel Welsh
parent
af1e6be894
commit
6b283301ea
4
collects/srfi/48.ss
Normal file
4
collects/srfi/48.ss
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
;; module loader for SRFI-48
|
||||
(module |48| mzscheme
|
||||
(require (lib "format.ss" "srfi" "48"))
|
||||
(provide (rename s:format format)))
|
||||
314
collects/srfi/48/format.ss
Normal file
314
collects/srfi/48/format.ss
Normal file
|
|
@ -0,0 +1,314 @@
|
|||
; SRFI 48
|
||||
; Zhu Chongkai mrmathematica@yahoo.com
|
||||
; 28-May-2005
|
||||
(module format mzscheme
|
||||
|
||||
(require (lib "pretty.ss"))
|
||||
|
||||
(provide s:format)
|
||||
|
||||
(define (s:format . args)
|
||||
(cond
|
||||
((null? args)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
"format: expects at least 1 argument, given 0"
|
||||
(current-continuation-marks))))
|
||||
((string? (car args))
|
||||
(apply s:format #f args))
|
||||
((< (length args) 2)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
"format: expects at least 1 string arguments, given 0"
|
||||
(current-continuation-marks))))
|
||||
(else
|
||||
(let ((output-port (car args))
|
||||
(format-string (cadr args))
|
||||
(args (cddr args)))
|
||||
(let ((port
|
||||
(cond ((output-port? output-port) output-port)
|
||||
((eq? output-port #t) (current-output-port))
|
||||
((eq? output-port #f) (open-output-string))
|
||||
(else (raise-type-error 'format "output-port/boolean" 0 args)))))
|
||||
|
||||
(define (point-five? n)
|
||||
(let ((absn (abs n)))
|
||||
(= 0.5 (- absn (truncate absn)))))
|
||||
|
||||
(define (round* n scale) ;; assert scale < 0
|
||||
;; Note: Scheme's "round to even" rule for 0.5*
|
||||
(let ((one (expt 10 (- scale))))
|
||||
(/ (round (* n one)) one)))
|
||||
|
||||
(define (string-index str c)
|
||||
(let ((len (string-length str)))
|
||||
(let loop ((i 0))
|
||||
(cond ((= i len) #f)
|
||||
((eqv? c (string-ref str i)) i)
|
||||
(else (loop (+ i 1)))))))
|
||||
|
||||
(define (string-grow str len char)
|
||||
(let ((off (- len (string-length str))))
|
||||
(if (positive? off)
|
||||
(string-append (make-string off char) str)
|
||||
str)))
|
||||
|
||||
(define (string-pad-right str len char)
|
||||
(let ((slen (string-length str)))
|
||||
(cond ((< slen len)
|
||||
(string-append str (make-string (- len slen) char)))
|
||||
((> slen len)
|
||||
(substring (number->string
|
||||
(round* (string->number str) len))
|
||||
0
|
||||
len))
|
||||
(else str))))
|
||||
|
||||
(define (format-fixed number-or-string width digits)
|
||||
(cond
|
||||
((string? number-or-string)
|
||||
(string-grow number-or-string width #\space))
|
||||
((number? number-or-string)
|
||||
(let ((real (real-part number-or-string))
|
||||
(imag (imag-part number-or-string)))
|
||||
(cond
|
||||
((not (zero? imag))
|
||||
(string-grow
|
||||
(string-append (format-fixed real 0 digits)
|
||||
(if (negative? imag) "" "+")
|
||||
(format-fixed imag 0 digits)
|
||||
"i")
|
||||
width
|
||||
#\space))
|
||||
(digits
|
||||
(let* ((rounded-number (exact->inexact (round* real (- digits))))
|
||||
(rounded-string (number->string rounded-number))
|
||||
(dot-index (string-index rounded-string #\.))
|
||||
(exp-index (string-index rounded-string #\e))
|
||||
(length (string-length rounded-string))
|
||||
(pre-string
|
||||
(cond
|
||||
(exp-index
|
||||
(if dot-index
|
||||
(substring rounded-string 0 (+ dot-index 1))
|
||||
(substring rounded-string 0 (+ exp-index 1))))
|
||||
(dot-index
|
||||
(substring rounded-string 0 (+ dot-index 1)))
|
||||
(else
|
||||
rounded-string)))
|
||||
(exp-string
|
||||
(if exp-index
|
||||
(substring rounded-string exp-index length)
|
||||
""))
|
||||
(frac-string
|
||||
(if exp-index
|
||||
(substring rounded-string (+ dot-index 1) exp-index)
|
||||
(substring rounded-string (+ dot-index 1) length))))
|
||||
(string-grow
|
||||
(string-append pre-string
|
||||
(if dot-index "" ".")
|
||||
(string-pad-right frac-string digits #\0)
|
||||
exp-string)
|
||||
width
|
||||
#\space)))
|
||||
(else ;; no digits
|
||||
(string-grow (number->string real) width #\space)))))
|
||||
(else
|
||||
(raise-type-error 'format "number/string" number-or-string))))
|
||||
|
||||
(define documentation-string
|
||||
"(format [<port>] <format-string> [<arg>...]) -- <port> is #t, #f or an output-port
|
||||
OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Encoding
|
||||
~H [Help] output this text
|
||||
~A [Any] (display arg) for humans
|
||||
~S [Slashified] (write arg) for parsers
|
||||
~W [WriteCircular] like ~s but outputs circular and recursive data structures
|
||||
~~ [tilde] output a tilde
|
||||
~T [Tab] output a tab character
|
||||
~% [Newline] output a newline character
|
||||
~& [Freshline] output a newline character if the previous output was not a newline
|
||||
~D [Decimal] the arg is a number which is output in decimal radix
|
||||
~X [heXadecimal] the arg is a number which is output in hexdecimal radix
|
||||
~O [Octal] the arg is a number which is output in octal radix
|
||||
~B [Binary] the arg is a number which is output in binary radix
|
||||
~w,dF [Fixed] the arg is a string or number which has width w and d digits after the decimal
|
||||
~C [Character] charater arg is output by write-char
|
||||
~_ [Space] a single space character is output
|
||||
~Y [Yuppify] the list arg is pretty-printed to the output
|
||||
~? [Indirection] recursive format: next 2 args are format-string and list of arguments
|
||||
~K [Indirection] same as ~?
|
||||
")
|
||||
|
||||
(define (require-an-arg args)
|
||||
(unless (pair? args)
|
||||
(raise-mismatch-error 'format "too few arguments: " args)))
|
||||
|
||||
(define (format-help format-strg arglist)
|
||||
(letrec ((length-of-format-string (string-length format-strg))
|
||||
(anychar-dispatch
|
||||
(lambda (pos arglist last-was-newline)
|
||||
(if (>= pos length-of-format-string)
|
||||
arglist ; return unused args
|
||||
(let ((char (string-ref format-strg pos)))
|
||||
(cond
|
||||
((eqv? char #\~)
|
||||
(tilde-dispatch (+ pos 1) arglist last-was-newline))
|
||||
(else
|
||||
(write-char char port)
|
||||
(anychar-dispatch (+ pos 1) arglist #f)))))))
|
||||
(has-newline?
|
||||
(lambda (whatever last-was-newline)
|
||||
(or (eqv? whatever #\newline)
|
||||
(and (string? whatever)
|
||||
(let ((len (string-length whatever)))
|
||||
(if (zero? len)
|
||||
last-was-newline
|
||||
(eqv? #\newline
|
||||
(string-ref whatever (- len 1)))))))))
|
||||
(tilde-dispatch
|
||||
(lambda (pos arglist last-was-newline)
|
||||
(cond
|
||||
((>= pos length-of-format-string)
|
||||
(write-char #\~ port) ; tilde at end of string is just output
|
||||
arglist)
|
||||
(else
|
||||
(case (char-upcase (string-ref format-strg pos))
|
||||
((#\A) ; Any -- for humans
|
||||
(require-an-arg arglist)
|
||||
(let ((whatever (car arglist)))
|
||||
(display whatever port)
|
||||
(anychar-dispatch (+ pos 1)
|
||||
(cdr arglist)
|
||||
(has-newline? whatever
|
||||
last-was-newline))))
|
||||
((#\S) ; Slashified -- for parsers
|
||||
(require-an-arg arglist)
|
||||
(let ((whatever (car arglist)))
|
||||
(write whatever port)
|
||||
(anychar-dispatch (+ pos 1)
|
||||
(cdr arglist)
|
||||
(has-newline? whatever
|
||||
last-was-newline))))
|
||||
((#\W)
|
||||
(require-an-arg arglist)
|
||||
(let ((whatever (car arglist)))
|
||||
(write whatever port)
|
||||
(anychar-dispatch (+ pos 1)
|
||||
(cdr arglist)
|
||||
(has-newline? whatever
|
||||
last-was-newline))))
|
||||
((#\D) ; Decimal
|
||||
(require-an-arg arglist)
|
||||
(display (number->string (car arglist) 10) port)
|
||||
(anychar-dispatch (+ pos 1) (cdr arglist) #f))
|
||||
((#\X) ; HeXadecimal
|
||||
(require-an-arg arglist)
|
||||
(display (number->string (car arglist) 16) port)
|
||||
(anychar-dispatch (+ pos 1) (cdr arglist) #f))
|
||||
((#\O) ; Octal
|
||||
(require-an-arg arglist)
|
||||
(display (number->string (car arglist) 8) port)
|
||||
(anychar-dispatch (+ pos 1) (cdr arglist) #f))
|
||||
((#\B) ; Binary
|
||||
(require-an-arg arglist)
|
||||
(display (number->string (car arglist) 2) port)
|
||||
(anychar-dispatch (+ pos 1) (cdr arglist) #f))
|
||||
((#\C) ; Character
|
||||
(require-an-arg arglist)
|
||||
(write-char (car arglist) port)
|
||||
(anychar-dispatch (+ pos 1)
|
||||
(cdr arglist)
|
||||
(eqv? (car arglist) #\newline)))
|
||||
((#\~) ; Tilde
|
||||
(write-char #\~ port)
|
||||
(anychar-dispatch (+ pos 1) arglist #f))
|
||||
((#\%) ; Newline
|
||||
(newline port)
|
||||
(anychar-dispatch (+ pos 1) arglist #t))
|
||||
((#\&) ; Freshline
|
||||
(unless last-was-newline
|
||||
(newline port))
|
||||
(anychar-dispatch (+ pos 1) arglist #t))
|
||||
((#\_) ; Space
|
||||
(write-char #\space port)
|
||||
(anychar-dispatch (+ pos 1) arglist #f))
|
||||
((#\T) ; Tab
|
||||
(write-char #\tab port)
|
||||
(anychar-dispatch (+ pos 1) arglist #f))
|
||||
((#\Y) ; Pretty-print
|
||||
(pretty-print (car arglist) port)
|
||||
(anychar-dispatch (+ pos 1) (cdr arglist) #f))
|
||||
((#\F)
|
||||
(require-an-arg arglist)
|
||||
(display (format-fixed (car arglist) 0 #f) port)
|
||||
(anychar-dispatch (+ pos 1) (cdr arglist) #f))
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
;; gather "~w[,d]F" w and d digits
|
||||
(let loop ((index (+ pos 1))
|
||||
(w-digits (list (string-ref format-strg pos)))
|
||||
(d-digits '())
|
||||
(in-width? #t))
|
||||
(if (>= index length-of-format-string)
|
||||
(raise-mismatch-error 'format
|
||||
"improper numeric format directive in "
|
||||
format-strg)
|
||||
(let ((next-char (string-ref format-strg index)))
|
||||
(cond
|
||||
((char-numeric? next-char)
|
||||
(if in-width?
|
||||
(loop (+ index 1)
|
||||
(cons next-char w-digits)
|
||||
d-digits
|
||||
in-width?)
|
||||
(loop (+ index 1)
|
||||
w-digits
|
||||
(cons next-char d-digits)
|
||||
in-width?)))
|
||||
((char=? next-char #\F)
|
||||
(let ((width
|
||||
(string->number (list->string (reverse w-digits))))
|
||||
(digits
|
||||
(if (zero? (length d-digits))
|
||||
#f
|
||||
(string->number (list->string (reverse d-digits))))))
|
||||
(display (format-fixed (car arglist) width digits) port)
|
||||
(anychar-dispatch (+ index 1) (cdr arglist) #f)))
|
||||
((char=? next-char #\,)
|
||||
(if in-width?
|
||||
(loop (+ index 1)
|
||||
w-digits
|
||||
d-digits
|
||||
#f)
|
||||
(raise-mismatch-error 'format
|
||||
"too many commas in directive "
|
||||
format-strg)))
|
||||
(else
|
||||
(raise-mismatch-error 'format
|
||||
"~w.dF directive ill-formed in "
|
||||
format-strg)))))))
|
||||
((#\? #\K) ; indirection -- take next arg as format string
|
||||
(cond ; and following arg as list of format args
|
||||
((< (length arglist) 2)
|
||||
(raise-mismatch-error 'format
|
||||
"less arguments than specified for ~?: "
|
||||
arglist))
|
||||
((not (string? (car arglist)))
|
||||
(raise-mismatch-error 'format
|
||||
"~? requires a string: "
|
||||
(car arglist)))
|
||||
(else
|
||||
(format-help (car arglist) (cadr arglist))
|
||||
(anychar-dispatch (+ pos 1) (cddr arglist) #f))))
|
||||
((#\H) ; Help
|
||||
(display documentation-string port)
|
||||
(anychar-dispatch (+ pos 1) arglist #t))
|
||||
(else
|
||||
(raise-mismatch-error 'format
|
||||
"unknown tilde escape: "
|
||||
(string-ref format-strg pos)))))))))
|
||||
(anychar-dispatch 0 arglist #f)))
|
||||
|
||||
(let ((unused-args (format-help format-string args)))
|
||||
(if (not (null? unused-args))
|
||||
(raise-mismatch-error 'format "unused arguments " unused-args))
|
||||
(if (eq? output-port #f) ;; if format into a string
|
||||
(get-output-string port)) ;; then return the string
|
||||
)))))))
|
||||
4
collects/srfi/59.ss
Normal file
4
collects/srfi/59.ss
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
;; module loader for SRFI-59
|
||||
(module |59| mzscheme
|
||||
(require (lib "vicinity.ss" "srfi" "59"))
|
||||
(provide (all-from (lib "vicinity.ss" "srfi" "59"))))
|
||||
44
collects/srfi/59/vicinity.ss
Normal file
44
collects/srfi/59/vicinity.ss
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
; SRFI 59
|
||||
; Zhu Chongkai mrmathematica@yahoo.com
|
||||
; 29-May-2005
|
||||
(module vicinity mzscheme
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define (implementation-vicinity)
|
||||
(pathname->vicinity
|
||||
(simplify-path
|
||||
(find-system-path 'exec-file))))
|
||||
|
||||
(define (library-vicinity)
|
||||
(car (current-library-collection-paths)))
|
||||
|
||||
(define (home-vicinity)
|
||||
(find-system-path 'home-dir))
|
||||
|
||||
(define in-vicinity build-path)
|
||||
|
||||
(define (user-vicinity)
|
||||
(current-directory))
|
||||
|
||||
(define vicinity:suffix?
|
||||
(let ((suffi
|
||||
(case (system-type)
|
||||
((macos) '(#\:))
|
||||
((windows) '(#\\ #\/))
|
||||
((unix oskit macosx) '(#\/)))))
|
||||
(lambda (chr) (and (memv chr suffi) #t))))
|
||||
|
||||
(define (pathname->vicinity pathname)
|
||||
(call-with-values
|
||||
(lambda () (split-path pathname))
|
||||
(lambda (base name must-be-dir?) base)))
|
||||
|
||||
(define (program-vicinity)
|
||||
(current-load-relative-directory))
|
||||
|
||||
(define sub-vicinity build-path)
|
||||
|
||||
(define (make-vicinity pathname) pathname)
|
||||
|
||||
)
|
||||
5
collects/srfi/60.ss
Normal file
5
collects/srfi/60.ss
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
(module |60| mzscheme
|
||||
|
||||
(require (lib "60.ss" "srfi" "60"))
|
||||
(provide (all-from (lib "60.ss" "srfi" "60")))
|
||||
)
|
||||
5
collects/srfi/60/60.ss
Normal file
5
collects/srfi/60/60.ss
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
(module |60| mzscheme
|
||||
|
||||
(require (lib "60.ss" "srfi" "60"))
|
||||
(provide (all-from (lib "60.ss" "srfi" "60")))
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user