X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa:/module.lisp..dea4d05507e59ab779ed4bb209e05971d87e260c:/pre-reorg/module.lisp

diff --git a/module.lisp b/pre-reorg/module.lisp
similarity index 60%
rename from module.lisp
rename to pre-reorg/module.lisp
index 6f8aeec..604703f 100644
--- a/module.lisp
+++ b/pre-reorg/module.lisp
@@ -26,135 +26,8 @@
 (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.
 
@@ -220,30 +93,6 @@
 	: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)))
@@ -257,33 +106,6 @@
 ;;;--------------------------------------------------------------------------
 ;;; 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*"
@@ -557,102 +379,4 @@
     (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 --------------------------------------------------