prec-utils.scm

;;; prec-util.scm -- utilities for precedence parsing and printing of
;;;                  expressions
;;;
;;; author :  Sandra Loosemore
;;; date   :  15 Feb 1992
;;;
;;; The functions in this file are used by the expression printers
;;; and by precedence parsing.


;;; Uncurry the function application, looking for a con-ref as the
;;; actual function being applied.  Return the con-ref-con and a list
;;; of the arguments.

(define (extract-constructor fn args)
  (cond ((is-type? 'con-ref fn)
	 (values (con-ref-con fn) args))
	((is-type? 'app fn)
	 (extract-constructor (app-fn fn) (cons (app-arg fn) args)))
	(else
	 (values '#f '()))))


;;; If this is an infix operator application, there are really two nested
;;; applications that we handle at once.  The "fn" on the outer app
;;; points to a nested app which is a var-ref or con-ref with the infix?
;;; slot set to T.
;;; Returns three values: the fixity info, the operator, and the first
;;; argument (the arg to the outer application is the second argument).

(define (extract-infix-operator fn)
  (if (is-type? 'app fn)
      (let* ((new-fn  (app-fn  fn))
	     (arg     (app-arg fn))
	     (fixity  (operator-fixity new-fn)))
	(if fixity
	    (values fixity new-fn arg)
	    (values '#f '#f '#f)))
      (values '#f '#f '#f)))


;;; Return the fixity info for a reference to a var or con.
;;; If it doesn't have an explicit fixity, use the default of
;;; left associativity and precedence 9.

(define default-fixity
  (make fixity (associativity 'l) (precedence 9)))

(define (operator-fixity fn)
  (if (is-type? 'save-old-exp fn)
      (operator-fixity (save-old-exp-old-exp fn))
      (or (and (is-type? 'var-ref fn)
	       (var-ref-infix? fn)
	       (or (and (var-ref-var fn)
			(not (eq? (var-ref-var fn) *undefined-def*))
			(var-fixity (var-ref-var fn)))
		   default-fixity))
	  (and (is-type? 'con-ref fn)
	       (con-ref-infix? fn)
	       (or (and (con-ref-con fn)
			(not (eq? (con-ref-con fn) *undefined-def*))
			(con-fixity (con-ref-con fn)))
		   default-fixity))
	  (and (is-type? 'pcon fn)
	       (pcon-infix? fn)
	       (or (and (pcon-con fn)
			(not (eq? (pcon-con fn) *undefined-def*))
			(con-fixity (pcon-con fn)))
		   default-fixity))
	  '#f)))
  


;;; Determine the precedence of an expression.
;;; *** What about unary -?

(define (precedence-of-exp exp associativity)
  (cond ((is-type? 'save-old-exp exp)
	 (precedence-of-exp (save-old-exp-old-exp exp) associativity))
	((is-type? 'aexp exp) 10)
	((is-type? 'app exp)
	 (multiple-value-bind (fixity op arg1)
	     (extract-infix-operator (app-fn exp))
	   (declare (ignore op arg1))
	   (if fixity
	       (if (eq? associativity (fixity-associativity fixity))
		   (1+ (fixity-precedence fixity))
		   (fixity-precedence fixity))
	       10)))
	((is-type? 'lambda exp) 10)
	((is-type? 'let exp) 10)
	((is-type? 'if exp) 10)
	((is-type? 'case exp) 10)
	((pp-exp-list-section? exp) 10)
	((is-type? 'negate exp) 10)  ; hack, hack
	(else
	 0)))


;;; Determine whether a pp-exp-list is really a section -- the
;;; first or last exp in the list is really an infix op.

(define (pp-exp-list-section? object)
  (if (is-type? 'pp-exp-list object)
      (let ((exps  (pp-exp-list-exps object)))
	(or (infix-var-or-con? (car exps))
	    (infix-var-or-con? (list-ref exps (1- (length exps))))))
      '#f))

(define (infix-var-or-con? object)
  (or (and (is-type? 'var-ref object)
	   (var-ref-infix? object))
      (and (is-type? 'con-ref object)
	   (con-ref-infix? object))))