forked from samirose/sicp-compiler-project
-
Notifications
You must be signed in to change notification settings - Fork 0
/
scheme-r7rs-syntax.sls
62 lines (55 loc) · 2.12 KB
/
scheme-r7rs-syntax.sls
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
#!r6rs
(library
(scheme-r7rs-syntax)
(export r7rs-library?
check-library-declarations
library-declaration
library-declarations)
(import (rnrs base)
(rnrs lists)
(pattern-match)
(compilation-error))
(define (r7rs-library? exp)
(pattern-match? `(define-library ,??*) exp))
(define library-decltypes
'(export begin))
(define (library-decltype? type)
(and (memq type library-decltypes) #t))
(define (check-library-declarations library-def)
(letrec*
((check-declaration
(lambda (decl)
(cond ((pattern-match? `(,library-decltype? ,??*) decl) 'ok)
((pattern-match? `(,(lambda (d) (not (library-decltype? d))) ,??*) decl)
(make-compilation-error "Unsupported R7RS library declaration" decl))
((not (pattern-match? `(,?? ,??*) decl))
(make-compilation-error "Illegal R7RS library declaration" decl)))))
(check-all-lists-and-types
(lambda (decls)
(cond ((null? decls) 'ok)
((check-declaration (car decls)))
(else (check-all-lists-and-types (cdr decls))))))
(check-decl-ordering
(lambda (types decls)
(cond ((null? decls) 'ok)
((null? types)
(or (null? decls)
(make-compilation-error "Duplicated R7RS library declarations" decls)))
((not (eq? (caar decls) (car types)))
(make-compilation-error "Unexpected R7RS library declaration" (car decls)))
(else (check-decl-ordering (cdr types) (cdr decls))))))
(library-declarations (cdr library-def))
(first-result (check-all-lists-and-types library-declarations)))
(if (compilation-error? first-result)
first-result
(check-decl-ordering
(filter
(lambda (type) (assq type library-declarations))
library-decltypes)
library-declarations))))
(define (library-declaration type library-def)
(assq type (cdr library-def)))
(define (library-declarations type library-def)
(let ((decl (library-declaration type library-def)))
(if decl (cdr decl) '())))
)