blob: 2833de4e66084e3a64469be57987de5eb296ce66 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
#| Copyright 2024 Peter McGoron
|
| 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.
|#
(define-syntax cond-values
(syntax-rules (else)
((cond-values clauses ... (else body ...))
(cond-thunk clauses ... (else body ...)))
((cond-values clauses ...)
(cond-thunk clauses ... (else (values))))))
(define-syntax %after
(syntax-rules (on-fail! %lambda %body when let =>)
((_ old-abort %lambda ((on-fail! on-error) clauses ...) body ...)
(lambda ()
(let ((abort (lambda () on-error)))
(%after abort %body (clauses ...) body ...))))
((_ old-abort %body ((on-fail! on-error) clauses ...) body ...)
(let ((abort (lambda () on-error)))
(%after abort %body (clauses ...) body ...)))
((_ abort action ((when conditional) clauses ...) body ...)
(if conditional
(%after abort action (clauses ...) body ...)
(abort)))
((_ abort action ((let value => formal) clauses ...) body ...)
(case-receive value
(() (abort))
(formal (%after abort action (clauses ...) body ...))))
((_ abort %lambda () body ...)
(lambda () body ...))
((_ abort %body () body ...)
(begin body ...))))
(define-syntax after
(syntax-rules ()
((after (clauses ...) body ...)
(let ((abort (lambda () #f)))
(%after abort %lambda (clauses ...) body ...)))))
(define-syntax receive-ct
(syntax-rules ()
((receive-ct formal generator body ...)
(after ((let generator => formal))
body ...))))
(define-syntax apply-after
(syntax-rules ()
((apply-after producer consumer)
(after ((let producer => formal))
(apply consumer formal)))))
(define (pair=> x)
(cond-values
(after ((when (pair? x)))
(values (car x) (cdr x)))))
(define (list-length-destructor whole-list num kont)
(cond-thunk
(when-ct (not (integer? num))
(error "must be integer" num))
(when-ct (not (positive? num))
(error "must be positive" num))
(else
(let loop ((iterator whole-list)
(collected '())
(num num))
(cond-values
(after ((when (= num 0)))
(kont collected iterator))
(after ((let (pair=> iterator) => (head rest)))
(loop rest (cons head collected) (- num 1))))))))
(define (length-at-least=> whole-list num)
(list-length-destructor whole-list num
(lambda (reverse-seen rest)
(cond-values
(when-ct (or (null? rest) (pair? rest))
(apply values
(reverse (cons rest reverse-seen))))))))
(define (length=> whole-list num)
(list-length-destructor whole-list num
(lambda (_ rest)
(cond-values
(when-ct (null? rest)
(apply values whole-list))))))
(define-syntax define-record-type/destructor
(syntax-rules ()
((_ type-name cstr predicate? destructor=>
(arg-name accessor setter ...)
...)
(begin
(define-record-type type-name
cstr
predicate?
(arg-name accessor setter ...)
...)
(define (destructor=> record)
(cond-values
(after ((when (predicate? record)))
(values (accessor record) ...))))))))
(define-syntax evaluate-destructor-to-boolean
(syntax-rules ()
((_ destructor)
(case-receive destructor
(() #f)
(_ #t)))))
|
