It lives!

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

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

(defclass type-item ()
  ((name :initarg :name :type string :reader type-name))
  (:documentation
   "A note that a module exports a type.

   We can only export simple types, so we only need to remember the name.
   The magic simple-type cache will ensure that we get the same type object
   when we do the import."))

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

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

(defclass code-fragment-item ()
  ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
   (reason :initarg :reason :type keyword :reader code-fragment-reason)
   (name :initarg :name :type t :reader code-fragment-name)
   (constraints :initarg :constraints :type list
		:reader code-fragment-constraints))
  (:documentation
   "A plain fragment of C to be dropped in at top-level."))

(defmacro define-fragment ((reason name) &body things)
  (categorize (thing things)
      ((constraints (listp thing))
       (frags (typep thing '(or string c-fragment))))
    (when (null frags)
      (error "Missing code fragment"))
    (when (cdr frags)
      (error "Multiple code fragments"))
    `(add-to-module
      *module*
      (make-instance 'code-fragment-item
		     :fragment ',(car frags)
		     :name ,name
		     :reason ,reason
		     :constraints (list ,@(mapcar (lambda (constraint)
						    (cons 'list constraint))
						  constraints))))))

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

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