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 expansion-backtrace (make-parameter 5)) ; #f or fixnum 6(define expansion-trace-stack (make-parameter '())) 7(define expansion-trace-level (make-parameter 0)) 8(define current-immutable-identifiers (make-parameter #f)) 9(define current-expansion-mode (make-parameter '())) 10(define current-expansion-environment (make-parameter '())) 11(define current-macro-expression (make-parameter #f)) 12(define current-transformer-environment (make-parameter '())) 13(define unexpect-top-level-form (make-parameter #f)) 14(define current-after-expansion-hook (make-parameter (lambda (form annotate annotate-closure) form))) 15(define current-temporary-count (make-parameter 0)) 16(define current-rename-count (make-parameter 0)) 17(define current-temporaries (make-parameter #f)) 18(define current-closure-comments (make-parameter #f)) 19(define current-top-level-exterior (make-parameter #f)) 20 21(set-top-level-value! '.set-top-level-macro! 22 (lambda (type keyword datum env) 23 (and (top-level-bound? keyword) (set-top-level-value! keyword .&UNDEF)) 24 (core-hashtable-set! (current-macro-environment) 25 keyword 26 (case type 27 ((syntax) 28 (make-macro datum env)) 29 ((variable) 30 (cond ((procedure? datum) 31 (make-macro-variable datum env)) 32 ((variable-transformer-token? datum) 33 (make-macro-variable (tuple-ref datum 1) env)) 34 (else 35 (scheme-error "internal error in .set-top-level-macro!: bad transformer type:~s keyword:~s datum:~s" type keyword datum)))))))) 36 37(define core-primitive-name 38 (lambda (e) 39 (string->symbol (format "~a~a" (current-primitive-prefix) e)))) 40 41(define generate-global-id 42 (lambda (library-id symbol) 43 (string->symbol (format "~a~a~a" library-id (current-library-suffix) symbol)))) 44 45(define make-temporary-symbol 46 (lambda (name prefix) 47 (let ((temps (current-temporaries))) 48 (or (core-hashtable-ref temps name #f) 49 (let ((new (string->uninterned-symbol name prefix))) 50 (core-hashtable-set! temps name new) 51 new))))) 52 53(define generate-temporary-symbol 54 (lambda () 55 (let ((count (current-temporary-count))) 56 (current-temporary-count (+ count 1)) 57 (let ((name (format ".L~a" count))) 58 (make-temporary-symbol name (string-length name)))))) 59 60(define generate-local-macro-symbol 61 (lambda (id) 62 (let ((count (current-temporary-count))) 63 (current-temporary-count (+ count 1)) 64 (make-temporary-symbol (format ".MACRO~a.~a" count id) 6)))) 65 66(define local-macro-symbol? 67 (lambda (id) 68 (and (uninterned-symbol? id) (string=? (uninterned-symbol-prefix id) ".MACRO")))) 69 70(define rename-id 71 (lambda (id count) 72 (if (uninterned-symbol? id) 73 (make-temporary-symbol (format "~a~a~a" id (current-rename-delimiter) count) (string-length (uninterned-symbol-prefix id))) 74 (make-temporary-symbol (format "~a~a~a" id (current-rename-delimiter) count) (string-length (symbol->string id)))))) 75 76(define renamed-id? 77 (lambda (id) 78 (and (uninterned-symbol? id) 79 (string-contains (uninterned-symbol-suffix id) (current-rename-delimiter))))) 80 81(define rename-variable-id 82 (lambda (id count) 83 (if (uninterned-symbol? id) 84 (make-temporary-symbol (format "~a~a~a*" id (current-rename-delimiter) count) (string-length (uninterned-symbol-prefix id))) 85 (make-temporary-symbol (format "~a~a~a*" id (current-rename-delimiter) count) (string-length (symbol->string id)))))) 86 87(define renamed-variable-id? 88 (lambda (id) 89 (and (uninterned-symbol? id) 90 (string-contains (uninterned-symbol-suffix id) (current-rename-delimiter)) 91 (string-contains (uninterned-symbol-suffix id) #\*)))) 92 93(define compose-id 94 (lambda (id suffix) 95 (if (uninterned-symbol? id) 96 (make-temporary-symbol (format "~a~a" id suffix) (string-length (uninterned-symbol-prefix id))) 97 (make-temporary-symbol (format "~a~a" id suffix) (string-length (symbol->string id)))))) 98 99(define original-id 100 (lambda (id) 101 (if (renamed-id? id) (string->symbol (uninterned-symbol-prefix id)) id))) 102 103(define strip-rename-suffix 104 (lambda (lst) 105 (if (cyclic-object? lst) 106 lst 107 (let loop ((lst lst)) 108 (cond ((pair? lst) 109 (let ((a (loop (car lst))) (d (loop (cdr lst)))) 110 (if (and (eq? a (car lst)) (eq? d (cdr lst))) lst (cons a d)))) 111 ((symbol? lst) 112 (original-id lst)) 113 ((vector? lst) 114 (list->vector (map loop (vector->list lst)))) 115 (else lst)))))) 116 117(define retrieve-rename-suffix 118 (lambda (id) 119 (cond ((renamed-id? id) (uninterned-symbol-suffix id)) 120 (else "")))) 121 122(define fresh-rename-count 123 (lambda () 124 (current-rename-count (+ (current-rename-count) 1)) 125 (current-rename-count))) 126 127(define set-closure-comment! 128 (lambda (form note) 129 (and (current-closure-comments) 130 (core-hashtable-set! (current-closure-comments) form (cons 'heap note))))) 131 132(define annotate-closure 133 (lambda (form source . attr) 134 (and (current-closure-comments) 135 (cond ((core-hashtable-ref (current-closure-comments) source #f) 136 => (lambda (note) 137 (if (null? attr) 138 (core-hashtable-set! (current-closure-comments) form note) 139 (core-hashtable-set! (current-closure-comments) form (cons (car attr) (cdr note)))))))))) 140 141(define annotated? 142 (lambda (form) 143 (and (current-source-comments) 144 (core-hashtable-ref (current-source-comments) form #f) 145 #t))) 146 147(define get-annotation 148 (lambda (form) 149 (and (pair? form) 150 (current-source-comments) 151 (core-hashtable-ref (current-source-comments) form #f)))) 152 153(define put-annotation 154 (lambda (form note) 155 (and (pair? form) 156 (current-source-comments) 157 (core-hashtable-set! (current-source-comments) form note)) 158 form)) 159 160(define annotate 161 (lambda (form source) 162 163 (define put-note! 164 (lambda (form note) 165 (and note 166 (let loop ((lst form)) 167 (and (list? lst) 168 (or (core-hashtable-ref (current-source-comments) lst #f) 169 (begin 170 (core-hashtable-set! (current-source-comments) lst note) 171 (for-each loop lst)))))))) 172 173 (define get-note 174 (lambda (source) 175 (let loop ((lst source)) 176 (and (pair? lst) 177 (or (core-hashtable-ref (current-source-comments) lst #f) 178 (loop (car lst)) 179 (loop (cdr lst))))))) 180 181 (and (pair? form) 182 (pair? source) 183 (not (eq? form source)) 184 (begin 185 (cond ((and (current-source-comments) (get-note source)) 186 => (lambda (e) (put-note! form e)))) 187 (cond ((and (current-closure-comments) (core-hashtable-ref (current-closure-comments) source #f)) 188 => (lambda (e) (core-hashtable-set! (current-closure-comments) form e)))))) 189 form)) 190 191(define abbreviated-take 192 (lambda (form n) 193 (annotate 194 (let loop ((lst form) (n n)) 195 (cond ((not (pair? lst)) lst) 196 ((<= n 0) (list '...)) 197 (else (cons (car lst) (loop (cdr lst) (- n 1)))))) 198 form))) 199 200(define abbreviated-take-form 201 (lambda (form ncar ncdr) 202 (annotate 203 (let loop ((lst form) (na ncar) (nd ncdr)) 204 (cond ((not (pair? lst)) lst) 205 ((or (<= na 0) (<= nd 0)) (list '...)) 206 (else (cons (loop (car lst) (- na 1) nd) (loop (cdr lst) ncar (- nd 1)))))) 207 form))) 208