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