git.fiddlerwoaroof.com
import-export/locate-entity.scm
4e987026
 ;;; This file deals with entities in import / export lists
 
 ;;; This resolves an entity with the export table of a
 ;;; module.  It returns either a group, the symbol 'error, or the symbol
 ;;; 'not-found.  When force-error? is true, signal an error when
 ;;; the module is not found & return 'error.
 
 (define (locate-entity/export-table entity mod force-error?)
   (let* ((name (entity-name entity))
 	 (group (table-entry (module-export-table mod) name)))
     (if (eq? group '#f)
 	(if (not force-error?)
 	    'not-found
 	    (signal-entity-not-found name (module-name mod)))
 	(let ((def (group-definition group)))
 	  (cond ((is-type? 'entity-var entity)
 		 group)
 		((is-type? 'entity-con entity)
 		 (cond ((algdata? def)
 			(strip-constructors group))
 		       ((synonym? def)
 			(signal-synonym-needs-dots name (module-name mod)))
 		       (else
 			(signal-wrong-definition
 			  "type constructor" name (module-name mod)))))
 		((is-type? 'entity-abbreviated entity)
 		 (cond ((algdata? def)
 			(cond ((hidden-constructors? group)
 			       (if force-error?
 				   (signal-abstract-type
 				     name (module-name mod))
 				   'not-found))
 			      (else
 			       group)))
 		       ((or (class? def) (synonym? def))
 			group)
 		       (else
 			(signal-wrong-definition
 			  "class or datatype" name (module-name mod)))))
 		((is-type? 'entity-class entity)
 		 (if (class? def)
 		     (match-constituents group (entity-class-methods entity)
 					 entity "method")
 		     (signal-wrong-definition "class" name (module-name mod))))
 		((is-type? 'entity-datatype entity)
 		 (if (algdata? def)
 		     (match-constituents group
 					 (entity-datatype-constructors entity)
 					 entity "constructor")
 		     (signal-wrong-definition
 		       "data type" name (module-name mod))))
 		(else
 		 (error "Bad entity ~s." entity))
 		)))))
 
 (define (match-constituents group names entity what)
   (check-duplicates names entity)
   (dolist (n-d (cdr group))
     (when (not (memq (tuple-2-1 n-d) names))
       (signal-extra-constituent entity (tuple-2-1 n-d) what)))
   (dolist (name names)
     (when (not (assq name (cdr group)))
       (signal-missing-constituent entity name what)))
   group)
 
 
 ;;; The following routine locates an entity in the current module.
 ;;; It may return 'error, 'not-found, or a group.
 
 (define (locate-entity entity)
   (let* ((name (entity-name entity))
 	 (def (resolve-toplevel-name name)))
     (cond ((eq? def '#f)
 	   'not-found)
 	  ((is-type? 'entity-var entity)
 	   (if (method-var? def)
 	       (signal-export-method-var name)
 	       (make-group name def)))
 	  ((is-type? 'entity-con entity)
 	   (cond ((algdata? def)
 		  (make-group name def))
 		 ((synonym? def)
 		  (signal-synonym-needs-dots name *module-name*))
 		 (else
 		  (signal-wrong-definition
 		    "type constructor" name *module-name*))))
 	  ((is-type? 'entity-abbreviated entity)
 	   (cond ((algdata? def)
 		  (require-complete-algdata
 		   (gather-algdata-group name def)))
 		 ((synonym? def)
 		  (make-group name def))
 		 ((class? def)
 		  (gather-class-group name def))
 		 (else
 		  (signal-wrong-definition
 		    "type constructor or class" name *module-name*))))
 	  ((is-type? 'entity-class entity)
 	   (if (class? def)
 	       (match-group-names
 		 (gather-class-group name def)
 		 (entity-class-methods entity)
 		 entity
 		 "method")
 	       (signal-wrong-definition "class" name *module-name*)))
 	  ((is-type? 'entity-datatype entity)
 	   (if (algdata? def)
 	       (match-group-names
 		 (require-complete-algdata (gather-algdata-group name def))
 		 (entity-datatype-constructors entity)
 		 entity "constructor")
 	       (signal-wrong-definition "data type" name *module-name*)))
 	  (else
 	   (error "Bad entity ~s." entity)))))
 
 (define (require-complete-algdata group)
   (if (hidden-constructors? group)
       'not-found
       group))
 
 (define (match-group-names group names entity what)
   (when (not (eq? group 'not-found))
     (match-constituents group names entity what))
   group)