home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / util / prec-utils.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  3.4 KB  |  100 lines  |  [TEXT/CCL2]
  1. -ref-con fn) args))
  2.     ((is-type? 'app fn)
  3.      (extract-constructor (app-fn fn) (cons (app-arg fn) args)))
  4.     (else
  5.      (values '#f '()))))
  6.  
  7.  
  8. ;;; If this is an infix operator application, there are really two nested
  9. ;;; applications that we handle at once.  The "fn" on the outer app
  10. ;;; points to a nested app which is a var-ref or con-ref with the infix?
  11. ;;; slot set to T.
  12. ;;; Returns three values: the fixity info, the operator, and the first
  13. ;;; argument (the arg to the outer application is the second argument).
  14.  
  15. (define (extract-infix-operator fn)
  16.   (if (is-type? 'app fn)
  17.       (let* ((new-fn  (app-fn  fn))
  18.          (arg     (app-arg fn))
  19.          (fixity  (operator-fixity new-fn)))
  20.     (if fixity
  21.         (values fixity new-fn arg)
  22.         (values '#f '#f '#f)))
  23.       (values '#f '#f '#f)))
  24.  
  25.  
  26. ;;; Return the fixity info for a reference to a var or con.
  27. ;;; If it doesn't have an explicit fixity, use the default of
  28. ;;; left associativity and precedence 9.
  29.  
  30. (define default-fixity
  31.   (make fixity (associativity 'l) (precedence 9)))
  32.  
  33. (define (operator-fixity fn)
  34.   (if (is-type? 'save-old-exp fn)
  35.       (operator-fixity (save-old-exp-old-exp fn))
  36.       (or (and (is-type? 'var-ref fn)
  37.            (var-ref-infix? fn)
  38.            (or (and (var-ref-var fn)
  39.             (not (eq? (var-ref-var fn) *undefined-def*))
  40.             (var-fixity (var-ref-var fn)))
  41.            default-fixity))
  42.       (and (is-type? 'con-ref fn)
  43.            (con-ref-infix? fn)
  44.            (or (and (con-ref-con fn)
  45.             (not (eq? (con-ref-con fn) *undefined-def*))
  46.             (con-fixity (con-ref-con fn)))
  47.            default-fixity))
  48.       (and (is-type? 'pcon fn)
  49.            (pcon-infix? fn)
  50.            (or (and (pcon-con fn)
  51.             (not (eq? (pcon-con fn) *undefined-def*))
  52.             (con-fixity (pcon-con fn)))
  53.            default-fixity))
  54.       '#f)))
  55.   
  56.  
  57.  
  58. ;;; Determine the precedence of an expression.
  59. ;;; *** What about unary -?
  60.  
  61. (define (precedence-of-exp exp associativity)
  62.   (cond ((is-type? 'save-old-exp exp)
  63.      (precedence-of-exp (save-old-exp-old-exp exp) associativity))
  64.     ((is-type? 'aexp exp) 10)
  65.     ((is-type? 'app exp)
  66.      (multiple-value-bind (fixity op arg1)
  67.          (extract-infix-operator (app-fn exp))
  68.        (declare (ignore op arg1))
  69.        (if fixity
  70.            (if (eq? associativity (fixity-associativity fixity))
  71.            (1+ (fixity-precedence fixity))
  72.            (fixity-precedence fixity))
  73.            10)))
  74.     ((is-type? 'lambda exp) 10)
  75.     ((is-type? 'let exp) 10)
  76.     ((is-type? 'if exp) 10)
  77.     ((is-type? 'case exp) 10)
  78.     ((pp-exp-list-section? exp) 10)
  79.     ((is-type? 'negate exp) 10)  ; hack, hack
  80.     (else
  81.      0)))
  82.  
  83.  
  84. ;;; Determine whether a pp-exp-list is really a section -- the
  85. ;;; first or last exp in the list is really an infix op.
  86.  
  87. (define (pp-exp-list-section? object)
  88.   (if (is-type? 'pp-exp-list object)
  89.       (let ((exps  (pp-exp-list-exps object)))
  90.     (or (infix-var-or-con? (car exps))
  91.         (infix-var-or-con? (list-ref exps (1- (length exps))))))
  92.       '#f))
  93.  
  94. (define (infix-var-or-con? object)
  95.   (or (and (is-type? 'var-ref object)
  96.        (var-ref-infix? object))
  97.       (and (is-type? 'con-ref object)
  98.        (con-ref-infix? object))))
  99.  
  100.