1 ;;; Guile VM code converters
3 ;; Copyright (C) 2001, 2009, 2012 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 (define-module (language scheme decompile-tree-il)
22 #:use-module (language tree-il)
23 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-26)
25 #:use-module (ice-9 receive)
26 #:use-module (ice-9 vlist)
27 #:use-module (ice-9 match)
28 #:use-module (system base syntax)
29 #:export (decompile-tree-il))
31 (define (decompile-tree-il e env opts)
32 (apply do-decompile e env opts))
34 (define* (do-decompile e env
36 (use-derived-syntax? #t)
39 (strip-numeric-suffixes? #f)
42 (receive (output-name-table occurrence-count-table)
43 (choose-output-names e use-derived-syntax? strip-numeric-suffixes?)
45 (define (output-name s) (hashq-ref output-name-table s))
46 (define (occurrence-count s) (hashq-ref occurrence-count-table s))
48 (define (const x) (lambda (_) x))
49 (define (atom? x) (not (or (pair? x) (vector? x))))
51 (define (build-void) '(if #f #f))
53 (define (build-begin es)
59 (define (build-lambda-body e)
61 (('let () body ...) body)
65 (define (build-begin-body e)
70 (define (build-define name e)
72 ((? (const avoid-lambda?)
73 ('lambda formals body ...))
74 `(define (,name ,@formals) ,@body))
75 ((? (const avoid-lambda?)
76 ('lambda* formals body ...))
77 `(define* (,name ,@formals) ,@body))
78 (_ `(define ,name ,e))))
80 (define (build-let names vals body)
81 (match `(let ,(map list names vals)
82 ,@(build-lambda-body body))
84 ((_ (b) ('let* (bs ...) body ...))
85 `(let* (,b ,@bs) ,@body))
86 ((? (const use-derived-syntax?)
87 (_ (b1) ('let (b2) body ...)))
88 `(let* (,b1 ,b2) ,@body))
91 (define (build-letrec in-order? names vals body)
92 (match `(,(if in-order? 'letrec* 'letrec)
93 ,(map list names vals)
94 ,@(build-lambda-body body))
96 ((_ () body ...) `(let () ,@body))
97 ((_ ((name ('lambda (formals ...) body ...)))
100 (if (= (length formals) (length args))
101 `(let ,name ,(map list formals args) ,@body)
103 ((? (const avoid-lambda?)
104 ('letrec* _ body ...))
106 ,@(map build-define names vals)
110 (define (build-if test consequent alternate)
112 (('if #f _) `(if ,test ,consequent))
113 (_ `(if ,test ,consequent ,alternate))))
115 (define (build-and xs)
121 (define (build-or xs)
127 (define (case-test-var test)
129 (('memv (? atom? v) ('quote (datums ...)))
131 (('eqv? (? atom? v) ('quote datum))
135 (define (test->datums v test)
137 ((v 'memv v ('quote (xs ...)))
139 ((v 'eqv? v ('quote x))
143 (define (build-else-tail e)
146 (('and xs ... x) `((,(build-and xs) ,@(build-begin-body x))
148 (_ `((else ,@(build-begin-body e))))))
150 (define (build-cond-else-tail e)
152 (('cond clauses ...) clauses)
153 (_ (build-else-tail e))))
155 (define (build-case-else-tail v e)
157 ((v 'case v clauses ...)
159 ((v 'if ('memv v ('quote (xs ...))) consequent . alternate*)
160 `((,xs ,@(build-begin-body consequent))
161 ,@(build-case-else-tail v (build-begin alternate*))))
162 ((v 'if ('eqv? v ('quote x)) consequent . alternate*)
163 `(((,x) ,@(build-begin-body consequent))
164 ,@(build-case-else-tail v (build-begin alternate*))))
165 (_ (build-else-tail e))))
167 (define (clauses+tail clauses)
169 ((cs ... (and c ('else . _))) (values cs (list c)))
170 (_ (values clauses '()))))
172 (define (build-cond tests consequents alternate)
175 ((1) (build-if (car tests) (car consequents) alternate))
176 (else `(cond ,@(map (lambda (test consequent)
177 `(,test ,@(build-begin-body consequent)))
179 ,@(build-cond-else-tail alternate)))))
181 (define (build-cond-or-case tests consequents alternate)
183 (build-cond tests consequents alternate)
184 (let* ((v (and (not (null? tests))
185 (case-test-var (car tests))))
186 (datum-lists (take-while identity
187 (map (cut test->datums v <>)
189 (n (length datum-lists))
190 (tail (build-case-else-tail v (build-cond
194 (receive (clauses tail) (clauses+tail tail)
195 (let ((n (+ n (length clauses)))
196 (datum-lists (append datum-lists
198 (consequents (append consequents
200 (map cdr clauses)))))
202 (build-cond tests consequents alternate)
204 ,@(map cons datum-lists (map build-begin-body
205 (take consequents n)))
210 (define (recurse-body e)
211 (build-lambda-body (recurse e)))
218 (if (and (self-evaluating? exp) (not (vector? exp)))
223 (build-begin (cons (recurse head)
228 (match `(,(recurse proc) ,@(map recurse args))
229 ((('lambda (formals ...) body ...) args ...)
231 (if (= (length formals) (length args))
232 (build-let formals args (build-begin body))
236 ((<primcall> name args)
237 `(,name ,@(map recurse args)))
239 ((<primitive-ref> name)
242 ((<lexical-ref> gensym)
243 (output-name gensym))
245 ((<lexical-set> gensym exp)
246 `(set! ,(output-name gensym) ,(recurse exp)))
248 ((<module-ref> mod name public?)
249 `(,(if public? '@ '@@) ,mod ,name))
251 ((<module-set> mod name public? exp)
252 `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp)))
254 ((<toplevel-ref> name)
257 ((<toplevel-set> name exp)
258 `(set! ,name ,(recurse exp)))
260 ((<toplevel-define> name exp)
261 (build-define name (recurse exp)))
263 ((<lambda> meta body)
264 (let ((body (recurse body))
265 (doc (assq-ref meta 'documentation)))
269 (('lambda formals body ...)
270 `(lambda ,formals ,doc ,@body))
271 (('lambda* formals body ...)
272 `(lambda* ,formals ,doc ,@body))
273 (('case-lambda (formals body ...) clauses ...)
274 `(case-lambda (,formals ,doc ,@body) ,@clauses))
275 (('case-lambda* (formals body ...) clauses ...)
276 `(case-lambda* (,formals ,doc ,@body) ,@clauses))
279 ((<lambda-case> req opt rest kw inits gensyms body alternate)
280 (let ((names (map output-name gensyms)))
282 ((and (not opt) (not kw) (not alternate))
283 `(lambda ,(if rest (apply cons* names) names)
284 ,@(recurse-body body)))
285 ((and (not opt) (not kw))
286 (let ((alt-expansion (recurse alternate))
287 (formals (if rest (apply cons* names) names)))
288 (case (car alt-expansion)
290 `(case-lambda (,formals ,@(recurse-body body))
291 ,(cdr alt-expansion)))
293 `(case-lambda* (,formals ,@(recurse-body body))
294 ,(cdr alt-expansion)))
296 `(case-lambda (,formals ,@(recurse-body body))
297 ,@(cdr alt-expansion)))
299 `(case-lambda* (,formals ,@(recurse-body body))
300 ,@(cdr alt-expansion))))))
302 (let* ((alt-expansion (and alternate (recurse alternate)))
304 (nopt (if opt (length opt) 0))
305 (restargs (if rest (list-ref names (+ nreq nopt)) '()))
306 (reqargs (list-head names nreq))
310 (list-head (list-tail names nreq) nopt)
312 (list-head inits nopt))))
317 (map output-name (map caddr (cdr kw)))
319 (list-tail inits nopt))
322 '(#:allow-other-keys)
325 (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
326 (if (not alt-expansion)
327 `(lambda* ,formals ,@(recurse-body body))
328 (case (car alt-expansion)
330 `(case-lambda* (,formals ,@(recurse-body body))
331 ,(cdr alt-expansion)))
332 ((case-lambda case-lambda*)
333 `(case-lambda* (,formals ,@(recurse-body body))
334 ,@(cdr alt-expansion))))))))))
336 ((<conditional> test consequent alternate)
337 (define (simplify-test e)
339 (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b)))
341 (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs ...))))
342 `(memv ,v '(,a ,@bs)))
345 ('else ('eqv? v ('quote last-datum))))
346 `(memv ,v '(,@datum ,last-datum)))
348 (match `(if ,(simplify-test (recurse test))
349 ,(recurse consequent)
350 ,@(if (void? alternate) '()
351 (list (recurse alternate))))
352 (('if test ('if ('and xs ...) consequent))
353 (build-if (build-and (cons test xs))
356 ((? (const use-derived-syntax?)
357 ('if test1 ('if test2 consequent)))
358 (build-if (build-and (list test1 test2))
361 (('if (? atom? x) x ('or ys ...))
362 (build-or (cons x ys)))
363 ((? (const use-derived-syntax?)
364 ('if (? atom? x) x y))
365 (build-or (list x y)))
366 (('if test consequent)
367 `(if ,test ,consequent))
368 (('if test ('and xs ...) #f)
369 (build-and (cons test xs)))
370 ((? (const use-derived-syntax?)
371 ('if test consequent #f))
372 (build-and (list test consequent)))
373 ((? (const use-derived-syntax?)
374 ('if test1 consequent1
375 ('if test2 consequent2 . alternate*)))
376 (build-cond-or-case (list test1 test2)
377 (list consequent1 consequent2)
378 (build-begin alternate*)))
379 (('if test consequent ('cond clauses ...))
380 `(cond (,test ,@(build-begin-body consequent))
382 (('if ('memv (? atom? v) ('quote (xs ...))) consequent
383 ('case v clauses ...))
384 `(case ,v (,xs ,@(build-begin-body consequent))
386 (('if ('eqv? (? atom? v) ('quote x)) consequent
387 ('case v clauses ...))
388 `(case ,v ((,x) ,@(build-begin-body consequent))
392 ((<let> gensyms vals body)
393 (match (build-let (map output-name gensyms)
396 (('let ((v e)) ('or v xs ...))
398 (if (and (not (null? gensyms))
399 (= 3 (occurrence-count (car gensyms))))
402 (('let ((v e)) ('case v clauses ...))
404 (if (and (not (null? gensyms))
405 ;; FIXME: This fails if any of the 'memv's were
406 ;; optimized into multiple 'eqv?'s, because the
407 ;; occurrence count will be higher than we expect.
408 (= (occurrence-count (car gensyms))
409 (1+ (length (clauses+tail clauses)))))
414 ((<letrec> in-order? gensyms vals body)
415 (build-letrec in-order?
416 (map output-name gensyms)
420 ((<fix> gensyms vals body)
421 ;; not a typo, we really do translate back to letrec. use letrec* since it
422 ;; doesn't matter, and the naive letrec* transformation does not require an
425 (map output-name gensyms)
429 ((<let-values> exp body)
430 `(call-with-values (lambda () ,@(recurse-body exp))
431 ,(recurse (make-lambda #f '() body))))
433 ((<dynwind> body winder unwinder)
434 `(dynamic-wind ,(recurse winder)
435 (lambda () ,@(recurse-body body))
436 ,(recurse unwinder)))
438 ((<dynlet> fluids vals body)
439 `(with-fluids ,(map list
442 ,@(recurse-body body)))
445 `(fluid-ref ,(recurse fluid)))
447 ((<dynset> fluid exp)
448 `(fluid-set! ,(recurse fluid) ,(recurse exp)))
450 ((<prompt> tag body handler)
453 (lambda () ,@(recurse-body body))
457 ((<abort> tag args tail)
458 `(apply abort ,(recurse tag) ,@(map recurse args)
460 (values (recurse e) env)))
462 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
464 ;; Algorithm for choosing better variable names
465 ;; ============================================
467 ;; First we perform an analysis pass, collecting the following
470 ;; * For each gensym: how many occurrences will occur in the output?
472 ;; * For each gensym A: which gensyms does A conflict with? Gensym A
473 ;; and gensym B conflict if they have the same base name (usually the
474 ;; same as the source name, but see below), and if giving them the
475 ;; same name would cause a bad variable reference due to unintentional
478 ;; The occurrence counter is indexed by gensym and is global (within each
479 ;; invocation of the algorithm), implemented using a hash table. We also
480 ;; keep a global mapping from gensym to source name as provided by the
481 ;; binding construct (we prefer not to trust the source names in the
482 ;; lexical ref or set).
484 ;; As we recurse down into lexical binding forms, we keep track of a
485 ;; mapping from base name to an ordered list of bindings, innermost
486 ;; first. When we encounter a variable occurrence, we increment the
487 ;; counter, look up the base name (preferring not to trust the 'name' in
488 ;; the lexical ref or set), and then look up the bindings currently in
489 ;; effect for that base name. Hopefully our gensym will be the first
490 ;; (innermost) binding. If not, we register a conflict between the
491 ;; referenced gensym and the other bound gensyms with the same base name
492 ;; that shadow the binding we want. These are simply the gensyms on the
493 ;; binding list that come before our gensym.
495 ;; Top-level bindings are treated specially. Whenever top-level
496 ;; references are found, they conflict with every lexical binding
497 ;; currently in effect with the same base name. They are guaranteed to
498 ;; be assigned to their source names. For purposes of recording
499 ;; conflicts (which are normally keyed on gensyms) top-level identifiers
500 ;; are assigned a pseudo-gensym that is an interned pair of the form
501 ;; (top-level . <name>). This allows them to be compared using 'eq?'
502 ;; like other gensyms.
504 ;; The base name is normally just the source name. However, if the
505 ;; source name has a suffix of the form "-N" (where N is a positive
506 ;; integer without leading zeroes), then we strip that suffix (multiple
507 ;; times if necessary) to form the base name. We must do this because
508 ;; we add suffixes of that form in order to resolve conflicts, and we
509 ;; must ensure that only identifiers with the same base name can
510 ;; possibly conflict with each other.
512 ;; XXX FIXME: Currently, primitives are treated exactly like top-level
513 ;; bindings. This handles conflicting lexical bindings properly, but
514 ;; does _not_ handle the case where top-level bindings conflict with the
515 ;; needed primitives.
517 ;; Also note that this requires that 'choose-output-names' be kept in
518 ;; sync with 'tree-il->scheme'. Primitives that are introduced by
519 ;; 'tree-il->scheme' must be anticipated by 'choose-output-name'.
521 ;; We also ensure that lexically-bound identifiers found in operator
522 ;; position will never be assigned one of the standard primitive names.
523 ;; This is needed because 'tree-il->scheme' recognizes primitive names
524 ;; in operator position and assumes that they have the standard
528 ;; How we assign an output name to each gensym
529 ;; ===========================================
531 ;; We process the gensyms in order of decreasing occurrence count, with
532 ;; each gensym choosing the best output name possible, as long as it
533 ;; isn't the same name as any of the previously-chosen output names of
534 ;; conflicting gensyms.
539 ;; 'choose-output-names' analyzes the top-level form e, chooses good
540 ;; variable names that are as close as possible to the source names,
541 ;; and returns two values:
543 ;; * a hash table mapping gensym to output name
544 ;; * a hash table mapping gensym to number of occurrences
546 (define choose-output-names
549 ;; This is a list of primitives that 'tree-il->scheme' assumes
550 ;; will have the standard bindings when found in operator
552 (let* ((primitives '(if quote @ @@ set! define define*
553 begin let let* letrec letrec*
555 lambda lambda* case-lambda case-lambda*
556 apply call-with-values dynamic-wind
557 with-fluids fluid-ref fluid-set!
558 call-with-prompt abort memv eqv?))
559 (table (make-hash-table (length primitives))))
560 (for-each (cut hashq-set! table <> #t) primitives)
561 (lambda (name) (hashq-ref table name))))
563 ;; Repeatedly strip suffix of the form "-N", where N is a string
564 ;; that could be produced by number->string given a positive
565 ;; integer. In other words, the first digit of N may not be 0.
566 (define compute-base-name
567 (let ((digits (string->char-set "0123456789")))
568 (define (base-name-string str)
569 (let ((i (string-skip-right str digits)))
570 (if (and i (< (1+ i) (string-length str))
571 (eq? #\- (string-ref str i))
572 (not (eq? #\0 (string-ref str (1+ i)))))
573 (base-name-string (substring str 0 i))
576 (string->symbol (base-name-string (symbol->string sym))))))
578 ;; choose-output-names
579 (lambda (e use-derived-syntax? strip-numeric-suffixes?)
581 (define lexical-gensyms '())
583 (define top-level-intern!
584 (let ((table (make-hash-table)))
586 (let ((h (hashq-create-handle! table name #f)))
587 (or (cdr h) (begin (set-cdr! h (cons 'top-level name))
589 (define (top-level? s) (pair? s))
590 (define (top-level-name s) (cdr s))
592 (define occurrence-count-table (make-hash-table))
593 (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0))
594 (define (increment-occurrence-count! s)
595 (let ((h (hashq-create-handle! occurrence-count-table s 0)))
597 (set! lexical-gensyms (cons s lexical-gensyms)))
598 (set-cdr! h (1+ (cdr h)))))
601 (let ((table (make-hash-table)))
603 (let ((h (hashq-create-handle! table name #f)))
604 (or (cdr h) (begin (set-cdr! h (compute-base-name name))
607 (define source-name-table (make-hash-table))
608 (define (set-source-name! s name)
609 (if (not (top-level? s))
610 (let ((name (if strip-numeric-suffixes?
613 (hashq-set! source-name-table s name))))
614 (define (source-name s)
617 (hashq-ref source-name-table s)))
619 (define conflict-table (make-hash-table))
620 (define (conflicts s) (or (hashq-ref conflict-table s) '()))
621 (define (add-conflict! a b)
623 (if (not (top-level? a))
624 (let ((h (hashq-create-handle! conflict-table a '())))
625 (if (not (memq b (cdr h)))
626 (set-cdr! h (cons b (cdr h)))))))
630 (let recurse-with-bindings ((e e) (bindings vlist-null))
633 ;; We call this whenever we encounter a top-level ref or set
634 (define (top-level name)
635 (let ((bname (base-name name)))
636 (let ((s (top-level-intern! name))
637 (conflicts (vhash-foldq* cons '() bname bindings)))
638 (for-each (cut add-conflict! s <>) conflicts))))
640 ;; We call this whenever we encounter a primitive reference.
641 ;; We must also call it for every primitive that might be
642 ;; inserted by 'tree-il->scheme'. It is okay to call this
643 ;; even when 'tree-il->scheme' will not insert the named
644 ;; primitive; the worst that will happen is for a lexical
645 ;; variable of the same name to be renamed unnecessarily.
646 (define (primitive name) (top-level name))
648 ;; We call this whenever we encounter a lexical ref or set.
650 (increment-occurrence-count! s)
653 (lambda (s*) (not (eq? s s*)))
654 (reverse! (vhash-foldq* cons
656 (base-name (source-name s))
658 (for-each (cut add-conflict! s <>) conflicts)))
661 ((<void>) (primitive 'if)) ; (if #f #f)
662 ((<const>) (primitive 'quote))
665 (if (lexical-ref? proc)
666 (let* ((gensym (lexical-ref-gensym proc))
667 (name (source-name gensym)))
668 ;; If the operator position contains a bare variable
669 ;; reference with the same source name as a standard
670 ;; primitive, we must ensure that it will be given a
671 ;; different name, so that 'tree-il->scheme' will not
672 ;; misinterpret the resulting expression.
673 (if (primitive? name)
674 (add-conflict! gensym (top-level-intern! name)))))
676 (for-each recurse args))
678 ((<primitive-ref> name) (primitive name))
679 ((<primcall> name args) (primitive name) (for-each recurse args))
681 ((<lexical-ref> gensym) (lexical gensym))
682 ((<lexical-set> gensym exp)
683 (primitive 'set!) (lexical gensym) (recurse exp))
685 ((<module-ref> public?) (primitive (if public? '@ '@@)))
686 ((<module-set> public? exp)
687 (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp))
689 ((<toplevel-ref> name) (top-level name))
690 ((<toplevel-set> name exp)
691 (primitive 'set!) (top-level name) (recurse exp))
692 ((<toplevel-define> name exp) (top-level name) (recurse exp))
694 ((<conditional> test consequent alternate)
695 (cond (use-derived-syntax?
696 (primitive 'and) (primitive 'or)
697 (primitive 'cond) (primitive 'case)
698 (primitive 'else) (primitive '=>)))
700 (recurse test) (recurse consequent) (recurse alternate))
703 (primitive 'begin) (recurse head) (recurse tail))
705 ((<lambda> body) (recurse body))
707 ((<lambda-case> req opt rest kw inits gensyms body alternate)
709 (cond ((or opt kw alternate)
711 (primitive 'case-lambda)
712 (primitive 'case-lambda*)))
714 (if use-derived-syntax? (primitive 'let*))
715 (let* ((names (append req (or opt '()) (if rest (list rest) '())
716 (map cadr (if kw (cdr kw) '()))))
717 (base-names (map base-name names))
719 (fold vhash-consq bindings base-names gensyms)))
720 (for-each increment-occurrence-count! gensyms)
721 (for-each set-source-name! gensyms names)
722 (for-each recurse inits)
723 (recurse-with-bindings body body-bindings)
724 (if alternate (recurse alternate))))
726 ((<let> names gensyms vals body)
728 (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
729 (for-each increment-occurrence-count! gensyms)
730 (for-each set-source-name! gensyms names)
731 (for-each recurse vals)
732 (recurse-with-bindings
733 body (fold vhash-consq bindings (map base-name names) gensyms)))
735 ((<letrec> in-order? names gensyms vals body)
737 (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
738 (primitive (if in-order? 'letrec* 'letrec))
739 (for-each increment-occurrence-count! gensyms)
740 (for-each set-source-name! gensyms names)
741 (let* ((base-names (map base-name names))
742 (bindings (fold vhash-consq bindings base-names gensyms)))
743 (for-each (cut recurse-with-bindings <> bindings) vals)
744 (recurse-with-bindings body bindings)))
746 ((<fix> names gensyms vals body)
749 (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
750 (for-each increment-occurrence-count! gensyms)
751 (for-each set-source-name! gensyms names)
752 (let* ((base-names (map base-name names))
753 (bindings (fold vhash-consq bindings base-names gensyms)))
754 (for-each (cut recurse-with-bindings <> bindings) vals)
755 (recurse-with-bindings body bindings)))
757 ((<let-values> exp body)
758 (primitive 'call-with-values)
759 (recurse exp) (recurse body))
761 ((<dynwind> winder body unwinder)
762 (primitive 'dynamic-wind)
763 (recurse winder) (recurse body) (recurse unwinder))
765 ((<dynlet> fluids vals body)
766 (primitive 'with-fluids)
767 (for-each recurse fluids)
768 (for-each recurse vals)
771 ((<dynref> fluid) (primitive 'fluid-ref) (recurse fluid))
772 ((<dynset> fluid exp)
773 (primitive 'fluid-set!) (recurse fluid) (recurse exp))
775 ((<prompt> tag body handler)
776 (primitive 'call-with-prompt)
778 (recurse tag) (recurse body) (recurse handler))
780 ((<abort> tag args tail)
783 (recurse tag) (for-each recurse args) (recurse tail)))))
786 (define output-name-table (make-hash-table))
787 (define (set-output-name! s name)
788 (hashq-set! output-name-table s name))
789 (define (output-name s)
792 (hashq-ref output-name-table s)))
794 (define sorted-lexical-gensyms
795 (sort-list lexical-gensyms
796 (lambda (a b) (> (occurrence-count a)
797 (occurrence-count b)))))
799 (for-each (lambda (s)
802 (let ((the-conflicts (conflicts s))
803 (the-source-name (source-name s)))
804 (define (not-yet-taken? name)
805 (not (any (lambda (s*)
806 (and=> (output-name s*)
809 (if (not-yet-taken? the-source-name)
811 (let ((prefix (string-append
812 (symbol->string the-source-name)
814 (let loop ((i 1) (name the-source-name))
815 (if (not-yet-taken? name)
821 (number->string i)))))))))))
822 sorted-lexical-gensyms)
823 (values output-name-table occurrence-count-table)))))