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