fix: README -> README.md
This commit is contained in:
tmtt
parent
43e68af625
commit
99b0a6292c
756 changed files with 323753 additions and 71 deletions
421
ta6ob/s/4.ss
Normal file
421
ta6ob/s/4.ss
Normal file
|
|
@ -0,0 +1,421 @@
|
|||
;;; 4.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define-who apply
|
||||
(let ()
|
||||
(define-syntax build-apply
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ () cl ...)
|
||||
#'(case-lambda
|
||||
[(p r)
|
||||
(unless (procedure? p)
|
||||
($oops #f "attempt to apply non-procedure ~s" p))
|
||||
(let ([n ($list-length r who)])
|
||||
(case n
|
||||
[(0) (p)]
|
||||
[(1) (p (car r))]
|
||||
[(2) (p (car r) (cadr r))]
|
||||
[(3) (let ([y1 (cdr r)]) (p (car r) (car y1) (cadr y1)))]
|
||||
[else ($apply p n r)]))]
|
||||
cl ...
|
||||
[(p x . r)
|
||||
(unless (procedure? p)
|
||||
($oops #f "attempt to apply non-procedure ~s" p))
|
||||
(let ([r (cons x ($apply list* ($list-length r who) r))])
|
||||
($apply p ($list-length r who) r))])]
|
||||
[(_ (s1 s2 ...) cl ...)
|
||||
(with-syntax ((m (length #'(s1 s2 ...))))
|
||||
#'(build-apply
|
||||
(s2 ...)
|
||||
[(p s1 s2 ... r)
|
||||
(unless (procedure? p)
|
||||
($oops #f "attempt to apply non-procedure ~s" p))
|
||||
(let ([n ($list-length r who)])
|
||||
(case n
|
||||
[(0) (p s1 s2 ...)]
|
||||
[(1) (p s1 s2 ... (car r))]
|
||||
[(2) (p s1 s2 ... (car r) (cadr r))]
|
||||
[(3) (let ([y1 (cdr r)])
|
||||
(p s1 s2 ... (car r) (car y1) (cadr y1)))]
|
||||
[else ($apply p (fx+ n m) (list* s1 s2 ... r))]))]
|
||||
cl ...))])))
|
||||
(build-apply (x1 x2 x3 x4))))
|
||||
|
||||
(let ()
|
||||
(define length-error
|
||||
(lambda (who l1 l2)
|
||||
($oops who "lists ~s and ~s differ in length" l1 l2)))
|
||||
|
||||
(define nonprocedure-error
|
||||
(lambda (who what)
|
||||
($oops who "~s is not a procedure" what)))
|
||||
|
||||
(define length-check
|
||||
(lambda (who first rest)
|
||||
(let ([n ($list-length first who)])
|
||||
(let loop ([rest rest])
|
||||
(cond
|
||||
[(null? rest) n]
|
||||
[(fx= ($list-length (car rest) who) n) (loop (cdr rest))]
|
||||
[else (length-error who first (car rest))])))))
|
||||
|
||||
(define mutation-error
|
||||
(lambda (who)
|
||||
($oops who "input list was altered during operation")))
|
||||
|
||||
; getcxrs returns the cdrs of ls and their cars
|
||||
(define getcxrs
|
||||
(lambda (ls who)
|
||||
(if (null? ls)
|
||||
(values '() '())
|
||||
(let-values ([(cdrs cars) (getcxrs (cdr ls) who)])
|
||||
(let ([d (cdar ls)])
|
||||
(unless (pair? d) (mutation-error who))
|
||||
(values (cons d cdrs) (cons (car d) cars)))))))
|
||||
|
||||
(let ()
|
||||
(define-syntax do-ormap
|
||||
(syntax-rules ()
|
||||
[(_ who)
|
||||
(case-lambda
|
||||
[(f ls)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(and (not (null? ls))
|
||||
(let ormap ([n ($list-length ls who)] [ls ls])
|
||||
(if (fx= n 1)
|
||||
(f (car ls))
|
||||
(or (f (car ls))
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(ormap (fx- n 1) ls))))))]
|
||||
[(f ls . more)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(let ([n (length-check who ls more)])
|
||||
(and (not (fx= n 0))
|
||||
(let ormap ([n n] [ls ls] [more more] [cars (map car more)])
|
||||
(if (fx= n 1)
|
||||
(apply f (car ls) cars)
|
||||
(or (apply f (car ls) cars)
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(let-values ([(cdrs cars) (getcxrs more who)])
|
||||
(ormap (fx- n 1) ls cdrs cars))))))))])]))
|
||||
(set-who! ormap (do-ormap who))
|
||||
(set-who! exists (do-ormap who)))
|
||||
|
||||
(let ()
|
||||
(define-syntax do-andmap
|
||||
(syntax-rules ()
|
||||
[(_ who)
|
||||
(case-lambda
|
||||
[(f ls)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(or (null? ls)
|
||||
(let andmap ([n ($list-length ls who)] [ls ls])
|
||||
(if (fx= n 1)
|
||||
(f (car ls))
|
||||
(and (f (car ls))
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(andmap (fx- n 1) ls))))))]
|
||||
[(f ls . more)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(let ([n (length-check who ls more)])
|
||||
(or (fx= n 0)
|
||||
(let andmap ([n n] [ls ls] [more more] [cars (map car more)])
|
||||
(if (fx= n 1)
|
||||
(apply f (car ls) cars)
|
||||
(and (apply f (car ls) cars)
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(let-values ([(cdrs cars) (getcxrs more who)])
|
||||
(andmap (fx- n 1) ls cdrs cars))))))))])]))
|
||||
(set-who! andmap (do-andmap who))
|
||||
(set-who! for-all (do-andmap who)))
|
||||
|
||||
(set-who! map
|
||||
(case-lambda
|
||||
[(f ls)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
($list-length ls who)
|
||||
; library map cdrs first to avoid getting sick if f mutates input
|
||||
(#3%map f ls)]
|
||||
[(f ls1 ls2)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(unless (fx= ($list-length ls1 who) ($list-length ls2 who))
|
||||
(length-error who ls1 ls2))
|
||||
; library map cdrs first to avoid getting sick if f mutates input
|
||||
(#3%map f ls1 ls2)]
|
||||
[(f ls . more)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(length-check who ls more)
|
||||
(let map ([f f] [ls ls] [more more])
|
||||
(if (null? ls)
|
||||
'()
|
||||
; cdr first to avoid getting sick if f mutates input
|
||||
(let ([tail (map f (cdr ls) (#3%map cdr more))])
|
||||
(cons (apply f (car ls) (#3%map car more)) tail))))]))
|
||||
|
||||
(set! $map
|
||||
; same as map but errors are reported as coming from who
|
||||
(case-lambda
|
||||
[(who f ls)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
($list-length ls who)
|
||||
; library map cdrs first to avoid getting sick if f mutates input
|
||||
(#3%map f ls)]
|
||||
[(who f ls1 ls2)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(unless (fx= ($list-length ls1 who) ($list-length ls2 who))
|
||||
(length-error who ls1 ls2))
|
||||
; library map cdrs first to avoid getting sick if f mutates input
|
||||
(#3%map f ls1 ls2)]
|
||||
[(who f ls . more)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(length-check who ls more)
|
||||
(let map ([f f] [ls ls] [more more])
|
||||
(if (null? ls)
|
||||
'()
|
||||
; cdr first to avoid getting sick if f mutates input
|
||||
(let ([tail (map f (cdr ls) (#3%map cdr more))])
|
||||
(cons (apply f (car ls) (#3%map car more)) tail))))]))
|
||||
|
||||
(set-who! for-each
|
||||
(case-lambda
|
||||
[(f ls)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(unless (null? ls)
|
||||
(let for-each ([n ($list-length ls who)] [ls ls])
|
||||
(if (fx= n 1)
|
||||
(f (car ls))
|
||||
(begin
|
||||
(f (car ls))
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(for-each (fx- n 1) ls))))))]
|
||||
[(f ls . more)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(let ([n (length-check who ls more)])
|
||||
(unless (fx= n 0)
|
||||
(let for-each ([n n] [ls ls] [more more] [cars (map car more)])
|
||||
(if (fx= n 1)
|
||||
(apply f (car ls) cars)
|
||||
(begin
|
||||
(apply f (car ls) cars)
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(let-values ([(cdrs cars) (getcxrs more who)])
|
||||
(for-each (fx- n 1) ls cdrs cars))))))))]))
|
||||
|
||||
(set-who! fold-left
|
||||
(case-lambda
|
||||
[(combine nil ls)
|
||||
(unless (procedure? combine) (nonprocedure-error who combine))
|
||||
(cond
|
||||
[(null? ls) nil]
|
||||
[else
|
||||
($list-length ls who)
|
||||
(let fold-left ([ls ls] [acc nil])
|
||||
(let ([cdrls (cdr ls)])
|
||||
(if (pair? cdrls)
|
||||
(fold-left cdrls (combine acc (car ls)))
|
||||
(if (null? cdrls)
|
||||
(combine acc (car ls))
|
||||
(mutation-error who)))))])]
|
||||
[(combine nil ls . more)
|
||||
(unless (procedure? combine) (nonprocedure-error who combine))
|
||||
(length-check who ls more)
|
||||
(if (null? ls)
|
||||
nil
|
||||
(let fold-left ([ls ls] [more more] [cars (map car more)] [acc nil])
|
||||
(let ([cdrls (cdr ls)])
|
||||
(if (null? cdrls)
|
||||
(apply combine acc (car ls) cars)
|
||||
(let ([acc (apply combine acc (car ls) cars)])
|
||||
(unless (pair? cdrls) (mutation-error who))
|
||||
(let-values ([(cdrs cars) (getcxrs more who)])
|
||||
(fold-left cdrls cdrs cars acc)))))))]))
|
||||
|
||||
(set-who! fold-right
|
||||
(case-lambda
|
||||
[(combine nil ls)
|
||||
(unless (procedure? combine) (nonprocedure-error who combine))
|
||||
($list-length ls who)
|
||||
; #3%fold-right naturally does cdrs first to avoid mutation sickness
|
||||
(#3%fold-right combine nil ls)]
|
||||
[(combine nil ls1 ls2)
|
||||
(unless (procedure? combine) (nonprocedure-error who combine))
|
||||
(unless (fx= ($list-length ls1 who) ($list-length ls2 who))
|
||||
(length-error who ls1 ls2))
|
||||
; #3%fold-right naturally does cdrs first to avoid mutation sickness
|
||||
(#3%fold-right combine nil ls1 ls2)]
|
||||
[(combine nil ls . more)
|
||||
(unless (procedure? combine) (nonprocedure-error who combine))
|
||||
(length-check who ls more)
|
||||
(let fold-right ([combine combine] [nil nil] [ls ls] [more more])
|
||||
(if (null? ls)
|
||||
nil
|
||||
(apply combine (car ls)
|
||||
(#3%fold-right cons
|
||||
(list (fold-right combine nil (cdr ls) (map cdr more)))
|
||||
(map car more)))))]))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define disable/enable (make-winder #f disable-interrupts enable-interrupts))
|
||||
|
||||
(define (dwind in body out)
|
||||
(let ((old-winders ($current-winders)))
|
||||
(in)
|
||||
($current-winders (cons (make-winder #f in out) old-winders))
|
||||
(call-with-values
|
||||
body
|
||||
(case-lambda
|
||||
[(x)
|
||||
($current-winders old-winders)
|
||||
(out)
|
||||
x]
|
||||
[args
|
||||
($current-winders old-winders)
|
||||
(out)
|
||||
(apply values args)]))))
|
||||
|
||||
(define (cwind in body out)
|
||||
(let* ((old-winders ($current-winders))
|
||||
[d/e+old-winders (cons disable/enable old-winders)])
|
||||
(disable-interrupts)
|
||||
($current-winders d/e+old-winders)
|
||||
(in)
|
||||
($current-winders (cons (make-winder #t in out) old-winders))
|
||||
(enable-interrupts)
|
||||
(call-with-values
|
||||
body
|
||||
(case-lambda
|
||||
[(x)
|
||||
(disable-interrupts)
|
||||
($current-winders d/e+old-winders)
|
||||
(out)
|
||||
($current-winders old-winders)
|
||||
(enable-interrupts)
|
||||
x]
|
||||
[args
|
||||
(disable-interrupts)
|
||||
($current-winders d/e+old-winders)
|
||||
(out)
|
||||
($current-winders old-winders)
|
||||
(enable-interrupts)
|
||||
(apply values args)]))))
|
||||
|
||||
(define (check-args in body out)
|
||||
(unless (procedure? in)
|
||||
($oops 'dynamic-wind "~s is not a procedure" in))
|
||||
(unless (procedure? body)
|
||||
($oops 'dynamic-wind "~s is not a procedure" body))
|
||||
(unless (procedure? out)
|
||||
($oops 'dynamic-wind "~s is not a procedure" out)))
|
||||
|
||||
(set! dynamic-wind
|
||||
(case-lambda
|
||||
[(in body out)
|
||||
(check-args in body out)
|
||||
(dwind in body out)]
|
||||
[(critical? in body out)
|
||||
(check-args in body out)
|
||||
(if critical?
|
||||
(cwind in body out)
|
||||
(dwind in body out))]))
|
||||
|
||||
(set-who! #(r6rs: dynamic-wind)
|
||||
(lambda (in body out)
|
||||
(#2%dynamic-wind in body out)))
|
||||
|
||||
(set! $do-wind
|
||||
(lambda (old new)
|
||||
(define common-tail
|
||||
(lambda (x y)
|
||||
(let ([lx (length x)] [ly (length y)])
|
||||
(do ([x (if (fx> lx ly) (list-tail x (fx- lx ly)) x) (cdr x)]
|
||||
[y (if (fx> ly lx) (list-tail y (fx- ly lx)) y) (cdr y)])
|
||||
((eq? x y) x)))))
|
||||
(let ([tail (common-tail old new)])
|
||||
(let f ((old old))
|
||||
(unless (eq? old tail)
|
||||
(let ([w (car old)] [old (cdr old)])
|
||||
(if (winder-critical? w)
|
||||
(begin
|
||||
(disable-interrupts)
|
||||
($current-winders (cons disable/enable old))
|
||||
((winder-out w))
|
||||
($current-winders old)
|
||||
(enable-interrupts))
|
||||
(begin
|
||||
($current-winders old)
|
||||
((winder-out w))))
|
||||
(f old))))
|
||||
(let f ([new new])
|
||||
(unless (eq? new tail)
|
||||
(let ([w (car new)])
|
||||
(f (cdr new))
|
||||
(if (winder-critical? w)
|
||||
(begin
|
||||
(disable-interrupts)
|
||||
($current-winders (cons disable/enable (cdr new)))
|
||||
((winder-in w))
|
||||
($current-winders new)
|
||||
(enable-interrupts))
|
||||
(begin
|
||||
((winder-in w))
|
||||
($current-winders new)))))))))
|
||||
)
|
||||
|
||||
|
||||
;;; make-promise and force
|
||||
|
||||
(define-who $make-promise
|
||||
(lambda (thunk)
|
||||
(unless (procedure? thunk)
|
||||
($oops who "~s is not a procedure" thunk))
|
||||
(let ([value (void)] [set? #f])
|
||||
(lambda ()
|
||||
(case set?
|
||||
[(single) value]
|
||||
[(multiple) (apply values value)]
|
||||
[else
|
||||
(call-with-values
|
||||
thunk
|
||||
(case-lambda
|
||||
[(x)
|
||||
(case set?
|
||||
[(single) value]
|
||||
[(multiple) (apply values value)]
|
||||
[(#f) (set! value x)
|
||||
(set! set? 'single)
|
||||
x])]
|
||||
[x
|
||||
(case set?
|
||||
[(single) value]
|
||||
[(multiple) (apply values value)]
|
||||
[(#f) (set! value x)
|
||||
(set! set? 'multiple)
|
||||
(apply values x)])]))])))))
|
||||
|
||||
(define-who force
|
||||
(lambda (promise)
|
||||
(unless (procedure? promise)
|
||||
($oops who "~s is not a procedure" promise))
|
||||
(promise)))
|
||||
)
|
||||
Reference in a new issue