
; shunting yard routines. refer to the wikipedia
; article: "shunting yard algorithm".

(define tokens '())

(define (balanced-parens-and-brackets? tokens)
  (let*
    ((stack '())
     (push
       (lambda (x)
	 (set! stack (cons x stack))))
     (pop
       (lambda ()
	 (set! stack (cdr stack))))
     (empty?
       (lambda ()
	 (null? stack)))
     (tos
       (lambda ()
	 (car stack))))
    (let
      ((ret #t)
       (processing #t))
      (do ((i 0 (+ i 1)))
          ((or (not processing) (= i (vector-length tokens))))
        (let
          ((token (vector-ref tokens i)))
          (if (or (eq? token open-paren-tok)
                  (eq? token open-bracket-tok))
	    (push token)
            (if (or (eq? token close-paren-tok)
                    (eq? token close-bracket-tok))
	      (if (empty?)
	        (begin
	          (set! ret #f)
	          (set! processing #f))
	        (let
		  ((top (tos)))
		  (pop)
		  (if (or
                      (and (eq? token close-paren-tok)
                           (not (eq? top open-paren-tok)))
                      (and (eq? token close-bracket-tok)
                           (not (eq? top open-bracket-tok))))
	            (begin
	              (set! ret #f)
	              (set! processing #f)))))))))
      (if ret
        (empty?)
        ret))))

(define shunt
  (letrec (
    (open-paren?
      (lambda (x)
        (or
          (eq? x open-paren-tok)
          (eq? x open-bracket-tok))))
    (close-paren?
      (lambda (x)
        (or
          (eq? x close-paren-tok)
          (eq? x close-bracket-tok))))
    (parenthesis?
      (lambda (x)
        (or (open-paren? x) (close-paren? x))))
    (matching-parens?
      (lambda (x y)
        (or (and (eq? x close-paren-tok) (eq? y open-paren-tok))
            (and (eq? x close-bracket-tok) (eq? y open-bracket-tok)))))
    (stack '())
    (pop
      (lambda ()
        (if (null? stack)
	  (log-error 'STACK_UNDERFLOW '())
          (let
            ((pop-value (car stack)))
            (set! stack (cdr stack))
            pop-value))))
    (push
      (lambda (x)
        (set! stack (cons x stack))))
    (tos
      (lambda ()
        (if (null? stack)
	  (log-error 'STACK_UNDERFLOW '())
          (car stack))))
    (empty-stack?
      (lambda ()
        (null? stack)))
    (display-stack
      (lambda ()
        (if (not (empty-stack?))
          (begin
            (display (pop))
            (newline)
            (display-stack)))))
    (output-queue '())
    (insert-to-output-queue
      (lambda (token)
        (set! output-queue (cons token output-queue))))
    (display-output-queue
      (lambda (x)
        (if (not (null? x))
          (let
            ((arg (car x)))
            (display arg)
            (newline)
            (display-output-queue (cdr x))))))
    (operator?
      (lambda (x)
	(or (eq? x bit-or-tok)
            (eq? x or-tok)
            (memq x '(
              = + - * / % $neg ! && ~ << >> & ^ == != < <= >= >
            )))))
    (binary-operator?
      (lambda (x)
	(or (eq? x bit-or-tok)
            (eq? x or-tok)
            (memq x '(= + - * / % && << >> & ^ == != < <= >= >)))))
    (get-n-args
      (lambda (x)
        (let
          ((n (function? x)))
          (if (not n) ; x is not a function but an array
            1 ; arrays have one dimension
            (length (cadr n)))))) ; function
    (function-or-array-var?
      (lambda (x)
        (or (function? x) (array-var? x))))
    (function-argument-separator?
      (lambda (x)
        (eq? x comma-tok)))
    (precedence
      (lambda (op)
	(if (eq? op bit-or-tok)
	5
        (if (eq? op or-tok)
        1
        (cadr (assq op '(
          (= 0)
          (&& 2)
          (! 3)
          (== 4) (!= 4) (< 4) (<= 4) (>= 4) (> 4)
          (+ 5) (- 5)
          (* 6) (- 6) (/ 6) (% 6) (& 6) (<< 6) (>> 6) (^ 6)
          (~ 7) ($neg 7)
        )))))))
    (right-associative?
      (lambda (op)
        (memq op '(! ~ $neg))))
    (left-associative?
      (lambda (op)
        (not (right-associative? op))))
    (var?
      (lambda (x)
	(if (symbol? x)
	  (if (not (array-var? x))
	    (or (local-var? x)
		(global-var? x))
	    #f)
	  #f)))
    (my-number?
      (lambda (x)
        (or (number? x) (var? x) (constant? x))))
    (pop-ops-with-less-than-or-equal-precedence
      (lambda (op)
        (if (not (null? stack))
          (if (operator? (tos))
            (let
              ((op2 (tos)))
              (if (or (and (left-associative? op)
                           (<= (precedence op) (precedence op2)))
                      (and (right-associative? op)
                           (< (precedence op) (precedence op2))))
                (begin
                  (insert-to-output-queue (pop))
                  (pop-ops-with-less-than-or-equal-precedence op))))))))
    (pop-ops-until-left-paren
      (lambda ()
        (if (null? stack)
	  (log-error 'MISMATCHED_PARENS '())
          (let
            ((op (pop)))
            (if (not (open-paren? op))
              (begin
                (insert-to-output-queue op) ; could also be a function name
                (pop-ops-until-left-paren)))))))
    (process-function-arg
      (lambda ()
        (if (null? stack)
	  (log-error 'MISMATCHED_PARENS_OR_MISSING_COMMA '())
          (let
            ((op (tos)))
            (if (not (open-paren? op))
              (begin
                (insert-to-output-queue (pop))
                (process-function-arg)))))))
    (clear-operators-from-stack
      (lambda ()
        (if (not (null? stack))
          (let
            ((element (pop)))
            (if (parenthesis? element)
	      (log-error 'MISMATCHED_PARENS '())
              (begin
                (insert-to-output-queue element)
                (clear-operators-from-stack)))))))
    (filter-unary-minus
      (lambda (previous expression next)
        (if (null? expression)
          '()
          (let
            ((prev (car previous))
             (expr (car expression))
             (nxt (car next)))
            (if (or
              (and (null? prev) (eq? expr '-))
              (and (operator? prev) (eq? expr '-))
              (and (eq? prev open-paren-tok) (eq? expr '-))
              (and (eq? prev comma-tok) (eq? expr '-)))
              (cons '$neg
                (filter-unary-minus (cdr previous) (cdr expression) next))
              (cons expr
                (filter-unary-minus (cdr previous) (cdr expression) next)))))))
    (pop-n-args
      (lambda (n)
        (if (= n 0)
          '()
          (cons (pop) (pop-n-args (- n 1))))))
    (filter-scheme-function
      (lambda (token)
	(let
	  ((scheme-token
	    (if (eq? token bit-or-tok)
	      '(bitwise-or bitwise-or)
            (assq token '(
              (= set!)
              (/ quotient)
              (% remainder)
              (& bitwise-and)
              (^ bitwise-xor)
              (~ bitwise-not)
              (>> shr)
              (<< shl)
              ($neg -)
              (== =))))))
	  (if (not scheme-token)
	    token
	    (cadr scheme-token)))))
    (make-binary-tree
      (lambda (output-queue)
        (if (null? output-queue)
          (pop) ; voila a binary expression tree
          (let
            ((token (car output-queue)))
            (cond
	      ((pair? token) ; special case. an array reference
	        (push (car token)))
              ((operator? token)
                (if (binary-operator? token)
                  (let
                    ((left-operand (pop))
                     (right-operand (pop)))
                    (push (cons (filter-scheme-function token)
			        (cons right-operand
                                      (cons left-operand '())))))
                  (let
                    ((operand (pop)))
                    (push (cons (filter-scheme-function token)
				(cons operand '()))))))
              ((array-var? token)
	        (push (cons token (pop-n-args 1))))
              ((function? token)
                (push (cons
			token
			(reverse (pop-n-args (get-n-args token))))))
              (else ; number, string or var
                (push token)))
            (make-binary-tree (cdr output-queue))))))
    (array-var-no-args?
      (lambda (expression token)
        (if (null? (cdr expression))
	  (if (array-var? token)
	    #t
	    #f)
	  (and (array-var? token)
	       (not (open-paren? (cadr expression)))))))
    (shunt-proper
      (lambda (expression)
        (if (null? expression)
          (clear-operators-from-stack)
          (let
            ((token (car expression)))
            (cond
              ((open-paren? token)
                (push token))
              ((close-paren? token)
                (pop-ops-until-left-paren)
                (if (and (not (empty-stack?)) (function-or-array-var? (tos)))
                  (insert-to-output-queue (pop))))
              ((function-argument-separator? token)
                (process-function-arg))
              ((operator? token)
                (pop-ops-with-less-than-or-equal-precedence token)
                (push token))
	       ((array-var-no-args? expression token)
		(push (list token)))
              ((or (my-number? token)
	        (string? token)
	        (array-var-no-args? expression token))
                (insert-to-output-queue token))
              ((function-or-array-var? token)
                (push token))
	      (else
		(log-error 'UNDEFINED_IDENTIFIER token)
                (insert-to-output-queue token)))
            (shunt-proper (cdr expression))))))
      ) ; letrec definitions
      (lambda (expression) ; shunt
        (set! stack '())
        (set! expression
          (filter-unary-minus
            (cons '() expression)
            expression
            (append expression '(()))))
        (set! stack '())
        (set! output-queue '())
	(shunt-proper expression)
      ; (display expression) ; debug
      ; (newline)
        (set! output-queue (reverse output-queue))
      ; (display-output-queue output-queue) ; debug
        (set! stack '())
        (make-binary-tree output-queue)
	)
    ))
