/usr/share/racket/pkgs/algol60/simplify.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | #lang racket
(require "parse.rkt"
(except-in racket/match ==))
(provide simplify)
;; flatten/label-block : list-of-decl list-of-stmt -> block-stmt
;; Desugars `for', converts `if' so that it's always of the form
;; `if <test> then goto <label> else goto <label>', flattens
;; compound statements into the enclosing block, and gives every
;; statement exactly one label. The result usually has lots of
;; "dummy" statements that could easily be eliminated by merging
;; labels.
(define (flatten/label-block decls statements ->stx)
(define extra-decls null)
(define new-statements
(let loop ([l statements])
(if (null? l)
null
(match (car l)
[(a60:block decls statements)
(cons (cons (gensym 'block) (flatten/label-block decls statements ->stx))
(loop (cdr l)))]
[(a60:compound statements)
(loop (append statements (cdr l)))]
[(a60:branch test then else)
(if (and (a60:goto? then) (a60:goto? else))
(cons (cons (gensym 'branch) (car l))
(loop (cdr l)))
(let ([then-label (gensym 'then)]
[else-label (gensym 'else)]
[cont-label (gensym 'if-cont)])
(loop
(list*
(make-a60:branch test (make-a60:goto then-label) (make-a60:goto else-label))
(make-a60:label then-label then)
(make-a60:goto cont-label)
(make-a60:label else-label else)
(make-a60:label cont-label (make-a60:dummy))
(cdr l)))))]
[(a60:for variable val-exprs body)
(let ([body-label (gensym 'for-body)]
[cont-label (gensym 'for-cont)])
(letrec ([make-init+test+increment+loop
(lambda (value)
(match value
[(a60:for-number value)
(values (make-a60:assign (list variable) (make-a60:binary 'num 'num
(->stx '+)
(->stx '0)
value)) ; +0 => number
(->stx #t)
(make-a60:dummy)
#f)]
[(a60:for-step start step end)
(values (make-a60:assign (list variable) start)
(make-a60:binary 'bool 'num
(->stx '<=)
(make-a60:binary 'num 'num
(->stx '*)
(make-a60:binary 'num 'num (->stx '-) variable end)
(make-a60:app (->stx 'sign) (list step)))
(->stx '0))
(make-a60:assign (list variable) (make-a60:binary 'num 'num (->stx '+) variable step))
#t)]
[(a60:for-while value test)
(values (make-a60:assign (list variable) value)
test
(make-a60:assign (list variable) value)
#t)]))])
(if (= 1 (length val-exprs))
(let-values ([(init test inc loop?) (make-init+test+increment+loop (car val-exprs))])
(loop (list*
init
(make-a60:label body-label (make-a60:dummy))
(make-a60:branch test
(make-a60:compound
(list
body
inc
(if loop?
(make-a60:goto body-label)
(make-a60:dummy))))
(make-a60:dummy))
(cdr l))))
(let* ([stage-name (datum->syntax #f (gensym 'stage-number))]
[switch-name (datum->syntax #f (gensym 'stage-switch))]
[end-switch-name (datum->syntax #f (gensym 'stage-switch))]
[stage-var (make-a60:variable stage-name null)]
[start-labels (map (lambda (x) (gensym 'stage)) (append val-exprs (list 'extra)))]
[end-labels (map (lambda (x) (gensym 'stage)) val-exprs)])
(set! extra-decls (list* stage-name
(cons switch-name start-labels)
(cons end-switch-name end-labels)
extra-decls))
(loop
(append
(list (make-a60:assign (list stage-var) (->stx '0)))
(let loop ([start-labels start-labels][end-labels end-labels][val-exprs val-exprs])
(if (null? val-exprs)
(list (make-a60:label (car start-labels) (make-a60:dummy)))
(let-values ([(init test inc loop?) (make-init+test+increment+loop (car val-exprs))])
(list*
(make-a60:label (car start-labels) (make-a60:dummy))
init
(make-a60:branch test
(make-a60:goto body-label)
(make-a60:compound
(list
(make-a60:assign (list stage-var) (make-a60:binary 'num 'num
(->stx '+)
(->stx '1)
stage-var))
(make-a60:goto (make-a60:subscript switch-name stage-var)))))
(make-a60:label (car end-labels) (make-a60:dummy))
inc
(if loop?
(make-a60:goto (car start-labels))
(make-a60:goto (cadr start-labels)))
(loop (cdr start-labels)
(cdr end-labels)
(cdr val-exprs))))))
(list
(make-a60:goto cont-label)
(make-a60:label body-label (make-a60:dummy))
body
(make-a60:goto (make-a60:subscript end-switch-name stage-var))
(make-a60:label cont-label (make-a60:dummy)))
(cdr l)))))))]
[(a60:label name statement)
(cons (cons name (make-a60:dummy))
(loop (cons statement (cdr l))))]
[else
(cons (cons (gensym 'other) (car l))
(loop (cdr l)))]))))
(make-a60:block
(append
(map (lambda (decl)
(match decl
[(a60:proc-decl result-type var arg-vars by-value-vars arg-specs body)
(make-a60:proc-decl result-type var arg-vars by-value-vars arg-specs
(simplify-statement body ->stx))]
[else decl]))
decls)
(map (lambda (extra)
(if (identifier? extra)
(make-a60:type-decl (->stx 'integer) (list extra))
(make-a60:switch-decl (car extra) (map (lambda (x)
(make-a60:variable (datum->syntax #f x) null))
(cdr extra)))))
extra-decls))
(if (null? new-statements)
(list (cons (gensym 'other) (make-a60:dummy)))
new-statements)))
(define (simplify stmt ctx)
(simplify-statement stmt (lambda (x)
(datum->syntax
ctx
x))))
(define (simplify-statement stmt ->stx)
(match stmt
[(a60:block decls statements)
(flatten/label-block decls statements ->stx)]
[(a60:compound statements)
(flatten/label-block null statements ->stx)]
[else stmt]))
|