home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / flic / ast-to-flic.scm next >
Encoding:
Text File  |  1994-09-27  |  9.5 KB  |  170 lines  |  [TEXT/CCL2]
  1.      (values
  2.            '()
  3.            (if (null? more-bindings)
  4.                newerbody
  5.                (begin
  6.              (munge-specializers more-bindings)
  7.              (make-flic-let more-bindings newerbody '#t))))))
  8.           ))))
  9.  
  10.  
  11. (define (single-definition-rhs decl)
  12.   (let* ((def-list  (valdef-definitions decl))
  13.      (def       (car def-list))
  14.      (rhs-list  (single-fun-def-rhs-list def))
  15.      (rhs       (car rhs-list)))
  16.     ;; All of this error checking could be omitted for efficiency, since
  17.     ;; none of these conditions are supposed to happen anyway.
  18.     (cond ((not (null? (cdr def-list)))
  19.        (error "Decl has multiple definitions: ~s." decl))
  20.       ((not (null? (single-fun-def-where-decls def)))
  21.        (error "Definition has non-null where-decls list: ~s." decl))
  22.       ((not (null? (cdr rhs-list)))
  23.        (error "Definition has multiple right-hand-sides: ~s." decl))
  24.       ((not (is-type? 'omitted-guard (guarded-rhs-guard rhs)))
  25.        (error "Definition has a guard: ~s." decl)))
  26.     (guarded-rhs-rhs rhs)))
  27.  
  28.  
  29. ;;; For generic functions with specialized versions, we need to inline
  30. ;;; the call to the generic version inside the body of the specialized
  31. ;;; version, and save the argument patterns away for the optimizer to
  32. ;;; mess with later.
  33.  
  34. (define (munge-specializers bindings)
  35.   (dolist (var bindings)
  36.     (let ((specializers  (var-specializers var)))
  37.       (dolist (s specializers)
  38.     (let* ((svar   (car s))
  39.            (sval   (var-value svar))
  40.            (lambda (if (flic-lambda? sval)
  41.                sval
  42.                (make-flic-lambda '() sval)))
  43.            (app    (if (flic-lambda? sval)
  44.                (flic-lambda-body sval)
  45.                sval)))
  46.       ;; Ignore bogus expansions.  You can get them if you try to
  47.       ;; make specializers for functions that don't have any
  48.       ;; dictionary variables.
  49.       (when (and (flic-app? app)
  50.              (flic-ref? (flic-app-fn app))
  51.              (eq? (flic-ref-var (flic-app-fn app)) var))
  52.         ;; Save the lambda for later pattern matching
  53.         (setf (cdr s) (copy-flic-top lambda))
  54.         ;; Inline the call in the specialized function body
  55.         (setf (flic-app-fn app) (wrap-with-let var (var-value var))))
  56.       )))))
  57.  
  58.  
  59. ;;; These are all straightforward translations.
  60.  
  61. (define-ast-to-flic if (object)
  62.   (make-flic-if
  63.     (ast-to-flic-1 (if-test-exp object))
  64.     (ast-to-flic-1 (if-then-exp object))
  65.     (ast-to-flic-1 (if-else-exp object))))
  66.  
  67. (define-ast-to-flic case-block (object)
  68.   (make-flic-case-block
  69.     (case-block-block-name object)
  70.     (ast-to-flic/list (case-block-exps object))))
  71.  
  72. (define-ast-to-flic return-from (object)
  73.   (make-flic-return-from
  74.     (return-from-block-name object)
  75.     (ast-to-flic-1 (return-from-exp object))))
  76.  
  77. (define-ast-to-flic and-exp (object)
  78.   (make-flic-and (ast-to-flic/list (and-exp-exps object))))
  79.   
  80.  
  81. ;;; Applications.  Uncurry here.  It's more convenient to do the
  82. ;;; optimizer on fully uncurried applications.  After the optimizer
  83. ;;; has run, all applications are adjusted based on observed arity
  84. ;;; of the functions and the saturated? flag is set correctly.
  85.  
  86. (define-ast-to-flic app (object)
  87.   (ast-to-flic-app-aux object '()))
  88.  
  89. (define (ast-to-flic-app-aux object args)
  90.   (if (is-type? 'app object)
  91.       (ast-to-flic-app-aux
  92.         (app-fn object)
  93.     (cons (ast-to-flic-1 (app-arg object)) args))
  94.       (make-flic-app (ast-to-flic-1 object) args '#f)))
  95.  
  96.  
  97. ;;; References
  98.  
  99. (define-ast-to-flic var-ref (object)
  100.   (make-flic-ref (var-ref-var object)))
  101.  
  102. (define-ast-to-flic con-ref (object)
  103.   (make-flic-pack (con-ref-con object)))
  104.  
  105.  
  106. ;;; Constants
  107.  
  108. (define-ast-to-flic integer-const (object)
  109.   (make-flic-const (integer-const-value object)))
  110.  
  111.  
  112. ;;; We should probably add a type field to flic-const but at the moment
  113. ;;; I'll force the value to be a list of numerator, denominator.
  114.  
  115. (define-ast-to-flic float-const (object)
  116.   (let ((e (float-const-exponent object))
  117.     (n (float-const-numerator object))
  118.     (d (float-const-denominator object)))
  119.     (make-flic-const
  120.      (if (> e 0)
  121.      (list (* n (expt 10 e)) d)
  122.      (list n (* d (expt 10 (- e))))))))
  123.  
  124. (define-ast-to-flic char-const (object)
  125.   (make-flic-const (char-const-value object)))
  126.  
  127.  
  128. (define-ast-to-flic string-const (object)
  129.   (let ((value  (string-const-value object)))
  130.     (if (equal? value "")
  131.     (make-flic-pack (core-symbol "Nil"))
  132.     (make-flic-const value))))
  133.  
  134.  
  135.  
  136. ;;; Random stuff
  137.  
  138. (define-ast-to-flic con-number (object)
  139.   (make-flic-con-number
  140.     (con-number-type object)
  141.     (ast-to-flic-1 (con-number-value object))))
  142.  
  143. (define-ast-to-flic sel (object)
  144.   (make-flic-sel
  145.     (sel-constructor object)
  146.     (sel-slot object)
  147.     (ast-to-flic-1 (sel-value object))))
  148.  
  149. (define-ast-to-flic is-constructor (object)
  150.   (make-flic-is-constructor
  151.     (is-constructor-constructor object)
  152.     (ast-to-flic-1 (is-constructor-value object))))
  153.  
  154. (define-ast-to-flic void (object)
  155.   (declare (ignore object))
  156.   (make-flic-void))
  157.  
  158.  
  159. ;;; This hack make strictness annotations work.  It adds #t's which correspond
  160. ;;; to the strictness of the dict params.
  161.  
  162. (define (adjust-annotated-strictness v s)
  163.   (let* ((ty (var-type v))
  164.      (c (gtype-context ty)))
  165.     (dolist (c1 c)
  166.       (dolist (c2 c1)
  167.         (declare (ignorable c2))
  168.         (push '#t s)))
  169.     s))
  170.