;; Derived from 08/meta/scm.scm --
;; An implementation of 'META' and 'Precedence Climbing' in Scheme


;; Operator precedence, arity & associativity
;;
;; Initialize
(define binary-table (make-hash))
(define unary-table (make-hash))

(define (init-prec table ops)
  (for-each (lambda (x)
              (let ([level (car x)])
                ; Add operators to hash table
                (for-each (lambda (op)
                            (hash-set! table op level)
                            ;(printf "~a ~a~n" op level)
                            )
                          (cdr x)))
              )
            ops))
(init-prec binary-table
           '[(2 "=" "+=" "-=" "*=" "/=" "%=" "^=")  ;...
             (3 "==" "!=")  ;...
             (4 "|")
             (5 "&")             ; Left out "&&" and "||"
             (6 "+" "-" "~")
             (8 "*" "/" "%" "<<" ">>" ">>>")
             (9 "^")]
           )
(init-prec unary-table
           '[(7 "+" "-" "~" "!")
             (10 "++" "--")]
           )

(define (binary op) (hash-ref binary-table op #f))
(define (unary op)  (hash-ref unary-table op #f))
(define (left-assoc? op)
  ;;;TODO: += -= etc... and more?
  ;;;Looks like the highest & lowest precedence levels are left-associative
  (not (or (equal? op "=") (equal? op "^"))))

;;---------------------------------------------------------------

(define (ctoi d) (- (char->integer d) (char->integer #\0)))

(define (digit)
  "Parse a single decimal digit"
  (let ((d (match char-numeric?)))
    (and d (ctoi d))))

(define (number)
  "Parse a decimal integer"
  (ws)
  (let ((n 0) (d 0))
    (and (and (setf d (digit))
              (setf n d))
         (do ()
           ((not (setf d (digit)))   n)  ; Return n
           (setf n (+ (* n 10) d)) ))))


;; Indentation
(define *ind* 0)

(define (push v)
  (set! *ind* (cons v *ind*)))

(define (pop)
  (let ((v (car *ind*)))
    (set! *ind* (cdr *ind*))
    v))

(define (dent)
  "Parse leading whitespace... indent/dedent/no change"
  (do ((n #f))
    ((begin
       (set! n *i*)
       (do () ((not (match-char #\space))   ;count spaces..
               (set! n (- *i* n))))
       ;(printf "~n~s ~s~n" *i* n)
       (when (match-char #\#)        ;skip comments
         (do () ((match (lambda (x) (not (char=? x #\newline)))))))
       (not (match-char #\newline)))
     ; Return
     (cond
       ((= n (car *ind*))             0)
       ((> n (car *ind*))   (push n)  1)
       ((= n (cadr *ind*))  (pop)    -1)
       (else #f)) )))

(define (indent)    (= (dent) 1))
(define (dedent)    (= (dent) -1))
(define (samedent)  (= (dent) 0))



(define (optarg n) `(#:optional ,n))
(define (restarg n) `(#:rest ,n))
(define (kwarg n) `(#:other-keys ,n))


    
;; Expressions
(define (Operator)
  ; Will need to handle 2-4 char operators too, e.g. >>=
  (let ((op (match (lambda (c) (member c (string->list "+-*/^="))))))
    ;(printf "op: ~s~n" op)
    (and op (list->string (list op)))))

(define (Value)
  (or (number)
      (let ((x (name))  (y null))
        (if x
            (if (setf y (Parens))
                (append x y)
                x)
            #f))))

(define (Parens)
  (let ((__start *i*)  (tree null))
    (if (and
         (literal "(")
         ;(setf tree (or (List Expr0 ",") null))
         (setf tree (or (Expr 0) null))
         (literal ")"))
        tree
        (begin (set! *i* __start) #f))))

(define (P)
  (let ((__start *i*)  (op null)  (q 0)  (tree null))
    (or
     (and (setf op (Operator))
          (setf q (unary op))
          (setf tree (Expr q))
          (cons op tree))
     (begin (set! *i* __start)
            (or (Value) (Parens))))))

(define (Expr n)
  ;(printf "EXPR~n")
  (do ((__start *i*)  (op null)  (q 0)  (tree (P)))
    ; Until
    ((begin
       (set! __start *i*)
       ;(printf "backtrack=~a~n" backtrack)
       (not (or
             (and (setf op (Operator))
                  (setf q (binary op))
                  (>= q n))
             (begin (set! *i* __start) #f))))
     ; Return
     ;(printf "~s RETURN~n" (list q op tree))
     tree)
    ; Loop
    ;(printf "~s~n" (list q op tree))
    (when (left-assoc? op)
      (set! q (+ q 1)))
    (setf tree (list (string->symbol op)
                     tree
                     (Expr q)))
    ))

(define (expr)
  (Expr 0))