1#lang racket 2(require "parse.rkt" 3 racket/match) 4 5(provide compile-simplified) 6 7;; The compiler generates references to "prims.rkt" and 8;; "runtime.rkt" exports, as well as Racket forms 9;; and functions. The `ctx' argument provides 10;; an appropriate context for those bindings (in 11;; the form of a syntax object to use with d->s-o). 12(define (compile-simplified stmt ctx #:module-exports? [module-exports? #f]) 13 (datum->syntax 14 ctx 15 (parameterize ([current-compile-context ctx]) 16 (compile-a60 stmt 'void (empty-context) #t module-exports?)))) 17 18(define current-compile-context (make-parameter #f)) 19 20(define (compile-a60 stmt next-label context add-to-top-level? module-exports?) 21 (match stmt 22 [(a60:block decls statements) 23 (compile-block decls statements next-label context add-to-top-level?)] 24 [else 25 (compile-statement stmt next-label context)])) 26 27(define (compile-block decls statements next-label context add-to-top-level?) 28 (let* ([labels-with-numbers (map car statements)] 29 [labels (map (lambda (l) 30 (if (stx-number? l) 31 (datum->syntax 32 l 33 (string->symbol (format "~a" (syntax-e l))) 34 l 35 l) 36 l)) 37 labels-with-numbers)] 38 ;; Build environment by adding labels, then decls: 39 [context (foldl (lambda (decl context) 40 (match decl 41 [(a60:proc-decl result-type var arg-vars by-value-vars arg-specs body) 42 (add-procedure context var result-type arg-vars by-value-vars arg-specs)] 43 [(a60:type-decl type ids) 44 (add-atoms context ids type)] 45 [(a60:array-decl type arrays) 46 (add-arrays context 47 (map car arrays) ; names 48 (map cdr arrays) ; dimensions 49 type)] 50 [(a60:switch-decl name exprs) 51 (add-switch context name)])) 52 (add-labels 53 context 54 labels) 55 decls)]) 56 ;; Generate bindings and initialization for all decls, 57 ;; plus all statements (thunked): 58 (let ([bindings 59 (append 60 (apply 61 append 62 ;; Decls: 63 (map (lambda (decl) 64 (match decl 65 [(a60:proc-decl result-type var arg-vars by-value-vars arg-specs body) 66 (let ([code 67 `(lambda (kont . ,arg-vars) 68 ;; Include the declaration variables 69 ,@(for/list ([arg-spec (in-list arg-specs)]) 70 `(void ,@(cdr arg-spec))) 71 ;; Extract by-value variables 72 (let ,(map (lambda (var) 73 `[,var (get-value ,var)]) 74 by-value-vars) 75 ;; Set up the result variable and done continuation: 76 ,(let ([result-var (gensym 'prec-result)] 77 [done (gensym 'done)]) 78 `(let* ([,result-var undefined] 79 [,done (lambda () (kont ,result-var))]) 80 ;; Include the compiled body: 81 ,(compile-a60 body done 82 (add-settable-procedure 83 (add-bindings 84 context 85 arg-vars 86 by-value-vars 87 arg-specs) 88 var 89 result-type 90 result-var) 91 #f 92 #f)))))]) 93 (if add-to-top-level? 94 (let ([exported (gensym 'exported)]) 95 (list 96 `(define ,var ,code) 97 `(define ,exported 98 (let ([,var (λ args 99 (apply ,var (λ (x) x) 100 (map (λ (x) (λ () x)) args)))]) 101 ,var)) 102 `(provide (rename-out [,exported ,var])) 103 `(namespace-set-variable-value! ',var ,var))) 104 (list 105 `(define ,var 106 ,code))))] 107 [(a60:type-decl type ids) 108 (map (lambda (id) `(define ,id undefined)) ids)] 109 [(a60:array-decl type arrays) 110 (map (lambda (array) 111 `(define ,(car array) 112 (make-array 113 ,@(apply 114 append 115 (map 116 (lambda (bp) 117 (list 118 (compile-expression (car bp) context 'num) 119 (compile-expression (cdr bp) context 'num))) 120 (cdr array)))))) 121 arrays)] 122 [(a60:switch-decl name exprs) 123 (list 124 `(define ,name (make-switch ,@(map (lambda (e) `(lambda () ,(compile-expression e context 'des))) 125 exprs))))] 126 [else (error "can't compile decl")])) 127 decls)) 128 ;; Statements: most of the work is in `compile-statement', but 129 ;; we provide the continuation label: 130 (cdr 131 (foldr (lambda (stmt label next-label+compiled) 132 (cons label 133 (cons 134 `(define ,label 135 (lambda () 136 ,(compile-statement (cdr stmt) 137 (car next-label+compiled) 138 context))) 139 (cdr next-label+compiled)))) 140 (cons next-label null) 141 statements 142 labels)))]) 143 ;; Check for duplicate bindings: 144 (let ([dup 145 (check-duplicate-identifier 146 (for/list ([binding (in-list bindings)] 147 #:when (match binding 148 [`(define ,(? identifier? id) ,exp) #t] 149 [_ #f])) 150 (list-ref binding 1)))]) 151 (when dup 152 (raise-syntax-error 153 #f 154 "name defined twice" 155 dup))) 156 ;; Generate code; body of leterec jumps to the first statement label. 157 (if add-to-top-level? 158 `(begin 159 ,@bindings 160 (,(caar statements))) 161 `(let () 162 ,@bindings 163 (,(caar statements))))))) 164 165(define (compile-statement statement next-label context) 166 (match statement 167 [(a60:block decls statements) 168 (compile-block decls statements next-label context #f)] 169 [(a60:branch test (a60:goto then) (a60:goto else)) 170 `(if (check-boolean ,(compile-expression test context 'bool)) 171 (goto ,(check-label then context)) 172 (goto ,(check-label else context)))] 173 [(a60:goto label) 174 (at (expression-location label) 175 `(goto ,(compile-expression label context 'des)))] 176 [(a60:dummy) 177 `(,next-label)] 178 [(a60:call proc args) 179 (at (expression-location proc) 180 `(,(compile-expression proc context 'func) 181 (lambda (val) 182 (,next-label)) 183 ,@(map (lambda (arg) (compile-argument arg context)) 184 args)))] 185 [(a60:assign vars val) 186 ;; >>>>>>>>>>>>>>> Start clean-up here <<<<<<<<<<<<<<<<< 187 ;; Lift out the spec-finding part, and use it to generate 188 ;; an expected type that is passed to `compile-expression': 189 `(begin 190 (let ([val ,(compile-expression val context 'numbool)]) 191 ,@(map (lambda (avar) 192 (let ([var (a60:variable-name avar)]) 193 (at var 194 (cond 195 [(null? (a60:variable-indices avar)) 196 (cond 197 [(call-by-name-variable? var context) 198 => (lambda (spec) 199 `(set-target! ,var ',var (coerce ',(spec-coerce-target spec null) val)))] 200 [(procedure-result-variable? var context) 201 `(set! ,(procedure-result-variable-name var context) 202 (coerce ',(spec-coerce-target (procedure-result-spec var context) null) val))] 203 [(or (settable-variable? var context) 204 (array-element? var context)) 205 => (lambda (spec) 206 `(,(if (own-variable? var context) 'set-box! 'set!) 207 ,var 208 (coerce ',(spec-coerce-target spec null) val)))] 209 [else (raise-syntax-error #f "confused by assignment" (expression-location var))])] 210 [else 211 (let ([spec (or (array-element? var context) 212 (call-by-name-variable? var context))]) 213 `(array-set! ,(compile-expression (make-a60:variable var null) context 'numbool) 214 (coerce ',(spec-coerce-target spec null) val) 215 ,@(map (lambda (e) (compile-expression e context 'num)) 216 (a60:variable-indices avar))))])))) 217 vars)) 218 (,next-label))] 219 [else (error "can't compile statement")])) 220 221(define (compile-expression expr context type) 222 (match expr 223 [(? (lambda (x) (and (syntax? x) (number? (syntax-e x)))) n) 224 (if (eq? type 'des) 225 ;; Need a label: 226 (check-label (datum->syntax expr 227 (string->symbol (number->string (syntax-e expr))) 228 expr 229 expr) 230 context) 231 ;; Normal use of a number: 232 (begin 233 (check-type 'num type expr) 234 (as-builtin n)))] 235 [(? (lambda (x) (and (syntax? x) (boolean? (syntax-e x)))) n) (check-type 'bool type expr) (as-builtin n)] 236 [(? (lambda (x) (and (syntax? x) (string? (syntax-e x)))) n) (check-type 'string type expr) (as-builtin n)] 237 [(? identifier? i) (compile-expression (make-a60:variable i null) context type)] 238 [(? symbol? i) ; either a generated label or 'val: 239 (unless (eq? expr 'val) 240 (check-type 'des type expr)) 241 (datum->syntax #f i)] 242 [(a60:subscript array index) 243 ;; Maybe a switch index, or maybe an array reference 244 (at array 245 (cond 246 [(array-element? array context) 247 `(array-ref ,array ,(compile-expression index context 'num))] 248 [(switch-variable? array context) 249 `(switch-ref ,array ,(compile-expression index context 'num))] 250 [else (raise-syntax-error 251 #f 252 "confused by variable" 253 array)]))] 254 [(a60:binary t argt op e1 e2) 255 (check-type t type expr) 256 (at op 257 `(,(as-builtin op) ,(compile-expression e1 context argt) ,(compile-expression e2 context argt)))] 258 [(a60:unary t argt op e1) 259 (check-type t type expr) 260 (at op 261 `(,(as-builtin op) ,(compile-expression e1 context argt)))] 262 [(a60:variable var subscripts) 263 (let ([sub (lambda (wrap v) 264 (wrap 265 (if (null? subscripts) 266 v 267 `(array-ref ,v ,@(map (lambda (e) (compile-expression e context 'num)) subscripts)))))]) 268 (cond 269 [(call-by-name-variable? var context) 270 => (lambda (spec) 271 (check-spec-type spec type var subscripts) 272 (sub (lambda (val) `(coerce ',(spec-coerce-target spec subscripts) ,val)) `(get-value ,var)))] 273 [(primitive-variable? var context) 274 => (lambda (name) 275 (sub values 276 (datum->syntax 277 (current-compile-context) 278 name 279 var 280 var)))] 281 [(and (procedure-result-variable? var context) 282 (not (eq? type 'func))) 283 (unless (null? subscripts) 284 (raise-syntax-error "confused by subscripts" var)) 285 (let ([spec (procedure-result-spec var context)]) 286 (check-spec-type spec type var null) 287 (at var 288 `(coerce 289 ',(spec-coerce-target spec null) 290 ,(procedure-result-variable-name var context))))] 291 [(or (procedure-result-variable? var context) 292 (procedure-variable? var context) 293 (label-variable? var context) 294 (settable-variable? var context) 295 (array-element? var context)) 296 => (lambda (spec) 297 (let ([spec (if (or (procedure-result-variable? var context) 298 (procedure-variable? var context) 299 (and (array-element? var context) 300 (null? subscripts))) 301 #f ;; need just the proc or array... 302 spec)]) 303 (check-spec-type spec type var subscripts) 304 (let ([target (spec-coerce-target spec subscripts)]) 305 (sub (if target 306 (lambda (v) `(coerce ',target ,v)) 307 values) 308 (if (own-variable? var context) 309 `(unbox ,var) 310 var)))))] 311 [else (raise-syntax-error 312 #f 313 "confused by expression" 314 (expression-location var))]))] 315 316 [(a60:app func args) 317 (at (expression-location func) 318 `(,(compile-expression func context 'func) 319 values 320 ,@(map (lambda (e) (compile-argument e context)) 321 args)))] 322 [(a60:if test then else) 323 `(if (check-boolean ,(compile-expression test context 'bool)) 324 ,(compile-expression then context type) 325 ,(compile-expression else context type))] 326 [else (error 'compile-expression "can't compile expression ~a" expr)])) 327 328(define (expression-location expr) 329 (if (syntax? expr) 330 expr 331 (match expr 332 [(a60:subscript array index) (expression-location array)] 333 [(a60:binary type argtype op e1 e2) op] 334 [(a60:unary type argtype op e1) op] 335 [(a60:variable var subscripts) (expression-location var)] 336 [(a60:app func args) 337 (expression-location func)] 338 [else #f]))) 339 340(define (compile-argument arg context) 341 (cond 342 [(or (and (a60:variable? arg) 343 (not (let ([v (a60:variable-name arg)]) 344 (or (procedure-variable? v context) 345 (label-variable? v context) 346 (primitive-variable? v context))))) 347 (a60:subscript? arg)) 348 (let ([arg (if (a60:subscript? arg) 349 (make-a60:variable (a60:subscript-array arg) 350 (list (a60:subscript-index arg))) 351 arg)]) 352 `(case-lambda 353 [() ,(compile-expression arg context 'any)] 354 [(val) ,(compile-statement (make-a60:assign (list arg) 'val) 'void context)]))] 355 [(identifier? arg) 356 (compile-argument (make-a60:variable arg null) context)] 357 [else `(lambda () ,(compile-expression arg context 'any))])) 358 359(define (check-type got expected expr) 360 (or (eq? expected 'any) 361 (case got 362 [(num) (memq expected '(num numbool))] 363 [(bool) (memq expected '(bool numbool))] 364 [(des) (memq expected '(des))] 365 [(func) (memq expected '(func))] 366 [else #f]) 367 (raise-syntax-error #f 368 (format "type mismatch (~a != ~a)" got expected) 369 expr))) 370 371(define (check-spec-type spec type expr subscripts) 372 (let ([target (spec-coerce-target spec subscripts)]) 373 (when target 374 (case (syntax-e target) 375 [(integer real) (check-type 'num type expr)] 376 [(boolean) (check-type 'bool type expr)] 377 [(procedure) (check-type 'func type expr)])))) 378 379 380(define (check-label l context) 381 (if (or (symbol? l) 382 (label-variable? l context)) 383 l 384 (raise-syntax-error 385 #f 386 "undefined label" 387 l))) 388 389(define (at stx expr) 390 (if (syntax? stx) 391 (datum->syntax (current-compile-context) expr stx) 392 expr)) 393 394(define (as-builtin stx) 395 ;; Preserve source loc, but change to reference to 396 ;; a builtin operation by changing the context: 397 (datum->syntax 398 (current-compile-context) 399 (syntax-e stx) 400 stx 401 stx)) 402 403;; -------------------- 404 405(define (empty-context) 406 `(((sign prim sign) 407 (entier prim entier) 408 409 (sin prim a60:sin) 410 (cos prim a60:cos) 411 (acrtan prim a60:arctan) 412 (sqrt prim a60:sqrt) 413 (abs prim a60:abs) 414 (ln prim a60:ln) 415 (exp prim a60:exp) 416 417 (prints prim prints) 418 (printn prim printn) 419 (printsln prim printsln) 420 (printnln prim printnln)))) 421 422(define (add-labels context l) 423 (cons (map (lambda (lbl) (cons (if (symbol? lbl) 424 (datum->syntax #f lbl) 425 lbl) 426 'label)) l) 427 context)) 428 429(define (add-procedure context var result-type arg-vars by-value-vars arg-specs) 430 (cons (list (cons var 'procedure)) 431 context)) 432 433(define (add-settable-procedure context var result-type result-var) 434 (cons (list (cons var `(settable-procedure ,result-var ,result-type))) 435 context)) 436 437(define (add-atoms context ids type) 438 (cons (map (lambda (id) (cons id type)) ids) 439 context)) 440 441(define (add-arrays context names dimensionses type) 442 (cons (map (lambda (name dimensions) 443 (cons name `(array ,type ,(length dimensions)))) 444 names dimensionses) 445 context)) 446 447(define (add-switch context name) 448 (cons (list (cons name 'switch)) 449 context)) 450 451(define (add-bindings context arg-vars by-value-vars arg-specs) 452 (cons (map (lambda (var) 453 (let ([spec (or (ormap (lambda (spec) 454 (and (ormap (lambda (x) (bound-identifier=? var x)) 455 (cdr spec)) 456 (car spec))) 457 arg-specs) 458 #'unknown)]) 459 (cons var 460 (if (ormap (lambda (x) (bound-identifier=? var x)) by-value-vars) 461 spec 462 (list 'by-name spec))))) 463 arg-vars) 464 context)) 465 466;; var-binding : syntax context -> symbol 467;; returns an identifier indicating where the var is 468;; bound, or 'free if it isn't. The compiler inserts 469;; top-level procedure definitions into the namespace; if 470;; the variable is bound there, it is a procedure. 471(define (var-binding var context) 472 (cond 473 [(null? context) 474 (let/ec k 475 (namespace-variable-value (syntax-e var) 476 #t 477 (lambda () (k 'free))) 478 'procedure)] 479 [else 480 (let ([m (var-in-rib var (car context))]) 481 (or m (var-binding var (cdr context))))])) 482 483(define (var-in-rib var rib) 484 (ormap (lambda (b) 485 (if (symbol? (car b)) 486 ;; primitives: 487 (and (eq? (syntax-e var) (car b)) 488 (cdr b)) 489 ;; everything else: 490 (and (bound-identifier=? var (car b)) 491 (cdr b)))) 492 rib)) 493 494(define (primitive-variable? var context) 495 (let ([v (var-binding var context)]) 496 (and (pair? v) 497 (eq? (car v) 'prim) 498 (cadr v)))) 499 500(define (call-by-name-variable? var context) 501 (let ([v (var-binding var context)]) 502 (and (pair? v) 503 (eq? (car v) 'by-name) 504 (cadr v)))) 505 506(define (procedure-variable? var context) 507 (let ([v (var-binding var context)]) 508 (eq? v 'procedure))) 509 510(define (procedure-result-variable? var context) 511 (let ([v (var-binding var context)]) 512 (and (pair? v) 513 (eq? (car v) 'settable-procedure) 514 (cdr v)))) 515 516(define (procedure-result-variable-name var context) 517 (let ([v (procedure-result-variable? var context)]) 518 (car v))) 519 520(define (procedure-result-spec var context) 521 (let ([v (procedure-result-variable? var context)]) 522 (cadr v))) 523 524(define (label-variable? var context) 525 (let ([v (var-binding var context)]) 526 (eq? v 'label))) 527 528(define (switch-variable? var context) 529 (let ([v (var-binding var context)]) 530 (eq? v 'switch))) 531 532(define (settable-variable? var context) 533 (let ([v (var-binding var context)]) 534 (or (box? v) 535 (and (syntax? v) 536 (memq (syntax-e v) '(integer real boolean)) 537 v)))) 538 539(define (own-variable? var context) 540 (let ([v (var-binding var context)]) 541 (box? v))) 542 543(define (array-element? var context) 544 (let ([v (var-binding var context)]) 545 (and (pair? v) 546 (eq? (car v) 'array) 547 (or (cadr v) 548 #'unknown)))) 549 550(define (spec-coerce-target spec subscripts) 551 (cond 552 [(and (syntax? spec) (memq (syntax-e spec) '(string label switch real integer boolean unknown))) spec] 553 [(and (syntax? spec) (memq (syntax-e spec) '(unknown))) #f] 554 [(or (not spec) (not (pair? spec))) #f] 555 [(eq? (car spec) 'array) (if (null? subscripts) #'array (cadr spec))] 556 [(eq? (car spec) 'procedure) #'procedure] 557 [else #f])) 558 559(define (stx-number? a) (and (syntax? a) (number? (syntax-e a)))) 560