;;;
;;; parser.lisp
;;;
;;; Parser for smalltalk source.
;;;

;;; FIXME: BSD license header goes here.

(in-package "SMALLTALK-PARSER")

;; TODO:
;;
;; * 1. Assignment expressions.
;; * 2. Keyword message expressions.
;; * 3. Blocks.
;;   4. Cascaded message expressions.
;;   5. Come up with a scheme for handling parse errors properly.
;;
;; The first two are straightforward, maybe an hour total?
;; The first three are the essentials.  Items 4 and 5 are optional/later.
;;
;; Some examination showed that there is no easy way to add support for
;; cascaded message expressions to the current parser.  Since they aren't
;; strictly necessary yet, they are being deferred indefinately.

(defstruct (parsed-code (:type list))
  selector
  arguments
  primitive
  temporaries
  statements)

(defun parse-message-pattern ()
  (let ((token (peek-next-token)))
    (ecase (car token)
      (:identifier
       (get-next-token)
       (values (cadr token) nil))
      (:binary-selector
       (get-next-token)
       (values (cadr token)
	       (list (cadr (get-next-token)))))
      (:keyword
       (loop
	  while (and (listp (peek-next-token))
		     (eq :keyword (car (peek-next-token))))
	  collect (cadr (get-next-token)) into keywords
	  collect (cadr (get-next-token)) into arguments
	  finally (return (values
			   (apply #'concatenate 'string keywords)
			   arguments)))))))

(defun parse-primitive ()
  (when (equal (peek-next-token) '(:binary-selector "<"))
    (get-next-token)
    (unless (equal (get-next-token) '(:keyword "primitive:"))
      (error "expected \"primitive:\""))
    (let ((primitive (get-next-token)))
      ;; FIXME: Error-check primitive (should be literal 8-bit integer)
      (unless (equal (get-next-token) '(:binary-selector ">"))
	(error "expected \">\""))
      ;; Never -ever- thought I'd use CADADR.
      (cadadr primitive))))

(defun parse-temporaries ()
  (when (equal (peek-next-token) '(:binary-selector "|"))
    (get-next-token)
    (let ((temporaries (loop
			  for token = (peek-next-token)
			  while (and (listp token)
				     (eql (car token) :identifier))
			  do (get-next-token)
			  collect (cadr token))))
      (unless (equal (get-next-token) '(:binary-selector "|"))
	(error "expected \"|\""))
      temporaries)))

(defun parse-block-args ()
  (let ((args (loop
		 for token = (peek-next-token)
		 while (and (listp token)
			    (eql (car token) :block-arg))
		 do (get-next-token)
		 collect (cadr token))))
    (when args
      (unless (equal (get-next-token)
		     '(:binary-selector "|"))
	(error "expected \"|\""))
      args)))

(defun parse-primary-expression ()
  (let ((token (get-next-token)))
    (cond
      ((and (listp token)
	    (member (car token) '(:literal :identifier)))
       token)

      ((eql token #\()
       (let ((expression (parse-expression)))
	 (unless (equal (get-next-token) #\))
	   (error "expected \")\""))
	 expression))

      ((eql token #\[)
       (let ((args (parse-block-args))
	     (statements (parse-statements)))
	 (unless (equal (get-next-token) #\])
	   (error "expected \"]\""))
	 (list :block args statements)))

      (t (error "unexpected token in primary expression")))))

(defun parse-unary-expression ()
  (loop
     with primary = (parse-primary-expression)
     for token = (peek-next-token)
     do (if (and (listp token)
		 (eq (car token) :identifier))
	    (progn
	      (get-next-token)
	      (setf primary (list (cadr token) primary)))
	    (return primary))))

(defun parse-binary-expression ()
  (loop
     with primary = (parse-unary-expression)
     for token = (peek-next-token)

     do (cond
	  ((and (listp token)
		(eq (car token) :binary-selector))
	   (get-next-token)
	   (setf primary (list (cadr token) primary
			       (parse-unary-expression))))

	  (t (return primary)))))

(defun parse-keyword-expression ()
  (loop
     with primary = (parse-binary-expression)
     for token = (peek-next-token)
     while (and (listp token)
		(eq (car token) :keyword))
     do (get-next-token)
     collect (cadr token) into keywords
     collect (parse-binary-expression) into arguments
     finally (if keywords
		 (return (list* (apply #'concatenate 'string keywords) primary arguments))
		 (return primary))))

(defun parse-expression ()
  (let ((primary (parse-keyword-expression)))
    (if (eql (peek-next-token) #\_)
	(progn
	  (get-next-token)
	  (list #\_ primary (parse-expression)))
	primary)))

(defun parse-statements ()
  (when (not (member (peek-next-token) '(nil #\])))
    ;; FIXME: Find a cleaner way to write this mess.
    (loop
       if (eql (peek-next-token) #\^)
       do (get-next-token)
       and collect `(#\^ ,(parse-expression))
       and do (loop-finish)
       else
       collect (parse-expression)
       end
       while (eql (peek-next-token) #\.)
       do (get-next-token))))

(defun parse-method-definition (source)
  (reset-tokenizer)
  (with-input-from-string
      (*standard-input* source)
    (multiple-value-bind
	  (selector arguments)
	(parse-message-pattern)
      (let ((primitive (parse-primitive))
	    (temporaries (parse-temporaries))
	    (statements (parse-statements)))
	;; FIXME: (assert (eql (get-next-token) nil))
	(make-parsed-code :selector selector :arguments arguments
			  :primitive primitive :temporaries temporaries
			  :statements statements)))))

;;; EOF
