for VisualWorks 7.9 on Mac OS X (macOS 10.14 Mojave or earlier) / Windows (Windows 7 or later)
for VisualWorks 8.1 on Mac OS X (macOS 10.14 Mojave or later) / Windows (Windows 7 or later)
SmalltalkプログラムをSmalltalkプログラムで作る、すなわち、Smalltalkメタプログラミングに挑戦しましょう。バンドルを作り、パッケージを作り、名前空間を作り、クラスを作り、プロトコルを作り、メソッドを作り、テストして、保存する、これら一連のSmalltalkプログラミングの過程それ自身をプログラミングしちゃおう！という試みになります。
Smalltalkはすべてがオブジェクトへのメッセージング（メッセージ送信）で成り立っているわけですから、これら一連のSmalltalkプログラミングの過程さえも、メッセージングにできるはずです。そりゃもう『目にうつる全てのことはメッセージ』ですから…。
メタプログラミングの題材として「Examples」を取り上げます。「例題集」のプログラム作成過程を、メタプログラムに仕立て上げてゆくプログラミングになります。一気に51個の例題プログラムを生成し、テストし、保存し、閲覧します。
さぁ！始めましょう。メタプログラムの実行結果をシステムブラウザで示してゆきます。
これから行ってゆくことのワークブック（Workbook：Workspaceの集合体）も用意しておきました。
$ curl -O http://www.cc.kyoto-su.ac.jp/~atsushi/Programs/VisualWorks/MetaProgrammingExamples/Workbook_Examples.zip % Total % Received % Xferd Average Speed Time Time Time Current Dload Upload Total Spent Left Speed 100 7511 100 7511 0 0 89580 0 --:--:-- --:--:-- --:--:-- 90493 $ unzip Workbook_Examples.zip Archive: Workbook_Examples.zip creating: Workbook_Examples/ inflating: Workbook_Examples/Workbook_Examples.st creating: Workbook_Examples/Workspaces/ inflating: Workbook_Examples/Workspaces/01_Bundle.st inflating: Workbook_Examples/Workspaces/02_Packages.st inflating: Workbook_Examples/Workspaces/03_NameSpace.st inflating: Workbook_Examples/Workspaces/04_Class.st inflating: Workbook_Examples/Workspaces/05_Protocol.st inflating: Workbook_Examples/Workspaces/06_Method.st inflating: Workbook_Examples/Workspaces/07_Methods.st inflating: Workbook_Examples/Workspaces/08_Test.st inflating: Workbook_Examples/Workspaces/09_Save.st inflating: Workbook_Examples/Workspaces/10_Browse.st
Smalltalkのファイルブラウザから「Workbook_Examples.st」をファイルイン（File In）してくださいませ。
これからやってゆくことのワークブック（Workbook：Workspaceの集合体）が開きます。
| aBundle |
aBundle := Smalltalk.Store.Registry bundleNamedOrCreate: 'AokiJuku'.
aBundle comment: 'AokiJuku: Programming in Summer 2019'.
^aBundle
==> {AokiJuku}
| aBundle aCollection aPackage |
aBundle := Smalltalk.Store.Registry bundleNamed: 'AokiJuku'.
aBundle ifNil: [^self error: 'fatal error'].
aCollection := Smalltalk.Core.OrderedCollection new.
aPackage := Smalltalk.Store.Registry packageNamedOrCreate: 'AJ-System'.
aPackage comment: 'AJ-System: System in AokiJuku'.
aCollection add: aPackage.
(aBundle containedItems includes: aPackage)
ifFalse: [aBundle addItem: aPackage].
aPackage := Smalltalk.Store.Registry packageNamedOrCreate: 'AJ-Examples'.
aPackage comment: 'AJ-Examples: Examples in AokiJuku'.
aCollection add: aPackage.
(aBundle containedItems includes: aPackage)
ifFalse: [aBundle addItem: aPackage].
^aCollection
==> OrderedCollection ([AJ-System] [AJ-Examples])
| aPackage aNameSpace |
aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-System'.
aPackage ifNil: [^self error: 'fatal error'].
aNameSpace := Smalltalk at: #AJ
ifAbsent:
[aNameSpace := Smalltalk
defineNameSpace: #AJ
private: false
imports: 'private Core.*'
category: ''.
aNameSpace yourself].
aNameSpace comment: 'AJ: NameSpace for AokiJuku'.
Smalltalk.Store.XChangeSet current moveWholeObject: aNameSpace
toPackage: aPackage.
^aNameSpace
==> AJ
| aReference aNameSpace aPackage aClass |
aReference := #{Smalltalk.AJ}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aNameSpace := aReference value.
(aNameSpace isKindOf: Smalltalk.Kernel.NameSpace)
ifFalse: [^self error: 'fatal error'].
aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-System'.
aPackage ifNil: [^self error: 'fatal error'].
aClass := aNameSpace
defineClass: #Examples
superclass: #{Smalltalk.Core.Object}
indexedType: #none
private: false
instanceVariableNames: ''
classInstanceVariableNames: ''
imports: ''
category: ''.
aClass comment: 'Examples in AokiJuku'.
aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-Examples'.
Smalltalk.Store.XChangeSet current moveWholeObject: aClass
toPackage: aPackage.
^aClass
==> AJ.Examples
| aReference theClass lambdaToCreateCategory dictionaryLambdaArgument theCategory |
aReference := #{Smalltalk.AJ.Examples}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
theClass := aReference value.
(theClass isKindOf: Smalltalk.Kernel.Class)
ifFalse: [^self error: 'fatal error'].
lambdaToCreateCategory :=
[:aDictionary |
| classBlock categoryName aClass aCategory |
classBlock := aDictionary at: #classBlock ifAbsent: [^nil].
categoryName := aDictionary at: #categoryName ifAbsent: [^nil].
aClass := classBlock on: Smalltalk.Core.Error do: [:anException | ^nil].
aCategory := aClass organization addCategory: categoryName asSymbol.
aCategory yourself].
dictionaryLambdaArgument :=
[| aDictionary |
aDictionary := Smalltalk.Core.Dictionary new.
aDictionary add: #classBlock -> [theClass class].
aDictionary add: #categoryName -> 'example template'.
aDictionary yourself].
theCategory := lambdaToCreateCategory
value: dictionaryLambdaArgument value.
^theCategory
==> ('example template')
| aReference theClass lambdaToCreateMethod dictionaryLambdaArgument theSelector |
aReference := #{Smalltalk.AJ.Examples}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
theClass := aReference value.
(theClass isKindOf: Smalltalk.Kernel.Class)
ifFalse: [^self error: 'fatal error'].
lambdaToCreateMethod :=
[:aDictionary |
| classBlock categoryName sourceCode aClass compileBlock |
classBlock := aDictionary at: #classBlock ifAbsent: [^nil].
categoryName := aDictionary at: #categoryName ifAbsent: [^nil].
sourceCode := aDictionary at: #sourceCode ifAbsent: [^nil].
aClass := classBlock on: Smalltalk.Core.Error do: [:anException | ^nil].
compileBlock :=
[| parserClass syntaxTree aSelector |
parserClass := Refactory.Browser.RBParser.
syntaxTree := parserClass parseMethod: sourceCode.
sourceCode := syntaxTree formattedCode.
aSelector := aClass compile: sourceCode classified: categoryName asSymbol.
aSelector].
compileBlock on: Smalltalk.Core.Error do: [:anException | ^nil]].
dictionaryLambdaArgument :=
[| aDictionary |
aDictionary := Smalltalk.Core.Dictionary new.
aDictionary add: #classBlock -> [theClass class].
aDictionary add: #categoryName -> 'example template'.
aDictionary add: #sourceCode -> 'example00 "AJ.Examples example00." ^nil'.
aDictionary yourself].
theSelector := lambdaToCreateMethod value: dictionaryLambdaArgument value.
^theSelector
==> #example00
| aReference theClass lambdaToCreateMethod lambdaToCreateMethods aCollection |
aReference := #{Smalltalk.AJ.Examples}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
theClass := aReference value.
(theClass isKindOf: Smalltalk.Kernel.Class)
ifFalse: [^self error: 'fatal error'].
lambdaToCreateMethod :=
[:aDictionary |
| classBlock categoryName sourceCode aClass compileBlock |
classBlock := aDictionary at: #classBlock ifAbsent: [^nil].
categoryName := aDictionary at: #categoryName ifAbsent: [^nil].
sourceCode := aDictionary at: #sourceCode ifAbsent: [^nil].
aClass := classBlock on: Smalltalk.Core.Error do: [:anException | ^nil].
compileBlock :=
[| parserClass syntaxTree aSelector |
parserClass := Refactory.Browser.RBParser.
syntaxTree := parserClass parseMethod: sourceCode.
sourceCode := syntaxTree formattedCode.
aSelector := aClass compile: sourceCode classified: categoryName asSymbol.
aSelector yourself].
compileBlock on: Smalltalk.Core.Error do: [:anException | ^nil]].
lambdaToCreateMethods :=
[:anInterval |
| classBlock firstString lastString categoryName methodNames |
classBlock := [theClass class].
firstString := anInterval first printString.
[firstString size < 2] whileTrue: [firstString := '0' , firstString].
lastString := anInterval last printString.
[lastString size < 2] whileTrue: [lastString := '0' , lastString].
categoryName := 'examples ' , firstString , ' - ' , lastString.
methodNames := anInterval collect:
[:aNumber |
| aString methodName |
aString := aNumber printString.
[aString size < 2] whileTrue: [aString := '0' , aString].
methodName := 'example' , aString.
methodName yourself].
methodNames collect:
[:methodName |
| aClass sourceCode dictionaryLambdaArgument |
aClass := classBlock on: Smalltalk.Core.Error do: [:anException | ^nil].
sourceCode := [aClass sourceCodeAt: methodName asSymbol]
on: Smalltalk.Core.Error
do: [:anException | methodName , ' "AJ.Examples ' , methodName , '." ' , '^nil'].
dictionaryLambdaArgument :=
[| aDictionary |
aDictionary := Smalltalk.Core.Dictionary new.
aDictionary add: #classBlock -> classBlock.
aDictionary add: #categoryName -> categoryName.
aDictionary add: #sourceCode -> sourceCode.
aDictionary yourself].
lambdaToCreateMethod value: dictionaryLambdaArgument value]].
aCollection := (Smalltalk.Core.OrderedCollection new)
addAll: (lambdaToCreateMethods value: (1 to: 10));
addAll: (lambdaToCreateMethods value: (11 to: 20));
addAll: (lambdaToCreateMethods value: (21 to: 30));
addAll: (lambdaToCreateMethods value: (31 to: 40));
addAll: (lambdaToCreateMethods value: (41 to: 50));
yourself.
^aCollection
==> OrderedCollection (
#example01 #example02 #example03 #example04 #example05 #example06 #example07 #example08 #example09 #example10
#example11 #example12 #example13 #example14 #example15 #example16 #example17 #example18 #example19 #example20
#example21 #example22 #example23 #example24 #example25 #example26 #example27 #example28 #example29 #example30
#example31 #example32 #example33 #example34 #example35 #example36 #example37 #example38 #example39 #example40
#example41 #example42 #example43 #example44 #example45 #example46 #example47 #example48 #example49 #example50
)
| aReference aClass aCollection |
aReference := #{Smalltalk.AJ.Examples}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Smalltalk.Kernel.Class)
ifFalse: [^self error: 'fatal error'].
aCollection := OrderedCollection new.
0 to: 50
do:
[:aNumber |
| aString |
aString := aNumber printString.
[aString size < 2] whileTrue: [aString := '0' , aString].
aString := 'example' , aString.
aCollection add: aString asSymbol].
^aCollection collect: [:aSelector | aClass perform: aSelector]
==> OrderedCollection (
nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil
nil
)
| aBundle fileName |
aBundle := Smalltalk.Store.Registry bundleNamed: 'AokiJuku'.
aBundle ifNil: [^self error: 'fatal error'].
fileName := Dialog
requestNewFileName: #FileOutOnC << #packages >> 'File out on:'
default: aBundle name , '-Examples' , '.st'.
fileName isEmpty ifTrue: [^nil].
aBundle fileOutOnFileNamed: fileName.
^fileName
==> ~/Desktop/AokiJuku-Examples.st
| lambdaToOpenBrowser dictionaryLambdaArgument |
lambdaToOpenBrowser :=
[:aDictionary |
| packageName classBlock categoryName methodName classHierarchy browseBlock |
packageName := aDictionary at: #packageName ifAbsent: [nil].
classBlock := aDictionary at: #classBlock ifAbsent: [nil].
categoryName := aDictionary at: #categoryName ifAbsent: [nil].
methodName := aDictionary at: #methodName ifAbsent: [nil].
classHierarchy := aDictionary at: #classHierarchy ifAbsent: [false].
browseBlock :=
[| aBrowser aWindow aBlock aNavigator |
aBrowser := #{Refactory.Browser.RefactoringBrowser} value open.
aWindow := aBrowser builder
ifNil: [^nil]
ifNotNil: [:aBuilder | aBuilder window].
aBlock :=
[| aRectangle |
aRectangle := 0 @ 0 extent: 800 @ 600.
aRectangle := aRectangle align: aRectangle center
with: Smalltalk.Graphics.Screen default bounds center.
aRectangle yourself].
aWindow displayBox: aBlock value.
aNavigator := aBrowser navigator.
(Smalltalk.Store.Registry packageNamed: packageName)
ifNotNil:
[:aPackage |
aNavigator selectPundle: aPackage.
classBlock
ifNotNil:
[(classBlock on: Smalltalk.Core.Error do: [:anException | nil])
ifNotNil: [:aClass | aNavigator state classesAndNameSpaces: (Array with: aClass)].
categoryName
ifNotNil:
[aNavigator state
protocols: (Smalltalk.Core.Array with: categoryName asSymbol)].
methodName
ifNotNil:
[aNavigator state
selectors: (Smalltalk.Core.Array with: methodName asSymbol)]]].
aNavigator
setState: aNavigator state;
changed.
classHierarchy = true ifTrue: [aNavigator beHierarchy].
aBrowser yourself].
browseBlock value].
dictionaryLambdaArgument :=
[| aDictionary |
aDictionary := Smalltalk.Core.Dictionary new.
aDictionary add: #packageName -> 'AJ-Examples'.
aDictionary add: #classBlock -> [#{Smalltalk.AJ.Examples} value class].
aDictionary add: #categoryName -> 'example template'.
aDictionary add: #methodName -> 'example00'.
aDictionary add: #classHierarchy -> false.
aDictionary yourself].
^lambdaToOpenBrowser value: dictionaryLambdaArgument value
==> a Refactory.Browser.RefactoringBrowser
