Another day, another commit.

[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)

;;;--------------------------------------------------------------------------
;;; Module basics.

(defclass module ()
  ((name :initarg :name :type pathname :reader module-name)
   (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset)
   (items :initarg :items :initform nil :type list :accessor module-items)
   (dependencies :initarg :dependencies :initform nil
		 :type list :accessor module-dependencies)
   (state :initarg :state :initform nil :accessor module-state))
  (: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."))

(defparameter *module* nil
  "The current module under construction.

   This is always an instance of MODULE.  Once we've finished constructing
   it, we'll call CHANGE-CLASS to turn it into an instance of whatever type
   is requested in the module's :LISP-CLASS property.")

(defgeneric module-import (object)
  (:documentation
   "Import definitions into the current environment.

   Instructs the OBJECT to import its definitions into the current
   environment.  Modules pass the request on to their constituents.  There's
   a default method which does nothing at all.

   It's not usual to modify the current module.  Inserting things into the
   *TYPE-MAP* is a good plan.")
  (:method (object) nil))

(defgeneric add-to-module (module item)
  (:documentation
   "Add ITEM to the MODULE's list of accumulated items.

   The module items participate in the MODULE-IMPORT and ADD-OUTPUT-HOOKS
   protocols."))

(defgeneric finalize-module (module)
  (:documentation
   "Finalizes a module, setting everything which needs setting.

   This isn't necessary if you made the module by hand.  If you've
   constructed it incrementally, then it might be a good plan.  In
   particular, it will change the class (using CHANGE-CLASS) of the module
   according to the class choice set in the module's :LISP-CLASS property.
   This has the side effects of calling SHARED-INITIALIZE, setting the
   module's state to T, and checking for unrecognized properties.  (Therefore
   subclasses should add a method to SHARED-INITIALIZE should take care of
   looking at interesting properties, just to make sure they're ticked
   off.)"))

(defmethod module-import ((module module))
  (dolist (item (module-items module))
    (module-import item)))

(defmethod add-to-module ((module module) item)
  (setf (module-items module)
	(nconc (module-items module) (list item)))
  (module-import item))

(defmethod shared-initialize :after ((module module) slot-names &key pset)
  "Tick off known properties on the property set."
  (declare (ignore slot-names))
  (when pset
    (dolist (prop '(:guard))
      (get-property pset prop nil))))

(defmethod finalize-module ((module module))
  (let* ((pset (module-pset module))
	 (class (get-property pset :lisp-class :symbol 'module)))

    ;; Always call CHANGE-CLASS, even if it's the same one; this will
    ;; exercise the property-set fiddling in SHARED-INITIALIZE and we can
    ;; catch unknown-property errors.
    (change-class module class :state t :pset pset)
    (check-unused-properties pset)
    module))

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

(defun build-module
    (name body-func &key (truename (probe-file name)) location)
  (let ((*module* (make-instance 'module
				 :name (pathname name)
				 :state (file-location location)))
	(*type-map* (make-hash-table :test #'equal)))
    (module-import *builtin-module*)
    (when truename
      (setf (gethash truename *module-map*) *module*))
    (unwind-protect
	 (progn
	   (funcall body-func)
	   (finalize-module *module*))
      (when (and truename (not (eq (module-state *module*) t)))
	(remhash truename *module-map*)))))

(defmacro define-module
    ((name &key (truename nil truenamep) (location nil locationp))
     &body body)
  `(build-module ,name
		 (lambda () ,@body)
		 ,@(and truenamep `(:truename ,truename))
		 ,@(and locationp `(:location ,location))))

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

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

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

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

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

  ;; A little fancy footwork is required because `class' is a reserved word.
  (loop
    (flet ((dispatch (tag pset)
	     (next-token lexer)
	     (parse-module-declaration tag lexer pset)
	     (check-unused-properties pset)))
      (restart-case
	  (case (token-type lexer)
	    (:eof (return))
	    (#\; (next-token lexer))
	    (t (let ((pset (parse-property-set lexer)))
		 (case (token-type lexer)
		   (:id (dispatch (string-to-symbol (token-value lexer)
						    :keyword)
				  pset))
		   (t (error "Unexpected token ~A: ignoring"
			     (format-token lexer)))))))
	(continue ()
	  :report "Ignore the error and continue parsing."
	  nil)))))

;;;--------------------------------------------------------------------------
;;; Type definitions.

(defclass type-item ()
  ((name :initarg :name :type string :reader type-name)))

(defmethod module-import ((item type-item))
  (let* ((name (type-name item))
	 (def (gethash name *type-map*))
	 (type (make-simple-type name)))
    (cond ((not def)
	   (setf (gethash name *type-map*) type))
	  ((not (eq def type))
	   (error "Conflicting types `~A'" name)))))

(defmethod module-import ((class sod-class))
  (record-sod-class class))

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

(defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
  (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)
  (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 #\;))))

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

#+(or)
(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 : `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 --------------------------------------------------