forked from samirose/sicp-compiler-project
-
Notifications
You must be signed in to change notification settings - Fork 0
/
scheme-syntax.sls
106 lines (94 loc) · 3.92 KB
/
scheme-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
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
#!r6rs
;; Adapted from SICP ch5-syntax.scm
(library
(scheme-syntax)
(export variable?
definition? definition-variable
check-binding
check-all-identifiers check-syntax-errors)
(import (rnrs base)
(rnrs lists)
(pattern-match)
(compilation-error))
(define (raise-error-on-match pat exp message object)
(if (pattern-match? pat exp)
(raise-compilation-error message object)
#f))
;; assignment
(define (variable? exp) (symbol? exp))
(define (not-variable? exp) (not (variable? exp)))
;; syntax errors
(define syntax-error-patterns
`(
;; quote
((quote) "Too few operands")
((quote ,?? ,?? ,??*) "Too many operands")
;; assignment
((set!) "Variable and value missing from assignment")
((set! ,??) "Variable or value missing from assignment")
((set! ,?? ,?? ,?? ,??*) "Too many operands to assignment")
((set! ,not-variable? ,??) "Invalid variable in assignment")
;: lambda expression
((lambda) "Arguments and body missing from lambda expression")
((lambda ,??) "Body missing from lambda expression")
((lambda ,?? ,??) "Arguments list missing from lambda expression")
;: definition
((define) "Variable and value missing from definition")
((define (,?? ,??*)) "Empty body in procedure definition")
((define ,??) "Variable or value missing from definition")
((define ,variable? ,?? ,?? ,??*) "Too many operands to variable definition")
((define () ,??*) "Variable missing from procedure definition")
((define (,not-variable? ,??*) ,??*) "Not an identifier in variable position")
((define ,not-variable? ,??) "Not an identifier in variable position")
((define ,?? ,?? ,?? ,??*) "Not a variable or procedure definition")
;; if expression
((if) "Test and consequent missing from if expression")
((if ,??) "Consequent missing from if expression")
((if ,?? ,?? ,?? ,??*) "Too many subexpressions in if expression")
;; not expression
((not) "Argument missing from not expression")
((not ,?? ,??*) "Too many arguments in not expression")
;; let expressions
((let () ,?? ,??*) "Empty bindings in let expression")
((let ,?? ,?? ,??*) "Bindings missing from let expression")
((let ,??) "Bindings or body missing from let expression")
((let) "Bindings and body missing from let expression")
((let* () ,?? ,??*) "Empty bindings in let* expression")
((let* ,?? ,?? ,??*) "Bindings missing from let* expression")
((let* ,??) "Bindings or body missing from let* expression")
((let*) "Bindings and body missing from let* expression")
((begin) "Empty sequence")
(() "No operator in application")))
(define (check-syntax-errors exp)
(for-each
(lambda (pattern-and-message)
(raise-error-on-match (car pattern-and-message) exp (cadr pattern-and-message) exp))
syntax-error-patterns)
#f)
(define (check-all-identifiers exps)
(cond ((null? exps))
((variable? (car exps)) (check-all-identifiers (cdr exps)))
(else (raise-compilation-error "Not an identifier" (car exps)))))
;; definition
(define (definition? exp)
(or (pattern-match? `(define ,variable? ,??*) exp)
(pattern-match? `(define (,variable? ,??*) ,??*) exp)))
(define (definition-variable exp)
(if (pattern-match? `(define ,variable? ,??) exp)
(cadr exp)
(caadr exp)))
;; let expression
(define (check-binding exp)
(cond ((pattern-match? `(,variable? ,??) exp))
((not (pattern-match? `(,??*) exp))
(raise-compilation-error "Not a binding" exp))
((raise-error-on-match
`(,?? ,??) exp "Not an identifier" (car exp)))
((raise-error-on-match
`(,variable?) exp "Value missing from binding" exp))
((raise-error-on-match
`(,variable? ,?? ,?? ,??*) exp "Too many operands in binding" exp))
((raise-error-on-match
'() exp "Empty binding" exp))
(else (raise-compilation-error "Not a binding" exp))))
)