blob: f400a3e93ca10b0c4a6270c4bfe5f3f1de825d46 (
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
|
;;; Copyright (C) Peter McGoron 2024
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, version 3 of the License.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;;
;;; Simple COND-EXPAND using SYNTAX-RULES. Designed for chez.
(define-syntax cond-expand-conditional
(syntax-rules (and or not chez r6rs)
;; Defined keywords
((cond-expand-conditional chez execute alt) execute)
((cond-expand-conditional r6rs execute alt) execute)
;; Conditional statements: AND
((cond-expand-conditional (and e1 e2 ...) execute alt)
(cond-expand-conditional e1
(cond-expand-conditional
(and e2 ...)
execute
alt)
alt))
((cond-expand-conditional (and) execute alt) execute)
;; OR
((cond-expand-conditional (or e1 e2 ...) execute alt)
(cond-expand-conditional e1 execute
(cond-expand-conditional
(or e2 ...) execute alt)))
((cond-expand-conditional (or) execute alt) alt)
;; NOT
((cond-expand-conditional (not e) execute alt)
(cond-expand-conditional e alt execute))
;; All other conditions
((cond-expand-conditional unknown execute alt) alt)))
(define-syntax cond-expand
(syntax-rules (else)
((cond-expand (else evaluated ...)) (begin evaluated ...))
((cond-expand (conditional evaluated ...) rest ...)
(cond-expand-conditional conditional
(begin evaluated ...)
(cond-expand rest ...)))))
(define %r6rs-error error)
(define (error . rest)
(apply %r6rs-error (cons "UNSLISP" rest)))
|
