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