;;; -*-lisp-*-
;;;
;;; Modules and module parser
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Module importing.

(defun read-module (pathname &key (truename (truename pathname)) location)
  "Reads a module.

   The module is returned if all went well; nil is returned if an error
   occurred.

   The PATHNAME argument is the file to read.  TRUENAME should be the file's
   truename, if known: often, the file will have been searched for using
   `probe-file' or similar, which drops the truename into your lap."

  ;; Deal with a module which is already in the map.  If its state is a
  ;; FILE-LOCATION then it's in progress and we have a cyclic dependency.
  (let ((module (gethash truename *module-map*)))
    (cond ((null module))
	  ((typep (module-state module) 'file-location)
	   (error "Module ~A already being imported at ~A"
		  pathname (module-state module)))
	  (module
	   (return-from read-module module))))

  ;; Make a new module.  Be careful to remove the module from the map if we
  ;; didn't succeed in constructing it.
  (define-module (pathname :location location :truename truename)
    (let ((*readtable* (copy-readtable)))
      (with-open-file (f-stream pathname :direction :input)
	(let* ((pai-stream (make-instance 'position-aware-input-stream
					  :stream f-stream
					  :file pathname))
	       (lexer (make-instance 'sod-lexer :stream pai-stream)))
	  (with-default-error-location (lexer)
	    (next-char lexer)
	    (next-token lexer)
	    (parse-module lexer)))))))

;;;--------------------------------------------------------------------------
;;; Module parsing protocol.

(defgeneric parse-module-declaration (tag lexer pset)
  (:method (tag lexer pset)
    (error "Unexpected module declaration ~(~A~)" tag))
  (:method :before (tag lexer pset)
    (next-token lexer)))

(defun parse-module (lexer)
  "Main dispatching for module parser.

   Calls PARSE-MODULE-DECLARATION for the identifiable declarations."

  (loop
    (restart-case
	(case (token-type lexer)
	  (:eof (return))
	  (#\; (next-token lexer))
	  (t (let ((pset (parse-property-set lexer)))
	       (case (token-type lexer)
		 (:id (let ((tag (intern (frob-case (token-value lexer))
					 :keyword)))
			(parse-module-declaration tag lexer pset)
			(check-unused-properties pset)))
		 (t (error "Unexpected token ~A: ignoring"
			   (format-token lexer)))))))
      (continue ()
	:report "Ignore the error and continue parsing."
	nil))))

(defmethod parse-module-declaration ((tag (eql :typename)) lexer pset)
  "module-decl ::= `typename' id-list `;'"
  (loop (let ((name (require-token lexer :id)))
	  (unless name (return))
	  (if (gethash name *type-map*)
	      (cerror* "Type `~A' already defined" name)
	      (add-to-module *module* (make-instance 'type-item :name name)))
	  (unless (require-token lexer #\, :errorp nil) (return))))
  (require-token lexer #\;))

;;;--------------------------------------------------------------------------
;;; Fragments.

(defmethod parse-module-declaration ((tag (eql :code)) lexer pset)
  "module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}'
   constraint ::= id*"
  (labels ((parse-constraint ()
	     (let ((list nil))
	       (loop (let ((id (require-token lexer :id
					      :errorp (null list))))
		       (unless id (return))
		       (push id list)))
	       (nreverse list)))
	   (parse-constraints ()
	     (let ((list nil))
	       (when (require-token lexer #\[ :errorp nil)
		 (loop (let ((constraint (parse-constraint)))
			 (push constraint list)
			 (unless (require-token lexer #\, :errorp nil)
			   (return))))
		 (require-token lexer #\]))
	       (nreverse list)))
	   (keywordify (id)
	     (and id (intern (substitute #\- #\_ (frob-case id)) :keyword))))
    (let* ((reason (prog1 (keywordify (require-token lexer :id))
		   (require-token lexer #\:)))
	   (name (keywordify (require-token lexer :id)))
	   (constraints (parse-constraints)))
      (when (require-token lexer #\{ :consumep nil)
	(let ((frag (scan-c-fragment lexer '(#\}))))
	  (next-token lexer)
	  (require-token lexer #\})
	  (add-to-module *module*
			 (make-instance 'code-fragment-item
					:name name
					:reason reason
					:constraints constraints
					:fragment frag)))))))

;;;--------------------------------------------------------------------------
;;; File searching.


(defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
  "module-decl ::= `import' string `;'"
  (let ((name (require-token lexer :string)))
    (when name
      (find-file lexer
		 (merge-pathnames name
				  (make-pathname :type "SOD" :case :common))
		 "module"
		 (lambda (path true)
		   (handler-case
		       (let ((module (read-module path :truename true)))
			 (when module
			   (module-import module)
			   (pushnew module (module-dependencies *module*))))
		     (file-error (error)
		       (cerror* "Error reading module ~S: ~A"
				path error)))))
      (require-token lexer #\;))))

(defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
  "module-decl ::= `load' string `;'"
  (let ((name (require-token lexer :string)))
    (when name
      (find-file lexer
		 (merge-pathnames name
				  (make-pathname :type "LISP" :case :common))
		 "Lisp file"
		 (lambda (path true)
		   (handler-case (load true :verbose nil :print nil)
		     (error (error)
		       (cerror* "Error loading Lisp file ~S: ~A"
				path error)))))
      (require-token lexer #\;))))

;;;--------------------------------------------------------------------------
;;; Lisp escapes.

(defmethod parse-module-declaration :around ((tag (eql :lisp)) lexer pset)
  "module-decl ::= `lisp' s-expression `;'"
  (let ((form (with-lexer-stream (stream lexer) (read stream t))))
    (eval form))
  (next-token lexer)
  (require-token lexer #\;))

;;;--------------------------------------------------------------------------
;;; Class declarations.

(defmethod parse-module-declaration ((tag (eql :class)) lexer pset)
  "module-decl ::= `class' id [`:' id-list] `{' class-item* `}'"
  (let* ((location (file-location lexer))
	 (name (let ((name (require-token lexer :id)))
		 (make-class-type name location)
		 (when (require-token lexer #\; :errorp nil)
		   (return-from parse-module-declaration))
		 name))
	 (supers (when (require-token lexer #\: :errorp nil)
		   (let ((list nil))
		     (loop (let ((id (require-token lexer :id)))
			     (unless id (return))
			     (push id list)
			     (unless (require-token lexer #\, :errorp nil)
			       (return))))
		     (nreverse list))))
	 (class (make-sod-class name (mapcar #'find-sod-class supers)
				pset location))
	 (nick (sod-class-nickname class)))
    (require-token lexer #\{)

    (labels ((parse-item ()
	       "Try to work out what kind of item this is.  Messy."
	       (let* ((pset (parse-property-set lexer))
		      (location (file-location lexer)))
		 (cond ((declaration-specifier-p lexer)
			(let ((declspec (parse-c-type lexer)))
			  (multiple-value-bind (type name)
			      (parse-c-declarator lexer declspec :dottedp t)
			    (cond ((null type)
				   nil)
				  ((consp name)
				   (parse-method type (car name) (cdr name)
						 pset location))
				  ((typep type 'c-function-type)
				   (parse-message type name pset location))
				  (t
				   (parse-slots declspec type name
						pset location))))))
		       ((not (eq (token-type lexer) :id))
			(cerror* "Expected <class-item>; found ~A (skipped)"
				 (format-token lexer))
			(next-token lexer))
		       ((string= (token-value lexer) "class")
			(next-token lexer)
			(parse-initializers #'make-sod-class-initializer
					    pset location))
		       (t
			(parse-initializers #'make-sod-instance-initializer
					    pset location)))))

	     (parse-method (type nick name pset location)
	       "class-item ::= declspec+ dotted-declarator -!- method-body

		method-body ::= `{' c-fragment `}' | `extern' `;'

		The dotted-declarator must describe a function type."
	       (let ((body (cond ((eq (token-type lexer) #\{)
				  (prog1 (scan-c-fragment lexer '(#\}))
				    (next-token lexer)
				    (require-token lexer #\})))
				 ((and (eq (token-type lexer) :id)
				       (string= (token-value lexer)
						"extern"))
				  (next-token lexer)
				  (require-token lexer #\;)
				  nil)
				 (t
				  (cerror* "Expected <method-body>; ~
					    found ~A"
					   (format-token lexer))))))
		 (make-sod-method class nick name type body pset location)))

	     (parse-message (type name pset location)
	       "class-item ::= declspec+ declarator -!- (method-body | `;')

		The declarator must describe a function type."
	       (make-sod-message class name type pset location)
	       (unless (require-token lexer #\; :errorp nil)
		 (parse-method type nick name nil location)))

	     (parse-initializer-body ()
	       "initializer ::= `=' `{' c-fragment `}' | `=' c-fragment"
	       (let ((char (lexer-char lexer)))
		 (loop
		   (when (or (null char) (not (whitespace-char-p char)))
		     (return))
		   (setf char (next-char lexer)))
		 (cond ((eql char #\{)
			(next-char lexer)
			(let ((frag (scan-c-fragment lexer '(#\}))))
			  (next-token lexer)
			  (require-token lexer #\})
			  (values :compound frag)))
		       (t
			(let ((frag (scan-c-fragment lexer '(#\, #\;))))
			  (next-token lexer)
			  (values :simple frag))))))

	     (parse-slots (declspec type name pset location)
	       "class-item ::=
		  declspec+ init-declarator [`,' init-declarator-list] `;'

		init-declarator ::= declarator -!- [initializer]"
	       (loop
		 (make-sod-slot class name type pset location)
		 (when (eql (token-type lexer) #\=)
		   (multiple-value-bind (kind form) (parse-initializer-body)
		     (make-sod-instance-initializer class nick name
						    kind form nil
						    location)))
		 (unless (require-token lexer #\, :errorp nil)
		   (return))
		 (setf (values type name)
		       (parse-c-declarator lexer declspec)
		       location (file-location lexer)))
	       (require-token lexer #\;))

	     (parse-initializers (constructor pset location)
	       "class-item ::= [`class'] -!- slot-initializer-list `;'

		slot-initializer ::= id `.' id initializer"
	       (loop
		 (let ((nick (prog1 (require-token lexer :id)
			       (require-token lexer #\.)))
		       (name (require-token lexer :id)))
		   (require-token lexer #\=)
		   (multiple-value-bind (kind form)
		       (parse-initializer-body)
		     (funcall constructor class nick name kind form
			      pset location)))
		 (unless (require-token lexer #\, :errorp nil)
		   (return))
		 (setf location (file-location lexer)))
	       (require-token lexer #\;)))

      (loop
	(when (require-token lexer #\} :errorp nil)
	  (return))
	(parse-item)))

    (finalize-sod-class class)
    (add-to-module *module* class)))

;;;----- That's all, folks --------------------------------------------------