home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 1 / RISC_DISC_1.iso / pd_share / code / smalltalk / !GNUst / st / Metaclass < prev    next >
Encoding:
Text File  |  1991-09-13  |  8.7 KB  |  277 lines
  1. "======================================================================
  2. |
  3. |   MetaClass Method Definitions
  4. |
  5.  ======================================================================"
  6.  
  7.  
  8. "======================================================================
  9. |
  10. | Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  11. | Written by Steve Byrne.
  12. |
  13. | This file is part of GNU Smalltalk.
  14. |
  15. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  16. | under the terms of the GNU General Public License as published by the Free
  17. | Software Foundation; either version 1, or (at your option) any later version.
  18. | 
  19. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  20. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  21. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  22. | details.
  23. | 
  24. | You should have received a copy of the GNU General Public License along with
  25. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  26. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  27. |
  28.  ======================================================================"
  29.  
  30.  
  31. "
  32. |     Change Log
  33. | ============================================================================
  34. | Author       Date       Change 
  35. | sbyrne     16 May 90      Changed the implementation of name: ... to try to
  36. |              preserve an existing class (if possible).  The
  37. |              original code exists in newMeta: ...
  38. |
  39. | sbyrne     25 Apr 89      created.
  40. |
  41. "
  42.  
  43. ClassDescription subclass: #Metaclass
  44.          instanceVariableNames: 'instanceClass'
  45.          classVariableNames: ''
  46.          poolDictionaries: ''
  47.          category: nil !
  48.  
  49. Metaclass comment: 
  50. 'I am the root of the class hierarchy.  My instances are metaclasses, one for
  51. each real class.  My instances have a single instance, which they hold
  52. onto, which is the class that they are the metaclass of.  I provide methods
  53. for creation of actual class objects from metaclass object, and the creation
  54. of metaclass objects, which are my instances.  If this is confusing to you,
  55. it should be...the Smalltalk metaclass system is strange and complex.' !
  56.  
  57. !Metaclass class methodsFor: 'instance creation'!
  58.  
  59. subclassOf: superMeta
  60.     | newMeta |
  61.     newMeta _ self new.
  62.     newMeta superclass: superMeta.
  63.     superMeta addSubclass: newMeta.
  64.     newMeta initMetaclass.
  65.     ^newMeta
  66.  
  67. !!
  68.  
  69.  
  70.  
  71. !Metaclass methodsFor: 'basic'!
  72.  
  73. name: newName
  74.     environment: aSystemDictionary
  75.     subclassOf: superclass
  76.     instanceVariableNames: stringOfInstVarNames
  77.     variable: variableBoolean
  78.     words: wordBoolean
  79.     pointers: pointerBoolean
  80.     classVariableNames: stringOfClassVarNames
  81.     poolDictionaries: stringOfPoolNames
  82.     category: categoryName
  83.     comment: commentString
  84.     changed: changed
  85.     | aClass variableString variableArray sharedPoolNames poolName pool 
  86.       className classVarDict oldClassPool |
  87.  
  88.     "Please don't look at this case for an example of how to create good 
  89.      Smalltalk code.  It is inelegantly written and probably highly 
  90.     inefficient."
  91.  
  92.     className _ newName asSymbol.
  93.     aClass _ aSystemDictionary 
  94.     at: className
  95.     ifAbsent: [ ^self newMeta: newName
  96.               environment: aSystemDictionary
  97.               subclassOf: superclass
  98.               instanceVariableNames: stringOfInstVarNames
  99.               variable: variableBoolean
  100.               words: wordBoolean
  101.               pointers: pointerBoolean
  102.               classVariableNames: stringOfClassVarNames
  103.               poolDictionaries: stringOfPoolNames
  104.               category: categoryName
  105.               comment: commentString
  106.               changed: changed ].
  107.  
  108.     (aClass isVariable == variableBoolean)
  109.     & (aClass isWords == wordBoolean )
  110.     & (aClass isPointers == pointerBoolean)
  111.     ifFalse: [ ^self newMeta: newName
  112.               environment: aSystemDictionary
  113.               subclassOf: superclass
  114.               instanceVariableNames: stringOfInstVarNames
  115.               variable: variableBoolean
  116.               words: wordBoolean
  117.               pointers: pointerBoolean
  118.               classVariableNames: stringOfClassVarNames
  119.               poolDictionaries: stringOfPoolNames
  120.               category: categoryName
  121.               comment: commentString
  122.               changed: changed ].
  123.  
  124.     "Here we have an existing class, so try hard to leave it alone"
  125.     instanceClass _ aClass.
  126.     aClass setSuperclass: superclass.
  127.  
  128.     superclass notNil
  129.         ifTrue: [ "Inherit instance variables from parent"
  130.               variableString _ superclass instanceVariableString
  131.           ]
  132.         ifFalse: [ variableString _ '' ].
  133.     variableString _ variableString , stringOfInstVarNames.
  134.     variableArray _ self parseVariableString: variableString.
  135.     1 to: variableArray size do:
  136.         [ :i | variableArray at: i put: (variableArray at: i) asSymbol ].
  137.     variableArray = aClass instVarNames
  138.     ifFalse: [ 'Recompilation required!' printNl.
  139.            "### This should be fixed soon" ].
  140.     aClass setInstanceVariables: variableArray.
  141.  
  142.     aClass setInstanceSpec: variableBoolean words: wordBoolean
  143.         pointers: pointerBoolean instVars: variableArray size.
  144.  
  145.     classVarDict _ (self parseToDict: stringOfClassVarNames).
  146.     oldClassPool _ aClass classPool.
  147.     oldClassPool isNil 
  148.     ifTrue: [ aClass setClassVariables: classVarDict ]
  149.     ifFalse: [ classVarDict associationsDo:
  150.                [ :assoc | (oldClassPool includesKey: assoc key)
  151.                       ifFalse: 
  152.                       [ aClass addClassVarName: 
  153.                         assoc key ] ] ].
  154.     classVarDict keys  ~= aClass classPool keys
  155.     ifTrue: [ 'Recompilation required: different class variables!' 
  156.                       printNl ].
  157.  
  158.     sharedPoolNames _ self parseVariableString: stringOfPoolNames.
  159.     1 to: sharedPoolNames size do:
  160.         [ :i | poolName _ (sharedPoolNames at: i) asSymbol.
  161.                "### Check that the pool name starts with an uppercase letter
  162.         here."
  163.            "??? Should this create the pool if not there?"
  164.            pool _ aSystemDictionary
  165.                        at: poolName
  166.                        ifAbsent: [ ^self error: 'Pool name ', poolName ,
  167.                                      ' does not exist' ].
  168.               sharedPoolNames at: i put: pool ].
  169.     "### probably should check for recompilation required here in case
  170.      the intersection of the sets of pool dictionaries shrinks"
  171.     aClass setSharedPools: sharedPoolNames.
  172.  
  173.     "### not done"
  174.     aClass category: categoryName. "### need to remove the old category maybe"
  175.     "### don't know what to do with changed"
  176.     ^aClass
  177. !
  178.  
  179.  
  180. newMeta: newName
  181.     environment: aSystemDictionary
  182.     subclassOf: superclass
  183.     instanceVariableNames: stringOfInstVarNames
  184.     variable: variableBoolean
  185.     words: wordBoolean
  186.     pointers: pointerBoolean
  187.     classVariableNames: stringOfClassVarNames
  188.     poolDictionaries: stringOfPoolNames
  189.     category: categoryName
  190.     comment: commentString
  191.     changed: changed
  192.     | aClass variableString variableArray sharedPoolNames poolName pool |
  193.  
  194.     sharedPoolNames _ self parseVariableString: stringOfPoolNames.
  195.     1 to: sharedPoolNames size do:
  196.         [ :i | poolName _ (sharedPoolNames at: i) asSymbol.
  197.                "### Check that the pool name starts with an uppercase letter
  198.         here."
  199.            pool _ aSystemDictionary
  200.                        at: poolName
  201.                        ifAbsent: [ ^self error: 'Pool name ', poolName ,
  202.                                      ' does not exist' ].
  203.               sharedPoolNames at: i put: pool ].
  204.     aClass _ self new.
  205.     instanceClass _ aClass.
  206.     aSystemDictionary at: (newName asSymbol) put: aClass.
  207.     aClass superclass: superclass.
  208.     aClass setName: newName asSymbol.
  209.     superclass notNil
  210.         ifTrue: [ superclass addSubclass: aClass.
  211.                   "Inherit instance variables from parent"
  212.               variableString _ superclass instanceVariableString
  213.           ]
  214.         ifFalse: [ variableString _ '' ].
  215.     variableString _ variableString , stringOfInstVarNames.
  216.     variableArray _ self parseVariableString: variableString.
  217.     1 to: variableArray size do:
  218.         [ :i | variableArray at: i put: (variableArray at: i) asSymbol ].
  219.     aClass setInstanceVariables: variableArray.
  220.     aClass setInstanceSpec: variableBoolean words: wordBoolean
  221.         pointers: pointerBoolean instVars: variableArray size.
  222.     aClass setClassVariables: (self parseToDict: stringOfClassVarNames).
  223.     aClass setSharedPools: sharedPoolNames.
  224.     "### not done"
  225.     aClass category: categoryName.
  226.     aClass comment: commentString.
  227.     "### don't know what to do with changed"
  228.     ^aClass
  229. !!
  230.  
  231.  
  232.  
  233. !Metaclass methodsFor: 'accessing'!
  234.  
  235. instanceClass
  236.     ^instanceClass
  237. !!
  238.  
  239.  
  240.  
  241.  
  242. !Metaclass methodsFor: 'printing'!
  243.  
  244. printOn: aStream
  245.     instanceClass printOn: aStream.
  246.     ' class' printOn: aStream
  247. !
  248.  
  249. storeOn: aStream
  250.     self printOn: aStream
  251. !!
  252.  
  253.  
  254.  
  255. !Metaclass methodsFor: 'private'!
  256.  
  257. initMetaclass
  258.     instanceVariables _ Class instVarNames.
  259.     instanceSpec _ Class instanceSpec
  260. !
  261.  
  262. parseVariableString: aString
  263.     | stream |
  264.     stream _ TokenStream on: aString.
  265.     ^stream contents
  266. !
  267.  
  268. parseToDict: aString
  269.     | tokenArray dict |
  270.     tokenArray _ self parseVariableString: aString.
  271.     dict _ Dictionary new.
  272.     tokenArray do:
  273.         [ :element | dict at: element asSymbol put: nil ].
  274.     ^dict
  275.  
  276. !!
  277.