[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Extended local defines.
This is about the issue of relaxing the local DEFINE's restrictions
and flushing LETREC. Using proof by algorithm, I show that the
proposed relaxation is computable. Enclosed is an R3RS program that
translates a simple Scheme program with extended local defines into
R3R Scheme.
Before this issue should be brought up in a Scheme meeting, the
subject of efficiency must be addressed. I strongly suspect a fast
implementation is easy in compilers that do alpha conversion. In
addition, since the number of local defines is usually less then 30,
graphs could be represented by an adjacency matrix, instead of a
vector of adjacency lists. Set operations could then be fast bit
operations.
John
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# eld.scm
# make.scm
# sc.scm
# sets.scm
# ts.scm
# This archive created: Mon Jul 18 10:06:17 1988
export PATH; PATH=/bin:$PATH
if test -f 'eld.scm'
then
echo shar: will not over-write existing file "'eld.scm'"
else
cat << \SHAR_EOF > 'eld.scm'
;;; Converts extended local define Scheme to
;;; R3R Scheme with LETREC's, LET's, and BEGIN's.
;;; John D. Ramsdell -- The MITRE Corporation -- July 1988
;;; ELD Scheme
;;; form ::= def | exp
;;; body ::= def* exp+
;;; def ::= (DEFINE id body)
;;; | (DEFINE (id+) body)
;;; exp ::= id
;;; | const
;;; | (QUOTE list)
;;; | (LAMBDA (id*) body)
;;; | (IF exp exp exp)
;;; | (SET! id exp)
;;; | (exp+)
;;; Converts ELD Scheme to R3R Scheme by analyzing the interdependency
;;; of local defines. Finds the strong components and a topological
;;; sort of a graph giving the interdependency. This information is
;;; used to construct R3R Scheme replacing the extended local defines
;;; with LETREC's, LET's, and BEGIN's.
;;; To use:
;;; (eld ELD-Scheme-form) => R3R-Scheme-form
;;; Keywords.
(define define-kw 'define)
(define quote-kw 'quote)
(define lambda-kw 'lambda)
(define if-kw 'if)
(define set-kw 'set!)
(define id? symbol?)
;;; Equality predicate for set elements.
(define same? eqv?)
;;; Entry procedure. All the excitement is in eld-body.
;;; No checks are made for syntactic correctness of ELD Scheme forms.
;;; The analysis should be done after alpha conversion.
(define (eld form) ; => form
(cond ((not (pair? form)) form)
((eq? (car form) define-kw)
(eld-def (lambda (form free)
(let ((name (cadr form)))
(if (element? name free)
(list*3 define-kw name
(make-binder
'letrec
(list form)
(list name)))
form)))
form))
((eld-exp (lambda (form free) form) form))))
;;; (define (name id*) body) =>
;;; (define name
;;; (lambda (id*)
;;; body))
(define (simplify-def def)
(let ((pattern (cadr def)))
(if (not (pair? pattern))
def
(let ((name (car pattern))
(args (cdr pattern))
(body (cddr def)))
(simplify-def ;; <- ignore this hack.
(list define-kw
name
(list*3 lambda-kw args body)))))))
;;; All eld-* procedures below return (c form free) except
;;; eld-body and eld-seq which return (c form-seq free).
;;; free is the set of free identifiers in the form.
(define (eld-def c def)
(let* ((def (simplify-def def))
(name (cadr def))
(body (cddr def)))
(eld-body (lambda (form-seq free)
(c (list*3 define-kw name form-seq)
free)) ; Note: name may be in free.
body)))
(define (eld-exp c exp)
(cond ((pair? exp) (eld-exp-is-pair c exp))
((id? exp) (c exp (singleton exp)))
(else (c exp (empty-set)))))
(define (eld-exp-is-pair c exp)
(let ((kw (car exp)))
(cond ((eq? kw quote-kw) (c exp (empty-set)))
((eq? kw lambda-kw) (eld-exp-lambda c exp))
((eq? kw if-kw) (eld-exp-if c exp))
((eq? kw set-kw) (eld-exp-set c exp))
(else (eld-exp-apply c exp)))))
(define (eld-exp-lambda c exp)
(let ((args (cadr exp))
(body (cddr exp)))
(eld-body
(lambda (form-seq free)
(c (list*3 lambda-kw args form-seq)
(set-difference free args)))
body)))
;;; See--there is no check for three expressions.
(define (eld-exp-if c exp)
(eld-exp-apply
(lambda (form free)
(c (cons (car exp) form) free))
(cdr exp)))
(define eld-exp-set eld-exp-if)
(define (eld-exp-apply c exp)
(if (null? exp)
(c '() (empty-set))
(eld-exp
(lambda (exp-first free-first)
(eld-exp-apply
(lambda (exp-rest free-rest)
(c (cons exp-first exp-rest)
(union free-first free-rest)))
(cdr exp)))
(car exp))))
(define eld-seq eld-exp-apply) ; => (c form-seq free)
(define (eld-body c exp) ; => (c form-seq free)
(let loop ((defs '()) (exps exp))
(let ((def (car exps))) ; Separate def* from exp+
(if (or (not (pair? def))
(not (eq? (car def) define-kw)))
(if (null? defs)
(eld-seq c exps) ; Speed hack.
(eld-def&seq c defs exps))
(loop (cons def defs) (cdr exps))))))
(define (eld-def&seq c defs seq)
(let* ((defs (list->vector defs))
(n (vector-length defs))
(f (make-vector n))) ; Vector of free sets.
(do ((v 0 (1+ v)))
((>= v n))
(eld-def
(lambda (form free)
(vector-set! defs v form) ; Update defs.
(vector-set! f v free))
(vector-ref defs v)))
(eld-seq ; Process exp+
(lambda (form free)
(eld-def-make-graph c defs f n form free))
seq)))
(define (eld-def-make-graph c defs f n seq free)
(let* ((g (make-vector n (empty-set)))
(env (do ((v 0 (1+ v))
(env '() (cons
(cons (cadr (vector-ref defs v)) v)
env)))
((>= v n) env)))
(names (map car env)) ; Assumes no duplicate names.
(free (set-difference ; Free to be return.
(do ((v 0 (1+ v))
(free free
(union free (vector-ref f v))))
((>= v n) free))
names)))
(do ((v 0 (1+ v))) ; Construct graph
((>= v n)) ; g has an edge from v to w (v->w),
(do ((l (vector-ref f v) (cdr l)))
((null? l)) ; iff the body defining w uses v.
(let ((a (assv (car l) env)))
(if (pair? a)
(vector-set! g v (adjoin (cdr a) (vector-ref g v)))))))
(eld-analyze-graph c defs g seq free)))
(define (eld-analyze-graph c defs g seq free)
(let loop ((ts (analyze-dependency g)) (form seq))
(if (null? ts) ; For each compressed component,
(c form free) ; construct a binder, a LET form
(let ((cp (car ts)) ; or a LETREC form.
(ts (cdr ts)))
(loop ts (construct-binder
(if (car cp)
'letrec
'let)
(cdr cp) g defs form))))))
(define (construct-binder binder cp g defs form)
(let loop ((cp cp) (binder-defs '()))
(if (null? cp)
(make-binder binder binder-defs form)
(let ((v (car cp))
(cp (cdr cp)))
(loop cp (cons (vector-ref defs v) binder-defs))))))
(define (make-binder binder defs form)
`((,binder ,(map (lambda (def)
(let ((var (cadr def))
(val (cddr def)))
`(,var ,(seq->exp val))))
defs)
,@form)))
(define (seq->exp seq)
(if (null? (cdr seq))
(car seq)
`(begin ,@seq)))
;;; list* is not part of R3RS.
(define (list*3 a b c)
(cons a (cons b c)))
SHAR_EOF
fi # end of overwriting check
if test -f 'make.scm'
then
echo shar: will not over-write existing file "'make.scm'"
else
cat << \SHAR_EOF > 'make.scm'
(define (make)
(load "eld.scm")
(load "sets.scm")
(load "sc.scm")
(load "ts.scm"))
(define eld-testers
'((define (a b) b)
(define (a b)
(define (c w) (a w))
(define (d x) (c w))
(c w))
(define (a b)
(define (c w) (d w))
(define (d x) (c w))
(c w))
(define (a b)
(define c 3)
(define d 2)
(+ b c d))))
(define (eld-test)
(for-each
(lambda (form)
(pp (eld form))
(newline))
eld-testers))
SHAR_EOF
fi # end of overwriting check
if test -f 'sc.scm'
then
echo shar: will not over-write existing file "'sc.scm'"
else
cat << \SHAR_EOF > 'sc.scm'
;;; Algorithm to find strongly connected components of a graph.
;;; A fairly direct translation of the program given in
;;; "The Design and Analysis of Computer Algorithms", Aho, Hopcroft,
;;; and Ullman, Adison-Wesley, 1974.
;;; g is an vector containing adjacency lists.
;;; Returns a vector in which all nodes of a strong component
;;; are given in the adjacency list of one of the nodes.
(define (sc g)
(let* ((n (vector-length g))
(dfn (make-vector n))
(old (make-vector n '#f))
(lowlink (make-vector n))
(sc (make-vector n (empty-set)))
(count 0)
(stack '()))
(letrec
((search
(lambda (v)
(vector-set! old v '#t)
(vector-set! dfn v count)
(vector-set! lowlink v count)
(set! count (+ count 1))
(set! stack (cons v stack))
(do ((l (vector-ref g v) (cdr l)))
((null? l))
(let ((w (car l)))
(if (not (vector-ref old w))
(begin
(search w)
(vector-set! lowlink v
(min (vector-ref lowlink v)
(vector-ref lowlink w))))
(if (and (< (vector-ref dfn w) (vector-ref dfn v))
(memv w stack))
(vector-set! lowlink v
(min (vector-ref lowlink v)
(vector-ref dfn w)))))))
(if (= (vector-ref lowlink v)
(vector-ref dfn v))
(let loop ()
(let ((x (car stack)))
(vector-set! sc v
(adjoin x (vector-ref sc v)))
(set! stack (cdr stack))
(if (not (= x v)) (loop))))))))
(do ((v 0 (1+ v)))
((>= v n) sc)
(if (not (vector-ref old v))
(search v))))))
SHAR_EOF
fi # end of overwriting check
if test -f 'sets.scm'
then
echo shar: will not over-write existing file "'sets.scm'"
else
cat << \SHAR_EOF > 'sets.scm'
;;; Sets much like those used by Guy Lewis Steele Jr.
;;; in his Rabbit compiler.
(define (element? e s)
(and (not (null? s))
(or (same? e (car s))
(element? e (cdr s)))))
(define (adjoin e s)
(if (element? e s)
s
(cons e s)))
(define (union s0 s1)
(do ((s s1 (cdr s))
(u s0 (adjoin (car s) u)))
((null? s) u)))
(define (intersect s0 s1)
(cond ((null? s0) '())
((element? (car s0) s1)
(cons (car s0) (intersect (cdr s0) s1)))
(else (intersect (cdr s0) s1))))
(define (remove e s)
(cond ((null? s) s)
((same? e (car s)) (cdr s))
(else
(let ((s0 (remove e (cdr s))))
(if (eq? s0 (cdr s))
s
(cons (car s) s0))))))
(define (set-difference s0 s1)
(do ((s s0 (cdr s))
(d '() (if (element? (car s) s1)
d
(cons (car s) d))))
((null? s) d)))
(define (empty-set)
'())
(define empty? null?)
(define (singleton e)
(list e))
(define (singleton? s)
(and (not (null? s))
(null? (cdr s))))
SHAR_EOF
fi # end of overwriting check
if test -f 'ts.scm'
then
echo shar: will not over-write existing file "'ts.scm'"
else
cat << \SHAR_EOF > 'ts.scm'
;;; Topological sort
;;; Takes a graph represented as a vector of adjacency lists.
;;; Returns a topological sort. The sort is a list of components.
;;; Each component is marked with a boolean telling if the component
;;; is cyclic. Non-cyclic components have been merged when no
;;; order is implied.
(define (analyze-dependency g)
(ts g (sc g)))
;;; Constructs the condensed graph given the strong components.
;;; The condensed graph is the acyclic graph gotten by condensing
;;; each strong component into a single node.
(define (ts g sc)
(let* ((n (vector-length g))
(out (make-vector n (empty-set))) ; The condensed graph.
(in (make-vector n (empty-set)))) ; Condensed graph's dual.
(do ((v 0 (1+ v)))
((>= v n)) ; Construct condensed graph.
(do ((l (vector-ref sc v) (cdr l)))
((null? l))
(let ((w (car l)))
(vector-set! out v
(union (vector-ref out v)
(vector-ref g w)))))
(vector-set! out v
(set-difference (vector-ref out v)
(vector-ref sc v))))
(do ((v 0 (1+ v)))
((>= v n)) ; Construct dual.
(do ((l (vector-ref out v) (cdr l)))
((null? l))
(let ((w (car l)))
(vector-set! in w
(union (vector-ref in w)
(singleton v))))))
(ts-bfs g sc out in n)))
;;; A breadth first search topological sort.
(define (ts-bfs g sc out in n)
(let ((search ; List of strong components.
(do ((v 0 (1+ v))
(s '() (if (empty? (vector-ref sc v))
s
(cons v s))))
((>= v n) s))))
(letrec
((main-loop ; Finds nodes to process on this pass.
(lambda (search next-search is-cyclic new-ts ts)
(if (null? search)
(restart-bfs next-search is-cyclic new-ts ts)
(let ((v (car search))
(search (cdr search)))
(if (and (empty? (vector-ref out v))
(eq? is-cyclic (cyclic? (vector-ref sc v) g)))
(main-loop search next-search
is-cyclic (cons v new-ts) ts)
(main-loop search (cons v next-search)
is-cyclic new-ts ts))))))
(restart-bfs ; Processes nodes with zero out degree.
(lambda (search is-cyclic new-ts ts)
(let ((ts (if is-cyclic ; Compute new ts for this pass.
(let loop ((ts ts) (new-ts new-ts))
(if (null? new-ts)
ts
(let ((v (car new-ts))
(new-ts (cdr new-ts)))
(loop (cons
(cons is-cyclic
(vector-ref sc v))
ts)
new-ts))))
(if (null? new-ts)
ts
(cons (cons is-cyclic new-ts) ts)))))
(do ((new-ts new-ts (cdr new-ts))) ; Update condensed graph.
((null? new-ts) (start-bfs search (not is-cyclic) ts))
(let ((v (car new-ts))) ; ^ Switch search mode.
(vector-set! sc v (empty-set))
(do ((l (vector-ref in v) (cdr l)))
((null? l))
(let ((w (car l)))
(vector-set! out w
(remove v (vector-ref out w))))))))))
(start-bfs
(lambda (search is-cyclic ts)
(if (null? search)
ts
(main-loop search '() is-cyclic '() ts)))))
(start-bfs search #f '()))))
(define (cyclic? cp g) ; A component is cyclic iff
(or (not (singleton? cp)) ; it does not have one element,
(let ((e (car cp))) ; or that element does not have
(element? e (vector-ref g e))))) ; a self-loop.
SHAR_EOF
fi # end of overwriting check
# End of shell archive
exit 0