"====================================================================== | | Experimental ENVY-like Applications | | $Revision: 1.7.5$ | $Date: 2000/05/28 16:56:52$ | $Author: pb$ | ======================================================================" "====================================================================== | | Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc. | Written by Paolo Bonzini. | | This file is part of GNU Smalltalk. | | GNU Smalltalk 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, or (at your option) any later version. | | GNU Smalltalk 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 | GNU Smalltalk; see the file COPYING. If not, write to the Free Software | Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | ======================================================================" Object subclass: #SubApplication instanceVariableNames: 'parent subApplications extendedClasses definedClasses prerequisites' classVariableNames: 'Applications' poolDictionaries: '' category: nil ! SubApplication subclass: #Application instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: nil ! !SubApplication class methodsFor: 'obtaining instances'! applications Applications isNil ifTrue: [ Applications := IdentityDictionary new ]. ^Applications ! new ^self error: 'Use #create: and #createSubApplication: to obtain a new instance, #instance to get existing ones' ! instance ^Applications at: self ! ! !SubApplication methodsFor: 'delegating'! fileOutOn: aStream ^self instance fileOutOn: aStream ! ! !SubApplication methodsFor: 'creating new subapplications'! createSubApplication: name | class | class := SubApplication subclass: name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: nil. self defineClass: class. ^(self class applications at: class put: class basicNew) initializeParent: self ! ! !SubApplication methodsFor: 'accessing'! addPrerequisite: aClass ^self addPrerequisite: aClass ifAbsentFileIn: nil ! addPrerequisite: aClass ifAbsentFileIn: aFile aFile notNil ifTrue: [ FileStream fileIn: aFile ifMissing: aClass ]. Smalltalk classAt: aClass ifAbsent: [ ^self error: 'Prerequisite not loaded' ]. ^prerequisites at: aClass put: aFile. ! checkPrerequisites prerequisites keysAndValuesDo: [ :class :file | file notNil ifTrue: [ FileStream fileIn: file ifMissing: class ]. Smalltalk classAt: class ifAbsent: [ ^self error: 'Prerequisite not loaded' ] ] ! defineClass: aClass aClass category: self name. ^definedClasses add: aClass ! defines: aClass ^definedClasses includes: aClass ! extendClass: aClass ^extendedClasses add: aClass ! extends: aClass ^extendedClasses includes: aClass ! extensions "Answer the category to be used for extensions belonging to this Application" ^'Extensions-', self className ! name ^self class name ! parent ^parent ! removePrerequisite: aClass ^prerequisites removeKey: aClass ! removePrerequisite: aClass ifAbsent: aBlock ^prerequisites removeKey: aClass ifAbsent: aBlock ! ! !SubApplication methodsFor: 'printing'! printOn: aStream aStream nextPutAll: 'Application '; print: self class name ! storeOn: aStream aStream store: self class name; nextPutAll: ' instance' ! ! !SubApplication methodsFor: 'enumerating'! allSubApplications | result | result := Set new. self allSubApplicationsDo: [ :each | result add: each ]. ^result ! allSubApplicationsDo: aBlock self subApplications do: [ :each | each withAllSubApplicationsDo: aBlock ] ! comment ^self class comment ! comment: aString self class comment: aString ! definedClassesDo: aBlock definedClasses do: aBlock ! extendedClassesDo: aBlock extendedClasses do: aBlock ! subApplicationsDo: aBlock subApplications do: aBlock ! subApplications ^subApplications copy ! withAllSubApplications ^self allSubApplications add: self; yourself ! withAllSubApplicationsDo: aBlock aBlock value: self. subApplications do: [ :each | each withAllSubApplicationsDo: aBlock ] ! ! !SubApplication methodsFor: 'filing out'! fileOutOn: aStream "File out in this order: - class declaration - prerequisites - #wasLoaded method - definition for defined classes - methods for defined classes - methods for extended classes - definition of subapplications - calls to methods in the application object" aStream nextPutAll: self definition; nl. prerequisites keysAndValuesDo: [ :class :file | aStream tab; nextPutAll: 'addPrerequisite: '; print: class; nextPutAll: ' ifAbsentFileIn: '; store: file; nextPut: $; nl ]. aStream tab; nextPutAll: 'yourself!'; nl; nl. self class includesSelector: #wasLoaded ifTrue: [ self class fileOutSelector: #wasLoaded on: aStream ]. self fileOutClassesOn: aStream. extendedClasses do: [ :each | each fileOutCategory: self extensions on: aStream ] self subApplicationsDo: [ :each | each instance fileOutOn: aStream ]. aStream store: self. definedClasses do: [ :each | aStream nl; tab; nextPutAll: 'definesClass: '; print: each; nextPut: $; ]. extendedClasses do: [ :each | aStream nl; tab; nextPutAll: 'extendsClass: '; print: each; nextPut: $; ]. aStream nl; tab; nextPutAll: (self parent isNil ifTrue: [ 'wasLoaded!' ] ifFalse: [ 'yourself!' ]); nl. ! !SubApplication methodsFor: 'events'! wasLoaded self checkPrerequisites. self definedClassesDo: [ :each | (each class includesSelector: #initialize) ifTrue: [ each initialize ] ]. self allSubApplicationsDo: [:each | each wasLoaded ] ! wasRemoved ! ! !SubApplication methodsFor: 'removing from the image'! removeClass: aClass (self extends: aClass) ifTrue: [ aClass removeCategory: 'Extensions-', self name. ^self ]. aClass subclasses isEmpty ifFalse: [ ^self error: 'cannot remove class with defined subclasses' ]. (self defines: aClass) ifTrue: [ aClass superclass removeSubclass: aClass . Smalltalk removeKey: aClass ]. ! remove self allSubApplicationsDo: [:each | each remove. definedClasses remove: each ]. "Use reverseDo: to go depth-first" self orderedDefinedClasses reverseDo: [ :each | each superclass removeSubclass: each. Smalltalk removeKey: each ]. self extendedClassesDo: [ :each | each removeCategory: 'Extensions-', self name ]. self wasRemoved. self class superclass removeSubclass: self class ! unbindClass: aClass definedClasses remove: aClass ifAbsent: [ extendedClasses remove: aClass ifAbsent: [ ^self error: 'class not found in Application' ] ]. ^aClass ! ! !SubApplication methodsFor: 'private'! compareClasses: a and: b | c d | a value = b value ifFalse: [ ^a value < b value ]. c := a key superclass. d := b key superclass. ^(c == d) | c isNil | d isNil ifFalse: [ c name < d name ] ifTrue: [ a key name < b key name ] ! declaration ^'(%2 createSubApplication: #%1)' bindWith: self name with: self parent storeString ! fileOutClassesOn: aStream self orderedDefinedClasses do: [ :each | each fileOutDeclarationOn: aStream ]; do: [ :each | self fileOutMethodsFor: each on: aStream ] ! fileOutMethodsFor: aClass on: aStream | categories | categories := Set new. aClass methodDictionary notNil ifTrue: [ aClass methodDictionary do: [ :method | categories add: method methodCategory. ] ]. categories do: [ :category | ('Extensions-*' match: category) ifFalse: [ aClass fileOutCategory: category toStream: aStream ] ] aStream nl; nl. ! orderedDefinedClasses | classes orderedClasses nextClass | classes := definedClasses reject: [ :each | each isKindOf: SubApplication ]. orderedClasses := WriteStream on: (Array new: classes size). [ classes isEmpty ] whileFalse: [ nextClass := classes anyOne. self orderClasses: classes startingAt: nextClass orderOn: orderedClasses level: nextClass allSuperclasses size ]. orderedClasses := orderedClasses contents asSortedCollection: [ :a :b | self compareClasses: a and: b ]. ^orderedClasses collect: [ :each | each key ] ! orderClasses: classes startingAt: aClass orderOn: aStream level: level | classesLeft | (classes includes: aClass superclass) ifTrue: [ self orderClasses: classes startingAt: aClass superclass orderOn: aStream level: level - 1 ]. classesLeft remove: aClass. aStream nextPut: (aClass -> level) ! initializeParent: anApplicationOrNil prerequisites := IdentityDictionary new: 8. extendedClasses := Set new. definedClasses := Set new. parent := anApplicationOrNil. ! ! !Application class methodsFor: 'creating new applications'! create: name | class | class := Application subclass: name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: nil. ^(self applications at: class put: class basicNew) initializeParent: nil ! !Application methodsFor: 'private'! declaration ^'(Application create: #%1)' bindWith: self name ! !