;;; -*-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.

(defparameter *module-dirs* nil
  "A list of directories (as pathname designators) to search for files.

   Both SOD module files and Lisp extension files are searched for in this
   list.  The search works by merging the requested pathname with each
   element of this list in turn.  The list is prefixed by the pathname of the
   requesting file, so that it can refer to other files relative to wherever
   it was found.

   See FIND-FILE for the grubby details.")

(defun find-file (lexer name what thunk)
  "Find a file called NAME on the module search path, and call THUNK on it.

   The file is searched for relative to the LEXER's current file, and also in
   the directories mentioned in the *MODULE-DIRS* list.  If the file is
   found, then THUNK is invoked with two arguments: the name we used to find
   it (which might be relative to the starting directory) and the truename
   found by PROBE-FILE.

   If the file wasn't found, or there was some kind of error, then an error
   is signalled; WHAT should be a noun phrase describing the kind of thing we
   were looking for, suitable for inclusion in the error message.

   While FIND-FILE establishes condition handlers for its own purposes, THUNK
   is not invoked with any additional handlers defined."

  (handler-case
      (dolist (dir (cons (stream-pathname (lexer-stream lexer))
			 *module-dirs*)
	       (values nil nil))
	(let* ((path (merge-pathnames name dir))
	       (probe (probe-file path)))
	  (when probe
	    (return (values path probe)))))
    (file-error (error)
      (error "Error searching for ~A ~S: ~A" what (namestring name) error))
    (:no-error (path probe)
      (cond ((null path)
	     (error "Failed to find ~A ~S" what (namestring name)))
	    (t
	     (funcall thunk path probe))))))

(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 --------------------------------------------------