1;;; Ypsilon Scheme System
2;;; Copyright (c) 2004-2008 Y.FUJITA, LittleWing Company Limited.
3;;; See license.txt for terms and conditions of use.
4
5(define expand-lambda
6  (lambda (form env)
7    (cond ((> (safe-length form) 2)
8           (let ((vars (collect-lambda-formals (cadr form) form)))
9             (let* ((suffix (fresh-rename-count))
10                    (renames (map cons vars (map (lambda (id) (rename-variable-id id suffix)) vars)))
11                    (body (expand-body form (cddr form) (extend-env renames env))))
12               (if (null? body)
13                   (syntax-violation 'lambda "empty body" form)
14                   (annotate `(lambda ,(rename-lambda-formals (cadr form) renames) ,@body) form)))))
15          (else
16           (syntax-violation 'lambda "expected formals and body" form)))))
17
18(define expand-quote
19  (lambda (form env)
20    (if (= (safe-length form) 2)
21        (annotate `(quote ,(strip-rename-suffix (cadr form))) form)
22        (syntax-violation 'quote "expected single datum" form))))
23
24(define expand-begin
25  (lambda (form env)
26    (and (unexpect-top-level-form)
27         (or (pair? (cdr form))
28             (syntax-violation 'begin "misplaced empty begin" form)))
29    (annotate `(begin ,@(flatten-begin (expand-each (cdr form) env) env)) form)))
30
31(define expand-if
32  (lambda (form env)
33    (annotate (destructuring-match form
34                ((_ test expr)
35                 `(if ,(expand-form test env)
36                      ,(expand-form expr env)))
37                ((_ test expr1 expr2)
38                 `(if ,(expand-form test env)
39                      ,(expand-form expr1 env)
40                      ,(expand-form expr2 env)))
41                (_
42                 (syntax-violation 'if "expected 2 or 3 expressions" form)))
43              form)))
44
45(define expand-set!
46  (lambda (form env)
47    (destructuring-match form
48      ((_ (? symbol? name) expr)
49       (let ((deno (env-lookup env name)))
50         (cond ((macro-variable? deno)
51                (let-values (((expr renames) (expand-macro-use form env deno)))
52                  (expand-form expr (extend-env renames env))))
53               ((or (special? deno) (macro? deno))
54                (syntax-violation 'set! "misplaced syntactic keyword as variable" form))
55               (else
56                (let ((var (expand-form name env)))
57                  (and (core-hashtable-contains? immutable-primitives var)
58                       (syntax-violation 'set! "attempt to modify immutable variable" form))
59                  (and (current-immutable-identifiers)
60                       (not (renamed-id? var))
61                       (core-hashtable-ref (current-immutable-identifiers) name #f)
62                       (syntax-violation 'set! "attempt to modify immutable variable" form))
63                  (let ((body (expand-form expr env)))
64                    (and (pair? body)
65                         (denote-lambda? env (car body))
66                         (set-closure-comment! body (original-id var)))
67                    (annotate `(set! ,var ,body) form)))))))
68      (_
69       (syntax-violation 'set! "expected variable and single expression" form)))))
70
71(define expand-let-syntax
72  (lambda (form env)
73    (destructuring-match form
74      ((_ bindings body ...)
75       (begin
76         (and (null? body) (syntax-violation (car form) "missing body" form))
77         (check-let-bindings form bindings)
78         (fresh-rename-count)
79         (expand-form `(.BEGIN ,@body) (expand-let-syntax-bindings form bindings env))))
80      (_
81       (syntax-violation (car form) "expected bindings and body" form)))))
82
83(define expand-letrec-syntax
84  (lambda (form env)
85    (destructuring-match form
86      ((_ bindings body ...)
87       (begin
88         (and (null? body) (syntax-violation (car form) "missing body" form))
89         (check-let-bindings form bindings)
90         (fresh-rename-count)
91         (expand-form `(.BEGIN ,@body) (expand-letrec-syntax-bindings form bindings env))))
92      (_
93       (syntax-violation (car form) "expected bindings and body" form)))))
94
95(define expand-define-syntax
96  (lambda (form env)
97    (and (unexpect-top-level-form)
98         (syntax-violation (car form) "misplaced definition" form))
99    (destructuring-match form
100      ((_ (? symbol? name) body)
101       (begin
102         (parameterize ((unexpect-top-level-form #t))
103           (let-values (((code . expr) (compile-macro form body env)))
104             (if (macro-variable? code)
105                 (.set-top-level-macro! 'variable name (cadr code) env)
106                 (.set-top-level-macro! 'syntax name code env))))
107         (env-delete! env name)
108         '(begin)))
109      (_
110       (syntax-violation (car form) "expected symbol and single expression" form)))))
111
112(define expand-define
113  (lambda (form env)
114
115    (define immutable?
116      (lambda (id)
117        (or (core-hashtable-contains? immutable-primitives id)
118            (memq id '(library define define-syntax
119                        quote lambda if set!
120                        cond case and or let let* letrec letrec*
121                        let-values let*-values
122                        begin quasiquote unquote unquote-splicing
123                        let-syntax letrec-syntax syntax-rules identifier-syntax
124                        assert else => ... _)))))
125
126    (define let?
127      (lambda (id)
128        (denote-let? env id)))
129
130    (and (unexpect-top-level-form)
131         (syntax-violation (car form) "misplaced definition" form))
132    (destructuring-match (desugar-define form)
133      ((_ name body)
134       (begin
135         (and (immutable? name)
136              (syntax-violation (car form) "attempt to modify immutable binding" form))
137         (let ((body (parameterize ((unexpect-top-level-form #t) (current-top-level-exterior name))
138                       (expand-form body env))))
139           (destructuring-match body
140             (((? let? _) _ e1)
141              (set-closure-comment! e1 (original-id name)))
142             (_
143              (set-closure-comment! body (original-id name))))
144           (core-hashtable-delete! (current-macro-environment) name)
145           (env-delete! env name)
146           (annotate `(define ,name ,body) form)))))))
147