123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797 |
- ;;; Guile VM code converters
- ;; Copyright (C) 2001, 2009, 2012, 2013 Free Software Foundation, Inc.
- ;;;; This library is free software; you can redistribute it and/or
- ;;;; modify it under the terms of the GNU Lesser General Public
- ;;;; License as published by the Free Software Foundation; either
- ;;;; version 3 of the License, or (at your option) any later version.
- ;;;;
- ;;;; This library is distributed in the hope that it will be useful,
- ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- ;;;; Lesser General Public License for more details.
- ;;;;
- ;;;; You should have received a copy of the GNU Lesser General Public
- ;;;; License along with this library; if not, write to the Free Software
- ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
- ;;; Code:
- (define-module (language scheme decompile-tree-il)
- #:use-module (language tree-il)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:use-module (ice-9 receive)
- #:use-module (ice-9 vlist)
- #:use-module (ice-9 match)
- #:use-module (system base syntax)
- #:export (decompile-tree-il))
- (define (decompile-tree-il e env opts)
- (apply do-decompile e env opts))
- (define* (do-decompile e env
- #:key
- (use-derived-syntax? #t)
- (avoid-lambda? #t)
- (use-case? #t)
- (strip-numeric-suffixes? #f)
- #:allow-other-keys)
- (receive (output-name-table occurrence-count-table)
- (choose-output-names e use-derived-syntax? strip-numeric-suffixes?)
- (define (output-name s) (hashq-ref output-name-table s))
- (define (occurrence-count s) (hashq-ref occurrence-count-table s))
- (define (const x) (lambda (_) x))
- (define (atom? x) (not (or (pair? x) (vector? x))))
- (define (build-void) '(if #f #f))
- (define (build-begin es)
- (match es
- (() (build-void))
- ((e) e)
- (_ `(begin ,@es))))
- (define (build-lambda-body e)
- (match e
- (('let () body ...) body)
- (('begin es ...) es)
- (_ (list e))))
- (define (build-begin-body e)
- (match e
- (('begin es ...) es)
- (_ (list e))))
- (define (build-define name e)
- (match e
- ((? (const avoid-lambda?)
- ('lambda formals body ...))
- `(define (,name ,@formals) ,@body))
- ((? (const avoid-lambda?)
- ('lambda* formals body ...))
- `(define* (,name ,@formals) ,@body))
- (_ `(define ,name ,e))))
- (define (build-let names vals body)
- (match `(let ,(map list names vals)
- ,@(build-lambda-body body))
- ((_ () e) e)
- ((_ (b) ('let* (bs ...) body ...))
- `(let* (,b ,@bs) ,@body))
- ((? (const use-derived-syntax?)
- (_ (b1) ('let (b2) body ...)))
- `(let* (,b1 ,b2) ,@body))
- (e e)))
- (define (build-letrec in-order? names vals body)
- (match `(,(if in-order? 'letrec* 'letrec)
- ,(map list names vals)
- ,@(build-lambda-body body))
- ((_ () e) e)
- ((_ () body ...) `(let () ,@body))
- ((_ ((name ('lambda (formals ...) body ...)))
- (name args ...))
- (=> failure)
- (if (= (length formals) (length args))
- `(let ,name ,(map list formals args) ,@body)
- (failure)))
- ((? (const avoid-lambda?)
- ('letrec* _ body ...))
- `(let ()
- ,@(map build-define names vals)
- ,@body))
- (e e)))
- (define (build-if test consequent alternate)
- (match alternate
- (('if #f _) `(if ,test ,consequent))
- (_ `(if ,test ,consequent ,alternate))))
- (define (build-and xs)
- (match xs
- (() #t)
- ((x) x)
- (_ `(and ,@xs))))
- (define (build-or xs)
- (match xs
- (() #f)
- ((x) x)
- (_ `(or ,@xs))))
- (define (case-test-var test)
- (match test
- (('memv (? atom? v) ('quote (datums ...)))
- v)
- (('eqv? (? atom? v) ('quote datum))
- v)
- (_ #f)))
- (define (test->datums v test)
- (match (cons v test)
- ((v 'memv v ('quote (xs ...)))
- xs)
- ((v 'eqv? v ('quote x))
- (list x))
- (_ #f)))
- (define (build-else-tail e)
- (match e
- (('if #f _) '())
- (('and xs ... x) `((,(build-and xs) ,@(build-begin-body x))
- (else #f)))
- (_ `((else ,@(build-begin-body e))))))
- (define (build-cond-else-tail e)
- (match e
- (('cond clauses ...) clauses)
- (_ (build-else-tail e))))
- (define (build-case-else-tail v e)
- (match (cons v e)
- ((v 'case v clauses ...)
- clauses)
- ((v 'if ('memv v ('quote (xs ...))) consequent . alternate*)
- `((,xs ,@(build-begin-body consequent))
- ,@(build-case-else-tail v (build-begin alternate*))))
- ((v 'if ('eqv? v ('quote x)) consequent . alternate*)
- `(((,x) ,@(build-begin-body consequent))
- ,@(build-case-else-tail v (build-begin alternate*))))
- (_ (build-else-tail e))))
- (define (clauses+tail clauses)
- (match clauses
- ((cs ... (and c ('else . _))) (values cs (list c)))
- (_ (values clauses '()))))
- (define (build-cond tests consequents alternate)
- (case (length tests)
- ((0) alternate)
- ((1) (build-if (car tests) (car consequents) alternate))
- (else `(cond ,@(map (lambda (test consequent)
- `(,test ,@(build-begin-body consequent)))
- tests consequents)
- ,@(build-cond-else-tail alternate)))))
- (define (build-cond-or-case tests consequents alternate)
- (if (not use-case?)
- (build-cond tests consequents alternate)
- (let* ((v (and (not (null? tests))
- (case-test-var (car tests))))
- (datum-lists (take-while identity
- (map (cut test->datums v <>)
- tests)))
- (n (length datum-lists))
- (tail (build-case-else-tail v (build-cond
- (drop tests n)
- (drop consequents n)
- alternate))))
- (receive (clauses tail) (clauses+tail tail)
- (let ((n (+ n (length clauses)))
- (datum-lists (append datum-lists
- (map car clauses)))
- (consequents (append consequents
- (map build-begin
- (map cdr clauses)))))
- (if (< n 2)
- (build-cond tests consequents alternate)
- `(case ,v
- ,@(map cons datum-lists (map build-begin-body
- (take consequents n)))
- ,@tail)))))))
- (define (recurse e)
- (define (recurse-body e)
- (build-lambda-body (recurse e)))
- (record-case e
- ((<void>)
- (build-void))
- ((<const> exp)
- (if (and (self-evaluating? exp) (not (vector? exp)))
- exp
- `(quote ,exp)))
- ((<seq> head tail)
- (build-begin (cons (recurse head)
- (build-begin-body
- (recurse tail)))))
- ((<call> proc args)
- (match `(,(recurse proc) ,@(map recurse args))
- ((('lambda (formals ...) body ...) args ...)
- (=> failure)
- (if (= (length formals) (length args))
- (build-let formals args (build-begin body))
- (failure)))
- (e e)))
- ((<primcall> name args)
- `(,name ,@(map recurse args)))
- ((<primitive-ref> name)
- name)
- ((<lexical-ref> gensym)
- (output-name gensym))
- ((<lexical-set> gensym exp)
- `(set! ,(output-name gensym) ,(recurse exp)))
- ((<module-ref> mod name public?)
- `(,(if public? '@ '@@) ,mod ,name))
- ((<module-set> mod name public? exp)
- `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp)))
- ((<toplevel-ref> name)
- name)
- ((<toplevel-set> name exp)
- `(set! ,name ,(recurse exp)))
- ((<toplevel-define> name exp)
- (build-define name (recurse exp)))
- ((<lambda> meta body)
- (if body
- (let ((body (recurse body))
- (doc (assq-ref meta 'documentation)))
- (if (not doc)
- body
- (match body
- (('lambda formals body ...)
- `(lambda ,formals ,doc ,@body))
- (('lambda* formals body ...)
- `(lambda* ,formals ,doc ,@body))
- (('case-lambda (formals body ...) clauses ...)
- `(case-lambda (,formals ,doc ,@body) ,@clauses))
- (('case-lambda* (formals body ...) clauses ...)
- `(case-lambda* (,formals ,doc ,@body) ,@clauses))
- (e e))))
- '(case-lambda)))
- ((<lambda-case> req opt rest kw inits gensyms body alternate)
- (let ((names (map output-name gensyms)))
- (cond
- ((and (not opt) (not kw) (not alternate))
- `(lambda ,(if rest (apply cons* names) names)
- ,@(recurse-body body)))
- ((and (not opt) (not kw))
- (let ((alt-expansion (recurse alternate))
- (formals (if rest (apply cons* names) names)))
- (case (car alt-expansion)
- ((lambda)
- `(case-lambda (,formals ,@(recurse-body body))
- ,(cdr alt-expansion)))
- ((lambda*)
- `(case-lambda* (,formals ,@(recurse-body body))
- ,(cdr alt-expansion)))
- ((case-lambda)
- `(case-lambda (,formals ,@(recurse-body body))
- ,@(cdr alt-expansion)))
- ((case-lambda*)
- `(case-lambda* (,formals ,@(recurse-body body))
- ,@(cdr alt-expansion))))))
- (else
- (let* ((alt-expansion (and alternate (recurse alternate)))
- (nreq (length req))
- (nopt (if opt (length opt) 0))
- (restargs (if rest (list-ref names (+ nreq nopt)) '()))
- (reqargs (list-head names nreq))
- (optargs (if opt
- `(#:optional
- ,@(map list
- (list-head (list-tail names nreq) nopt)
- (map recurse
- (list-head inits nopt))))
- '()))
- (kwargs (if kw
- `(#:key
- ,@(map list
- (map output-name (map caddr (cdr kw)))
- (map recurse
- (list-tail inits nopt))
- (map car (cdr kw)))
- ,@(if (car kw)
- '(#:allow-other-keys)
- '()))
- '()))
- (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
- (if (not alt-expansion)
- `(lambda* ,formals ,@(recurse-body body))
- (case (car alt-expansion)
- ((lambda lambda*)
- `(case-lambda* (,formals ,@(recurse-body body))
- ,(cdr alt-expansion)))
- ((case-lambda case-lambda*)
- `(case-lambda* (,formals ,@(recurse-body body))
- ,@(cdr alt-expansion))))))))))
- ((<conditional> test consequent alternate)
- (define (simplify-test e)
- (match e
- (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b)))
- `(memv ,v '(,a ,b)))
- (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs ...))))
- `(memv ,v '(,a ,@bs)))
- (('case (? atom? v)
- ((datum) #t) ...
- ('else ('eqv? v ('quote last-datum))))
- `(memv ,v '(,@datum ,last-datum)))
- (_ e)))
- (match `(if ,(simplify-test (recurse test))
- ,(recurse consequent)
- ,@(if (void? alternate) '()
- (list (recurse alternate))))
- (('if test ('if ('and xs ...) consequent))
- (build-if (build-and (cons test xs))
- consequent
- (build-void)))
- ((? (const use-derived-syntax?)
- ('if test1 ('if test2 consequent)))
- (build-if (build-and (list test1 test2))
- consequent
- (build-void)))
- (('if (? atom? x) x ('or ys ...))
- (build-or (cons x ys)))
- ((? (const use-derived-syntax?)
- ('if (? atom? x) x y))
- (build-or (list x y)))
- (('if test consequent)
- `(if ,test ,consequent))
- (('if test ('and xs ...) #f)
- (build-and (cons test xs)))
- ((? (const use-derived-syntax?)
- ('if test consequent #f))
- (build-and (list test consequent)))
- ((? (const use-derived-syntax?)
- ('if test1 consequent1
- ('if test2 consequent2 . alternate*)))
- (build-cond-or-case (list test1 test2)
- (list consequent1 consequent2)
- (build-begin alternate*)))
- (('if test consequent ('cond clauses ...))
- `(cond (,test ,@(build-begin-body consequent))
- ,@clauses))
- (('if ('memv (? atom? v) ('quote (xs ...))) consequent
- ('case v clauses ...))
- `(case ,v (,xs ,@(build-begin-body consequent))
- ,@clauses))
- (('if ('eqv? (? atom? v) ('quote x)) consequent
- ('case v clauses ...))
- `(case ,v ((,x) ,@(build-begin-body consequent))
- ,@clauses))
- (e e)))
- ((<let> gensyms vals body)
- (match (build-let (map output-name gensyms)
- (map recurse vals)
- (recurse body))
- (('let ((v e)) ('or v xs ...))
- (=> failure)
- (if (and (not (null? gensyms))
- (= 3 (occurrence-count (car gensyms))))
- `(or ,e ,@xs)
- (failure)))
- (('let ((v e)) ('case v clauses ...))
- (=> failure)
- (if (and (not (null? gensyms))
- ;; FIXME: This fails if any of the 'memv's were
- ;; optimized into multiple 'eqv?'s, because the
- ;; occurrence count will be higher than we expect.
- (= (occurrence-count (car gensyms))
- (1+ (length (clauses+tail clauses)))))
- `(case ,e ,@clauses)
- (failure)))
- (e e)))
- ((<letrec> in-order? gensyms vals body)
- (build-letrec in-order?
- (map output-name gensyms)
- (map recurse vals)
- (recurse body)))
- ((<fix> gensyms vals body)
- ;; not a typo, we really do translate back to letrec. use letrec* since it
- ;; doesn't matter, and the naive letrec* transformation does not require an
- ;; inner let.
- (build-letrec #t
- (map output-name gensyms)
- (map recurse vals)
- (recurse body)))
- ((<let-values> exp body)
- `(call-with-values (lambda () ,@(recurse-body exp))
- ,(recurse (make-lambda #f '() body))))
- ((<prompt> escape-only? tag body handler)
- `(call-with-prompt
- ,(recurse tag)
- ,(if escape-only?
- `(lambda () ,(recurse body))
- (recurse body))
- ,(recurse handler)))
- ((<abort> tag args tail)
- `(apply abort ,(recurse tag) ,@(map recurse args)
- ,(recurse tail)))))
- (values (recurse e) env)))
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;
- ;; Algorithm for choosing better variable names
- ;; ============================================
- ;;
- ;; First we perform an analysis pass, collecting the following
- ;; information:
- ;;
- ;; * For each gensym: how many occurrences will occur in the output?
- ;;
- ;; * For each gensym A: which gensyms does A conflict with? Gensym A
- ;; and gensym B conflict if they have the same base name (usually the
- ;; same as the source name, but see below), and if giving them the
- ;; same name would cause a bad variable reference due to unintentional
- ;; variable capture.
- ;;
- ;; The occurrence counter is indexed by gensym and is global (within each
- ;; invocation of the algorithm), implemented using a hash table. We also
- ;; keep a global mapping from gensym to source name as provided by the
- ;; binding construct (we prefer not to trust the source names in the
- ;; lexical ref or set).
- ;;
- ;; As we recurse down into lexical binding forms, we keep track of a
- ;; mapping from base name to an ordered list of bindings, innermost
- ;; first. When we encounter a variable occurrence, we increment the
- ;; counter, look up the base name (preferring not to trust the 'name' in
- ;; the lexical ref or set), and then look up the bindings currently in
- ;; effect for that base name. Hopefully our gensym will be the first
- ;; (innermost) binding. If not, we register a conflict between the
- ;; referenced gensym and the other bound gensyms with the same base name
- ;; that shadow the binding we want. These are simply the gensyms on the
- ;; binding list that come before our gensym.
- ;;
- ;; Top-level bindings are treated specially. Whenever top-level
- ;; references are found, they conflict with every lexical binding
- ;; currently in effect with the same base name. They are guaranteed to
- ;; be assigned to their source names. For purposes of recording
- ;; conflicts (which are normally keyed on gensyms) top-level identifiers
- ;; are assigned a pseudo-gensym that is an interned pair of the form
- ;; (top-level . <name>). This allows them to be compared using 'eq?'
- ;; like other gensyms.
- ;;
- ;; The base name is normally just the source name. However, if the
- ;; source name has a suffix of the form "-N" (where N is a positive
- ;; integer without leading zeroes), then we strip that suffix (multiple
- ;; times if necessary) to form the base name. We must do this because
- ;; we add suffixes of that form in order to resolve conflicts, and we
- ;; must ensure that only identifiers with the same base name can
- ;; possibly conflict with each other.
- ;;
- ;; XXX FIXME: Currently, primitives are treated exactly like top-level
- ;; bindings. This handles conflicting lexical bindings properly, but
- ;; does _not_ handle the case where top-level bindings conflict with the
- ;; needed primitives.
- ;;
- ;; Also note that this requires that 'choose-output-names' be kept in
- ;; sync with 'tree-il->scheme'. Primitives that are introduced by
- ;; 'tree-il->scheme' must be anticipated by 'choose-output-name'.
- ;;
- ;; We also ensure that lexically-bound identifiers found in operator
- ;; position will never be assigned one of the standard primitive names.
- ;; This is needed because 'tree-il->scheme' recognizes primitive names
- ;; in operator position and assumes that they have the standard
- ;; bindings.
- ;;
- ;;
- ;; How we assign an output name to each gensym
- ;; ===========================================
- ;;
- ;; We process the gensyms in order of decreasing occurrence count, with
- ;; each gensym choosing the best output name possible, as long as it
- ;; isn't the same name as any of the previously-chosen output names of
- ;; conflicting gensyms.
- ;;
- ;;
- ;; 'choose-output-names' analyzes the top-level form e, chooses good
- ;; variable names that are as close as possible to the source names,
- ;; and returns two values:
- ;;
- ;; * a hash table mapping gensym to output name
- ;; * a hash table mapping gensym to number of occurrences
- ;;
- (define choose-output-names
- (let ()
- (define primitive?
- ;; This is a list of primitives that 'tree-il->scheme' assumes
- ;; will have the standard bindings when found in operator
- ;; position.
- (let* ((primitives '(if quote @ @@ set! define define*
- begin let let* letrec letrec*
- and or cond case
- lambda lambda* case-lambda case-lambda*
- apply call-with-values dynamic-wind
- with-fluids fluid-ref fluid-set!
- call-with-prompt abort memv eqv?))
- (table (make-hash-table (length primitives))))
- (for-each (cut hashq-set! table <> #t) primitives)
- (lambda (name) (hashq-ref table name))))
- ;; Repeatedly strip suffix of the form "-N", where N is a string
- ;; that could be produced by number->string given a positive
- ;; integer. In other words, the first digit of N may not be 0.
- (define compute-base-name
- (let ((digits (string->char-set "0123456789")))
- (define (base-name-string str)
- (let ((i (string-skip-right str digits)))
- (if (and i (< (1+ i) (string-length str))
- (eq? #\- (string-ref str i))
- (not (eq? #\0 (string-ref str (1+ i)))))
- (base-name-string (substring str 0 i))
- str)))
- (lambda (sym)
- (string->symbol (base-name-string (symbol->string sym))))))
- ;; choose-output-names
- (lambda (e use-derived-syntax? strip-numeric-suffixes?)
- (define lexical-gensyms '())
- (define top-level-intern!
- (let ((table (make-hash-table)))
- (lambda (name)
- (let ((h (hashq-create-handle! table name #f)))
- (or (cdr h) (begin (set-cdr! h (cons 'top-level name))
- (cdr h)))))))
- (define (top-level? s) (pair? s))
- (define (top-level-name s) (cdr s))
- (define occurrence-count-table (make-hash-table))
- (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0))
- (define (increment-occurrence-count! s)
- (let ((h (hashq-create-handle! occurrence-count-table s 0)))
- (if (zero? (cdr h))
- (set! lexical-gensyms (cons s lexical-gensyms)))
- (set-cdr! h (1+ (cdr h)))))
- (define base-name
- (let ((table (make-hash-table)))
- (lambda (name)
- (let ((h (hashq-create-handle! table name #f)))
- (or (cdr h) (begin (set-cdr! h (compute-base-name name))
- (cdr h)))))))
- (define source-name-table (make-hash-table))
- (define (set-source-name! s name)
- (if (not (top-level? s))
- (let ((name (if strip-numeric-suffixes?
- (base-name name)
- name)))
- (hashq-set! source-name-table s name))))
- (define (source-name s)
- (if (top-level? s)
- (top-level-name s)
- (hashq-ref source-name-table s)))
- (define conflict-table (make-hash-table))
- (define (conflicts s) (or (hashq-ref conflict-table s) '()))
- (define (add-conflict! a b)
- (define (add! a b)
- (if (not (top-level? a))
- (let ((h (hashq-create-handle! conflict-table a '())))
- (if (not (memq b (cdr h)))
- (set-cdr! h (cons b (cdr h)))))))
- (add! a b)
- (add! b a))
- (let recurse-with-bindings ((e e) (bindings vlist-null))
- (let recurse ((e e))
- ;; We call this whenever we encounter a top-level ref or set
- (define (top-level name)
- (let ((bname (base-name name)))
- (let ((s (top-level-intern! name))
- (conflicts (vhash-foldq* cons '() bname bindings)))
- (for-each (cut add-conflict! s <>) conflicts))))
- ;; We call this whenever we encounter a primitive reference.
- ;; We must also call it for every primitive that might be
- ;; inserted by 'tree-il->scheme'. It is okay to call this
- ;; even when 'tree-il->scheme' will not insert the named
- ;; primitive; the worst that will happen is for a lexical
- ;; variable of the same name to be renamed unnecessarily.
- (define (primitive name) (top-level name))
- ;; We call this whenever we encounter a lexical ref or set.
- (define (lexical s)
- (increment-occurrence-count! s)
- (let ((conflicts
- (take-while
- (lambda (s*) (not (eq? s s*)))
- (reverse! (vhash-foldq* cons
- '()
- (base-name (source-name s))
- bindings)))))
- (for-each (cut add-conflict! s <>) conflicts)))
- (record-case e
- ((<void>) (primitive 'if)) ; (if #f #f)
- ((<const>) (primitive 'quote))
- ((<call> proc args)
- (if (lexical-ref? proc)
- (let* ((gensym (lexical-ref-gensym proc))
- (name (source-name gensym)))
- ;; If the operator position contains a bare variable
- ;; reference with the same source name as a standard
- ;; primitive, we must ensure that it will be given a
- ;; different name, so that 'tree-il->scheme' will not
- ;; misinterpret the resulting expression.
- (if (primitive? name)
- (add-conflict! gensym (top-level-intern! name)))))
- (recurse proc)
- (for-each recurse args))
- ((<primitive-ref> name) (primitive name))
- ((<primcall> name args) (primitive name) (for-each recurse args))
- ((<lexical-ref> gensym) (lexical gensym))
- ((<lexical-set> gensym exp)
- (primitive 'set!) (lexical gensym) (recurse exp))
- ((<module-ref> public?) (primitive (if public? '@ '@@)))
- ((<module-set> public? exp)
- (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp))
- ((<toplevel-ref> name) (top-level name))
- ((<toplevel-set> name exp)
- (primitive 'set!) (top-level name) (recurse exp))
- ((<toplevel-define> name exp) (top-level name) (recurse exp))
- ((<conditional> test consequent alternate)
- (cond (use-derived-syntax?
- (primitive 'and) (primitive 'or)
- (primitive 'cond) (primitive 'case)
- (primitive 'else) (primitive '=>)))
- (primitive 'if)
- (recurse test) (recurse consequent) (recurse alternate))
- ((<seq> head tail)
- (primitive 'begin) (recurse head) (recurse tail))
- ((<lambda> body)
- (if body (recurse body) (primitive 'case-lambda)))
- ((<lambda-case> req opt rest kw inits gensyms body alternate)
- (primitive 'lambda)
- (cond ((or opt kw alternate)
- (primitive 'lambda*)
- (primitive 'case-lambda)
- (primitive 'case-lambda*)))
- (primitive 'let)
- (if use-derived-syntax? (primitive 'let*))
- (let* ((names (append req (or opt '()) (if rest (list rest) '())
- (map cadr (if kw (cdr kw) '()))))
- (base-names (map base-name names))
- (body-bindings
- (fold vhash-consq bindings base-names gensyms)))
- (for-each increment-occurrence-count! gensyms)
- (for-each set-source-name! gensyms names)
- (for-each recurse inits)
- (recurse-with-bindings body body-bindings)
- (if alternate (recurse alternate))))
- ((<let> names gensyms vals body)
- (primitive 'let)
- (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
- (for-each increment-occurrence-count! gensyms)
- (for-each set-source-name! gensyms names)
- (for-each recurse vals)
- (recurse-with-bindings
- body (fold vhash-consq bindings (map base-name names) gensyms)))
- ((<letrec> in-order? names gensyms vals body)
- (primitive 'let)
- (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
- (primitive (if in-order? 'letrec* 'letrec))
- (for-each increment-occurrence-count! gensyms)
- (for-each set-source-name! gensyms names)
- (let* ((base-names (map base-name names))
- (bindings (fold vhash-consq bindings base-names gensyms)))
- (for-each (cut recurse-with-bindings <> bindings) vals)
- (recurse-with-bindings body bindings)))
- ((<fix> names gensyms vals body)
- (primitive 'let)
- (primitive 'letrec*)
- (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
- (for-each increment-occurrence-count! gensyms)
- (for-each set-source-name! gensyms names)
- (let* ((base-names (map base-name names))
- (bindings (fold vhash-consq bindings base-names gensyms)))
- (for-each (cut recurse-with-bindings <> bindings) vals)
- (recurse-with-bindings body bindings)))
- ((<let-values> exp body)
- (primitive 'call-with-values)
- (recurse exp) (recurse body))
- ((<prompt> tag body handler)
- (primitive 'call-with-prompt)
- (recurse tag) (recurse body) (recurse handler))
- ((<abort> tag args tail)
- (primitive 'apply)
- (primitive 'abort)
- (recurse tag) (for-each recurse args) (recurse tail)))))
- (let ()
- (define output-name-table (make-hash-table))
- (define (set-output-name! s name)
- (hashq-set! output-name-table s name))
- (define (output-name s)
- (if (top-level? s)
- (top-level-name s)
- (hashq-ref output-name-table s)))
- (define sorted-lexical-gensyms
- (sort-list lexical-gensyms
- (lambda (a b) (> (occurrence-count a)
- (occurrence-count b)))))
- (for-each (lambda (s)
- (set-output-name!
- s
- (let ((the-conflicts (conflicts s))
- (the-source-name (source-name s)))
- (define (not-yet-taken? name)
- (not (any (lambda (s*)
- (and=> (output-name s*)
- (cut eq? name <>)))
- the-conflicts)))
- (if (not-yet-taken? the-source-name)
- the-source-name
- (let ((prefix (string-append
- (symbol->string the-source-name)
- "-")))
- (let loop ((i 1) (name the-source-name))
- (if (not-yet-taken? name)
- name
- (loop (+ i 1)
- (string->symbol
- (string-append
- prefix
- (number->string i)))))))))))
- sorted-lexical-gensyms)
- (values output-name-table occurrence-count-table)))))
|