Very ragged work-in-progress.

[sod] / module.lisp

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

;;;--------------------------------------------------------------------------
;;; 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 name))
	    (t
	     (funcall thunk path probe))))))

;;;--------------------------------------------------------------------------
;;; Modules.

(defclass module ()
  ((name :initarg :name
	 :type pathname
	 :accessor module-name)
   (plist :initform nil
	  :initarg :plist
	  :type list
	  :accessor module-plist)
   (classes :initform nil
	    :initarg :classes
	    :type list
	    :accessor module-classes)
   (source-fragments :initform nil
		     :initarg :source-fragments
		     :type list
		     :accessor module-source-fragments)
   (header-fragments :initform nil
		     :initarg :header-fragments
		     :type list
		     :accessor module-header-fragments)
   (dependencies :initform nil
		 :initarg :dependencies
		 :type list
		 :accessor module-dependencies))
  (:documentation
   "A module is a container for the definitions made in a source file.

   Modules are the fundamental units of translation.  The main job of a
   module is to remember which definitions it contains, so that they can be
   translated and written to output files.  The module contains the following
   handy bits of information:

     * A (path) name, which is the filename we used to find it.  The default
       output filenames are derived from this.  (We use the file's truename
       as the hash key to prevent multiple inclusion, and that's a different
       thing.)

     * A property list containing other useful things.

     * A list of the classes defined in the source file.

     * Lists of C fragments to be included in the output header and C source
       files.

     * A list of other modules that this one depends on.

   Modules are usually constructed by the PARSE-MODULE function, which is in
   turn usually invoked by IMPORT-MODULE, though there's nothing to stop
   fancy extensions building modules programmatically."))

(defun import-module (pathname &key (truename (truename pathname)))
  "Import 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."

  (let ((module (gethash truename *module-map*)))
    (cond

      ;; The module's not there.  (The *MODULE-MAP* never maps things to
      ;; NIL.)
      ((null module)

       ;; Mark the module as being in progress.  Another attempt to import it
       ;; will fail.
       (setf (gethash truename *module-map*) :in-progress)

       ;; Be careful to restore the state of the module map on exit.
       (unwind-protect

	    ;; Open the module file and parse it.
	    (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)
		  (restart-case
		      (progn
			(next-char lexer)
			(next-token lexer)
			(setf module (parse-module lexer)))
		    (continue ()
		      :report "Ignore the import and continue"
		      nil))))))

	 ;; If we successfully parsed the module, then store it in the table;
	 ;; otherwise remove it because we might want to try again.  (That
	 ;; might not work very well, but it could be worth a shot.)
	 (if module
	     (setf (gethash truename *module-map*) module)
	     (remhash truename *module-map*)))

      ;; A module which is being read can't be included again.
      ((eql module :in-progress)
       (error "Cyclic module dependency involving module ~A" pathname))

      ;; A module which was successfully read.  Just return it.
      (t
       module))))

(defun parse-module (lexer)
  "Parse a module from the given LEXER.

   The newly constructed module is returned.  This is the top-level parsing
   function."

  (let ((hfrags nil)
	(cfrags nil)
	(classes nil)
	(plist nil)
	(deps nil))

    (labels ((fragment (func)
	       (next-token lexer)
	       (when (require-token lexer #\{ :consumep nil)
		 (let ((frag (scan-c-fragment lexer '(#\}))))
		   (next-token lexer)
		   (require-token lexer #\})
		   (funcall func frag)))))

      (tagbody

       top
	 ;; module : empty | module-def module
	 ;;
	 ;; Just read module-defs until we reach the end of the file.
	 (case (token-type lexer)

	   (:eof
	    (go done))
	   (#\;
	    (next-token lexer)
	    (go top))

	   ;; module-def : `import' string `;'
	   ;;
	   ;; Read another module of definitions from a file.
	   (:import
	    (next-token lexer)
	    (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 (import-module path
							    :truename true)))
				   (when module
				     (push module deps)))
			       (file-error (error)
				 (cerror* "Error reading module ~S: ~A"
					  path error)))))))
	    (go semicolon))

	   ;; module-def : `load' string `;'
	   ;;
	   ;; Load a Lisp extension from a file.
	   (:load
	    (next-token lexer)
	    (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)))))))
	    (go semicolon))

	   ;; module-def : `lisp' sexp
	   ;;
	   ;; Process an in-line Lisp form immediately.
	   (:lisp
	    (let ((form (with-lexer-stream (stream lexer)
			  (read stream t))))
	      (handler-case
		  (eval form)
		(error (error)
		  (cerror* "Error in Lisp form: ~A" error))))
	    (next-token lexer)
	    (go top))

	   ;; module-def : `typename' ids `;'
	   ;; ids : id | ids `,' id
	   ;;
	   ;; Add ids as registered type names.  We don't need to know what
	   ;; they mean at this level.
	   (:typename
	    (next-token lexer)
	    (loop
	      (let ((id (require-token lexer :id)))
		(cond ((null id)
		       (return))
		      ((gethash id *type-map*)
		       (cerror* "Type ~A is already defined" id))
		      (t
		       (setf (gethash id *type-map*)
			     (make-instance 'simple-c-type :name id))))
		(unless (eql (token-type lexer) #\,)
		  (return))
		(next-token lexer)))
	    (go semicolon))

	   ;; module-def : `source' `{' c-stuff `}'
	   ;; module-def : `header' `{' c-stuff `}'
	   (:source
	    (fragment (lambda (frag) (push frag cfrags)))
	    (go top))
	   (:header
	    (fragment (lambda (frag) (push frag hfrags)))
	    (go top))

	   ;; Anything else is an error.
	   (t
	    (cerror* "Unexpected token ~A ignored" (format-token lexer))
	    (next-token lexer)
	    (go top)))

       semicolon
	 ;; Scan a terminating semicolon.
	 (require-token lexer #\;)
	 (go top)

       done)

      ;; Assemble the module and we're done.
      (make-instance 'module
		     :name (stream-pathname (lexer-stream lexer))
		     :plist plist
		     :classes classes
		     :header-fragments hfrags
		     :source-fragments cfrags
		     :dependencies deps))))

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