home *** CD-ROM | disk | FTP | other *** search
/ The CDPD Public Domain Collection for CDTV 3 / CDPDIII.bin / pd / programming / gnusmalltalk / browser.st < prev    next >
Encoding:
Text File  |  1992-02-16  |  11.4 KB  |  420 lines
  1. "======================================================================
  2. |
  3. | Copyright (C) 1990, 1991, 1992 Free Software Foundation, Inc.
  4. | Written by Steve Byrne.
  5. |
  6. | This file is part of GNU Smalltalk.
  7. |
  8. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  9. | under the terms of the GNU General Public License as published by the Free
  10. | Software Foundation; either version 1, or (at your option) any later version.
  11. | 
  12. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  13. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  14. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  15. | details.
  16. | 
  17. | You should have received a copy of the GNU General Public License along with
  18. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  19. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  20. |
  21.  ======================================================================"
  22.  
  23. "
  24. |     Change Log
  25. | ============================================================================
  26. | Author       Date       Change 
  27. | sbb         16 Feb 92      created a while ago
  28. |
  29. "
  30.  
  31. Object subclass: #Browser
  32.        instanceVariableNames: ''
  33.        classVariableNames: ''
  34.        poolDictionaries: ''
  35.        category: 'Class browser'
  36. !
  37.  
  38. !Browser class methodsFor: 'browsing'!
  39.  
  40. startEmacsMessage
  41.     stdout nextPut: (Character value: 2)
  42. !
  43.  
  44. finishEmacsMessage
  45.     nil                "does nothing for now"
  46. !
  47.  
  48. withGcOff: aBlock
  49.     | oldFlag |
  50.     oldFlag _ Smalltalk gcMessage: false.
  51.     aBlock value.
  52.     Smalltalk gcMessage: oldFlag
  53. !
  54.  
  55. emacsFunction: funcName on: aBlock
  56.     self withGcOff:
  57.     [ self startEmacsMessage.
  58.       stdout nextPut: $(;
  59.           nextPutAll: funcName; nl.
  60.       aBlock value.
  61.       stdout nextPut: $); nl.    
  62.           self finishEmacsMessage ]
  63. !
  64.  
  65. emacsListFunction: funcName on: aBlock
  66.     self emacsFunction: funcName on:
  67.     [ stdout nextPutAll: '''('; nl.
  68.       aBlock value.
  69.       stdout nextPut: $) ]
  70. !
  71.  
  72. oldShowInstanceMethods: class
  73.     | methods |
  74.     methods _ self getMethods: class.
  75.     self withGcOff:
  76.     [ self startEmacsMessage.
  77.       stdout nextPutAll: '(smalltalk-browse "instance methods"'; nl;
  78.           nextPutAll: '''test-func'; nl;
  79.           nextPutAll: 't'; nl;
  80.           nextPutAll: '''('; nl.
  81.       class allSelectors do:
  82.           [ :sel | stdout nextPutAll: '("';
  83.                            print: sel;
  84.                            nextPutAll: '" . "';
  85.                    print: sel;
  86.                       nextPutAll: '")'; nl ].
  87.           stdout nextPutAll: ')'; nl.    
  88.           self finishEmacsMessage ]
  89. !
  90.  
  91. showMethods: class for: methodType 
  92.     | methods |
  93.     "Experimental version"
  94.     methods _ class newGetMethods.    
  95.     self emacsFunction: 'smalltalk-browse' on: 
  96.     [ stdout nextPut: $";
  97.           nextPutAll: methodType;
  98.           nextPutAll: ' methods"'; nl;
  99.           nextPutAll: '''test-func'; nl;
  100.           nextPutAll: 't'; nl;
  101.           nextPutAll: '''('; nl.
  102.       methods associationsDo:
  103.           [ :sel | sel value value methodSourceFile notNil 
  104.                ifTrue: 
  105.                    [ stdout nextPutAll: '("'; 
  106.                      print: sel key; tab; tab;
  107.                      print: sel value key;
  108.                      nextPutAll: '" . ("'; 
  109.                      nextPutAll: sel value value methodSourceFile;
  110. nextPutAll: '" . ';
  111.                      nextPutAll: sel value value methodSourcePos printString;
  112.                      nextPut: $).
  113.                  stdout nextPut: $); nl ] 
  114.                ifFalse:
  115.                    [ stdout nextPutAll: '("'; 
  116.                      print: sel key; tab; tab;
  117.                      print: sel value key;
  118.                      nextPutAll: '" . ("'; 
  119.                      nextPutAll: sel value value methodSourceString
  120.                      nextPut: $).
  121.                  stdout nextPut: $); nl ]
  122.                ].
  123.           stdout nextPut: $) ]
  124. !
  125.     
  126. showDirectMethods: class inBuffer: bufferName
  127.     | methods |
  128.     "Experimental version"
  129.     methods _ class getDirectMethods.
  130.     self browseMethods: methods forClass: class inBuffer: bufferName .
  131. !
  132.  
  133. showAllMethods: class inBuffer: bufferName
  134.     | methods |
  135.     "Experimental version"
  136.     methods _ class getAllMethods.
  137.     self browseMethods: methods forClass: class inBuffer: bufferName .
  138. !
  139.  
  140. showIndirectMethods: class inBuffer: bufferName
  141.     | methods |
  142.     "Experimental version"
  143.     methods _ class getIndirectMethods.
  144.     self browseMethods: methods forClass: class inBuffer: bufferName.
  145. !
  146.  
  147. getAllSelectors: selector inBuffer: bufferName
  148.     | methods |
  149.     methods _ self getMethodsFor: selector.
  150.     self browseMethods: methods forClass: Object inBuffer: bufferName.
  151. !    
  152.  
  153. browseMethods: methods forClass: class inBuffer: bufferName
  154.     self emacsFunction: 'smalltalk-method-browse' on:
  155.     [ stdout nextPut: $";
  156.           nextPutAll: bufferName;
  157.           nextPutAll: '" ''('; nl.
  158.       methods associationsDo:
  159.           [ :sel | sel value value methodSourceFile notNil 
  160.                ifTrue:
  161.                    [ stdout nextPutAll: '("'; 
  162.                      print: sel key; 
  163.                      nextPutAll: '" . ("'; 
  164.                      nextPutAll: sel value value methodSourceFile;
  165.                      nextPutAll: '" . ';
  166.                      nextPutAll: sel value value methodSourcePos printString;
  167.                      nextPutAll: '))'; nl ] 
  168.                ifFalse:
  169.                    [ stdout nextPutAll: '("'; 
  170.                      print: sel key; 
  171.                      nextPutAll: '" . ("'; 
  172.                      print: class;
  173.                      nextPutAll: '" "';
  174.                      nextPutAll: sel value value methodCategory;
  175.                      nextPut: $"; nl;
  176.                      nextPut: $";
  177.                      nextPutAll: sel value value methodSourceString;
  178.                      nextPutAll: '")'.
  179.                  stdout nextPut: $); nl ]
  180.                ].
  181.       stdout nextPutAll: ')'; nl ]
  182. !
  183.  
  184. oldShowMethods: class for: methodType
  185.     | methods |
  186.     methods _ class getMethods.    
  187.     self withGcOff:
  188.     [ self startEmacsMessage.
  189.       stdout nextPutAll: '(smalltalk-browse "';
  190.           nextPutAll: methodType;
  191.           nextPutAll: ' methods"'; nl;
  192.           nextPutAll: '''test-func'; nl;
  193.           nextPutAll: 't'; nl;
  194.           nextPutAll: '''('; nl.
  195.       methods associationsDo:
  196.           [ :sel | sel value methodSourceFile notNil ifTrue:
  197.                [ stdout nextPutAll: '("'; 
  198.                      print: sel key;
  199.                                  nextPutAll: '" . ("'; 
  200.                  nextPutAll: sel value methodSourceFile;
  201.                  nextPutAll: '" . ';
  202.                  nextPutAll: sel value methodSourcePos printString;
  203.                  nextPutAll: ')'.
  204.                  stdout nextPutAll: ')'; nl ] ].
  205.           stdout nextPutAll: '))'; nl.    
  206.           self finishEmacsMessage ]
  207. !
  208.  
  209. oldloadClassNames
  210.     self withGcOff:
  211.         [ self startEmacsMessage. 
  212.           stdout nextPutAll: '(smalltalk-set-class-names ''('; nl. 
  213.       Object withAllSubclasses do: 
  214.           [ :class | class name == nil
  215.                  ifFalse: [ stdout nextPutAll: class name; nl. ]
  216.                  ].
  217.       stdout nextPutAll: '))'.
  218.           self finishEmacsMessage ]
  219. !
  220.  
  221. loadClassNames
  222.     self emacsListFunction: 'smalltalk-set-class-names' on:
  223.     [ Smalltalk associationsDo:
  224.           [ :assoc | (assoc value isKindOf: Behavior)
  225.                  ifTrue: [ stdout nextPutAll: assoc key; nl ]
  226.                  ] 
  227.           ]
  228. !
  229.  
  230. selectors
  231.     | md |
  232.     self emacsListFunction: 'smalltalk-set-all-methods' on:
  233.     [ Smalltalk associationsDo:
  234.           [ :assoc | (assoc value isKindOf: Behavior)
  235.                  ifTrue: 
  236.                  [ (md _ assoc value methodDictionary)
  237.                        isNil ifFalse:
  238.                        [ md keysDo:
  239.                          " also spit out class methods"
  240.                          [ :key | stdout nextPut: $";
  241.                                   print: key;
  242.                                   nextPut: $"; nl 
  243.                                   ]
  244.                          ]
  245.                        ]
  246.                  ]
  247.           ]
  248. !
  249.  
  250. browseHierarchy
  251.     self emacsListFunction: 'smalltalk-hier-browser' on: 
  252.     [ Object printHierarchy ]
  253. !
  254.  
  255. testMethods: aClass for: methodType
  256.     | classes methods md |
  257.     classes _ (aClass allSuperclasses). 
  258.     classes addFirst: aClass.
  259.     self withGcOff:
  260.     [ self startEmacsMessage.
  261.       stdout nextPutAll: '(smalltalk-fast-browse "';
  262.           nextPutAll: methodType;
  263.           nextPutAll: ' methods"'; nl;
  264.           nextPutAll: '''test-func'; nl;
  265.           nextPutAll: '''('; nl.
  266.       classes do:
  267.           [ :cl | md _ cl methodDictionary.
  268.               md notNil ifTrue:
  269.               [ md associationsDo: 
  270.                 [ :meth | stdout nextPutAll: '("';
  271.                           nextPutAll: meth key;
  272.                           nextPutAll: '" . ("'; 
  273.                           nextPutAll: meth value methodSourceFile;
  274.                           nextPutAll: '" . ';
  275.                           nextPutAll: meth value methodSourcePos printString;
  276.                           nextPutAll: '))';
  277.                           nl ]
  278.                 ]
  279.               ].
  280.       stdout nextPutAll: '))'.
  281.       self finishEmacsMessage ].
  282. !!
  283.  
  284. !Behavior methodsFor: 'browsing'!
  285.  
  286. methodDictionary
  287.     ^methodDictionary
  288. !
  289.  
  290. getMethods
  291.     | classes methods md |
  292.     methods _ Dictionary new.
  293.     self allSuperclasses reverseDo:
  294.     [ :superclass | md _ superclass methodDictionary.
  295.             md notNil ifTrue: 
  296.                 [ md associationsDo:
  297.                   [ :assoc | methods add: assoc ] ] ].
  298.     methodDictionary notNil ifTrue: 
  299.     [ methodDictionary associationsDo:
  300.           [ :assoc | methods add: assoc ] ].
  301.     ^methods
  302. !
  303.  
  304. newGetMethods
  305.     | classes methods md b |
  306.     methods _ Dictionary new.
  307.     b _ [ :md :class | md associationsDo:
  308.           [ :assoc | methods 
  309.                  add: (Association key: assoc key 
  310.                            value: (Association 
  311.                                    key: class 
  312.                                    value: assoc value)) ] ].
  313.     self allSuperclasses reverseDo:
  314.     [ :superclass | md _ superclass methodDictionary.
  315.             md notNil ifTrue: 
  316.                 [ b value: md value: superclass ] ].
  317.     methodDictionary notNil ifTrue: 
  318.     [ b value: methodDictionary value: self ].
  319.     ^methods
  320. !
  321.  
  322. getIndirectMethods
  323.     | classes methods md b |
  324.     methods _ Dictionary new.
  325.     b _ [ :md :class | md associationsDo:
  326.           [ :assoc | methods 
  327.                  add: (assoc key ->
  328.                        (class -> assoc value)) ] ].
  329.     self allSuperclasses reverseDo:
  330.     [ :superclass | md _ superclass methodDictionary.
  331.             md notNil ifTrue: 
  332.                 [ b value: md value: superclass ] ].
  333.     ^methods
  334. !
  335.  
  336. getAllMethods
  337.     | classes methods md b |
  338.     methods _ Dictionary new.
  339.     b _ [ :md :class | md associationsDo:
  340.           [ :assoc | methods 
  341.                  add: (assoc key ->
  342.                         (class -> assoc value)) ] ].
  343.     classes _ self allSuperclasses.
  344.     classes addFirst: self.
  345.     classes reverseDo:
  346.     [ :superclass | md _ superclass methodDictionary.
  347.             md notNil ifTrue: 
  348.                 [ b value: md value: superclass ] ].
  349.     ^methods
  350. !
  351.  
  352. getDirectMethods
  353.     | classes methods md b |
  354.     methods _ Dictionary new.
  355.     b _ [ :md :class | md associationsDo:
  356.           [ :assoc | methods 
  357.                  add: (Association key: assoc key 
  358.                            value: (Association 
  359.                                    key: class 
  360.                                    value: assoc value)) ] ].
  361.     methodDictionary notNil ifTrue: 
  362.     [ b value: methodDictionary value: self ].
  363.     ^methods
  364. !
  365.  
  366. getMethodsFor: aSelector
  367.     | methods dict elt b |
  368.     methods _ Dictionary new.
  369.     b _ [ :subclass | dict _ subclass methodDictionary.
  370.               dict notNil ifTrue:
  371.               [ elt _ dict at: aSelector
  372.                        ifAbsent: [ nil ].
  373.                 elt notNil ifTrue:
  374.                 [ methods add: 
  375.                       (subclass -> 
  376.                        (subclass -> elt)) ]
  377.                 ]
  378.               ].
  379.  
  380.     Object allSubclassesDo: b.
  381.     b value: Object.
  382.     ^methods
  383. ! !
  384.  
  385. !Behavior methodsFor: 'hierarchy browsing'!
  386.  
  387. printHierarchy
  388.     "I my entire subclassclass hierarchy on the terminal."
  389.     self printSubclasses: 0    
  390. !!
  391.  
  392. !Behavior methodsFor: 'private'!
  393.  
  394. printSubclasses: level
  395.     "I print my name, and then all my subclasses, each indented according
  396.      to its position in the hierarchy."
  397.     | mySubclasses |
  398.     stdout nextPutAll: '("'.
  399.     stdout print: self name;
  400.     nextPutAll: '" . ';
  401.     print: level;
  402.     nextPutAll: ')'; nl.
  403.     mySubclasses _ self subclasses asSortedCollection:
  404.                         [ :a :b | (a name isNil or: [ b name isNil ])
  405.                                       ifTrue: [ true ]
  406.                               ifFalse: [ a name <= b name ] ].
  407.     mySubclasses do:
  408.         [ :subclass | subclass class ~~ Metaclass
  409.                     ifTrue: [ subclass printSubclasses: level + 1 ] ]
  410. !
  411.  
  412. indentToLevel: level
  413.     level timesRepeat:
  414.         [ stdout next: (self hierarchyIndent) put: Character space ]
  415. !
  416.  
  417. hierarchyIndent
  418.     ^4
  419. !!
  420.