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

reformatting

Browse Source 
svn: r8652
This commit is contained in:
Eli Barzilay 2008-02-13 20:17:26 +00:00
parent b69384799a
commit 572b7f1401
3 changed files with 1803 additions and 1808 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3370
collects/srfi/13/string.ss
View File

File diff suppressed because it is too large Load Diff

16
collects/srfi/8/receive.ss
View File

@ -10,13 +10,11 @@
;;;
;;; oh well, there is no such comment.
(module receive mzscheme
(provide receive)
#lang mzscheme
(provide receive)
;; (receive vars producer . body)
(define-syntax receive
(syntax-rules ()
((receive ?vars ?producer . ?body)
(call-with-values (lambda () ?producer)
(lambda ?vars . ?body)))))
)
;; (receive vars producer . body)
(define-syntax receive
(syntax-rules ()
((receive ?vars ?producer . ?body)
(call-with-values (lambda () ?producer) (lambda ?vars . ?body)))))

225
collects/srfi/optional.ss
View File

@ -10,7 +10,7 @@
;;; Copyright (c) 1993-1999 Richard Kelsey and Jonathan Rees
;;; Copyright (c) 1994-1999 by Olin Shivers and Brian D. Carlstrom.
;;; All rights reserved.
;;;
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
@ -21,7 +21,7 @@
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
@ -45,126 +45,125 @@
;; macros. :-)
;;
(module optional mzscheme
(provide :optional
let-optionals*
check-arg
)
#lang mzscheme
(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)))
;; (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)))
;; (:optional rest-arg default-exp [test-pred])
;;
;; This form is for evaluating optional arguments and their defaults
;; in simple procedures that take a *single* optional argument. It is
;; a macro so that the default will not be computed unless it is needed.
;;
;; REST-ARG is a rest list from a lambda -- e.g., R in
;; (lambda (a b . r) ...)
;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
;; - If REST-ARG has 1 element, return that element.
;; - If REST-ARG has >1 element, error.
;;
;; If there is an TEST-PRED form, it is a predicate that is used to test
;; a non-default value. If the predicate returns false, an error is raised.
(define-syntax (:optional stx)
(syntax-case stx ()
[(_ rest default-exp)
(syntax
(let ((maybe-arg rest))
(if (pair? maybe-arg)
(if (null? (cdr maybe-arg)) (car maybe-arg)
(error "too many optional arguments:" maybe-arg))
default-exp)))]
[(_ rest default-exp arg-test)
(syntax
(let ((maybe-arg rest))
(if (pair? maybe-arg)
(if (null? (cdr maybe-arg))
(let ((val (car maybe-arg)))
(if (arg-test val) val
(error "optional argument failed test:" val)))
(error "too many optional arguments:" maybe-arg))
default-exp)))]))
;; (:optional rest-arg default-exp [test-pred])
;;
;; This form is for evaluating optional arguments and their defaults
;; in simple procedures that take a *single* optional argument. It is
;; a macro so that the default will not be computed unless it is needed.
;;
;; REST-ARG is a rest list from a lambda -- e.g., R in
;; (lambda (a b . r) ...)
;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
;; - If REST-ARG has 1 element, return that element.
;; - If REST-ARG has >1 element, error.
;;
;; If there is an TEST-PRED form, it is a predicate that is used to test
;; a non-default value. If the predicate returns false, an error is raised.
(define-syntax (:optional stx)
(syntax-case stx ()
[(_ rest default-exp)
(syntax
(let ([maybe-arg rest])
(if (pair? maybe-arg)
(if (null? (cdr maybe-arg)) (car maybe-arg)
(error "too many optional arguments:" maybe-arg))
default-exp)))]
[(_ rest default-exp arg-test)
(syntax
(let ([maybe-arg rest])
(if (pair? maybe-arg)
(if (null? (cdr maybe-arg))
(let ([val (car maybe-arg)])
(if (arg-test val) val
(error "optional argument failed test:" val)))
(error "too many optional arguments:" maybe-arg))
default-exp)))]))
;; NOTE: This is the `less-efficient version of LET-OPTIONALS*'.
;; Once I understand the more efficient one, as for to
;; adapt it to PLT Scheme, I will. Sorry, Olin Shivers,
;; wrote a far to complex thing for me to grasp. :-{
;; NOTE: This is the `less-efficient version of LET-OPTIONALS*'.
;; Once I understand the more efficient one, as for to
;; adapt it to PLT Scheme, I will. Sorry, Olin Shivers,
;; wrote a far to complex thing for me to grasp. :-{
;; (LET-OPTIONALS* arg-list (opt-clause1 ... opt-clauseN [rest])
;; body ...)
;; where
;; <opt-clause> ::= (var default [arg-check supplied?])
;; | ((var1 ... varN) external-arg-parser)
;;
;; LET-OPTIONALS* has LET* scope -- each arg clause sees the bindings of
;; the previous clauses. LET-OPTIONALS has LET scope -- each arg clause
;; sees the outer scope (an ARG-CHECK expression sees the outer scope
;; *plus* the variable being bound by that clause, by necessity).
(define-syntax let-optionals*
(syntax-rules ()
((let-optionals* arg (opt-clause ...) body ...)
(let ((rest arg))
(%let-optionals* rest (opt-clause ...) body ...)))))
;; (LET-OPTIONALS* arg-list (opt-clause1 ... opt-clauseN [rest])
;; body ...)
;; where
;; <opt-clause> ::= (var default [arg-check supplied?])
;; | ((var1 ... varN) external-arg-parser)
;;
;; LET-OPTIONALS* has LET* scope -- each arg clause sees the bindings of
;; the previous clauses. LET-OPTIONALS has LET scope -- each arg clause
;; sees the outer scope (an ARG-CHECK expression sees the outer scope
;; *plus* the variable being bound by that clause, by necessity).
(define-syntax let-optionals*
(syntax-rules ()
[(let-optionals* arg (opt-clause ...) body ...)
(let ([rest arg])
(%let-optionals* rest (opt-clause ...) body ...))]))
(define-syntax %let-optionals*
(syntax-rules ()
((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...)
(call-with-values (lambda () (xparser arg))
(lambda (rest var ...)
(%let-optionals* rest (opt-clause ...) body ...))))
((%let-optionals* arg ((var default) opt-clause ...) body ...)
(call-with-values (lambda () (if (null? arg) (values default '())
(values (car arg) (cdr arg))))
(lambda (var rest)
(%let-optionals* rest (opt-clause ...) body ...))))
((%let-optionals* arg ((var default test) opt-clause ...) body ...)
(call-with-values (lambda ()
(if (null? arg) (values default '())
(let ((var (car arg)))
(if test (values var (cdr arg))
(error "arg failed LET-OPT test" var)))))
(lambda (var rest)
(%let-optionals* rest (opt-clause ...) body ...))))
(define-syntax %let-optionals*
(syntax-rules ()
[(%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...)
(call-with-values (lambda () (xparser arg))
(lambda (rest var ...)
(%let-optionals* rest (opt-clause ...) body ...)))]
((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...)
(call-with-values (lambda ()
(if (null? arg) (values default #f '())
(let ((var (car arg)))
(if test (values var #t (cdr arg))
(error "arg failed LET-OPT test" var)))))
(lambda (var supplied? rest)
(%let-optionals* rest (opt-clause ...) body ...))))
[(%let-optionals* arg ((var default) opt-clause ...) body ...)
(call-with-values (lambda () (if (null? arg) (values default '())
(values (car arg) (cdr arg))))
(lambda (var rest)
(%let-optionals* rest (opt-clause ...) body ...)))]
((%let-optionals* arg (rest) body ...)
(let ((rest arg)) body ...))
[(%let-optionals* arg ((var default test) opt-clause ...) body ...)
(call-with-values (lambda ()
(if (null? arg) (values default '())
(let ([var (car arg)])
(if test (values var (cdr arg))
(error "arg failed LET-OPT test" var)))))
(lambda (var rest)
(%let-optionals* rest (opt-clause ...) body ...)))]
((%let-optionals* arg () body ...)
(if (null? arg) (begin body ...)
(error "Too many arguments in let-opt" arg)))))
[(%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...)
(call-with-values (lambda ()
(if (null? arg) (values default #f '())
(let ([var (car arg)])
(if test (values var #t (cdr arg))
(error "arg failed LET-OPT test" var)))))
(lambda (var supplied? rest)
(%let-optionals* rest (opt-clause ...) body ...)))]
)
;; optional.ss ends here
[(%let-optionals* arg (rest) body ...)
(let ([rest arg]) body ...)]
[(%let-optionals* arg () body ...)
(if (null? arg) (begin body ...)
(error "Too many arguments in let-opt" arg))]))
;; optional.ss ends here