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プログラミングの過程さえも、メッセージングにできるはずです。そりゃもう『目にうつる全てのことはメッセージ』ですから…。
メタプログラミングの題材として「My First MVC」を取り上げます。「私の初めてのモデル・ビュー・コントローラ」のプログラム作成過程を、メタプログラムに仕立て上げてゆくプログラミングになります。
さぁ!始めましょう。メタプログラムの実行結果をシステムブラウザで示してゆきます。
これから行ってゆくことのワークブック(Workbook:Workspaceの集合体)も用意しておきました。
$ curl -O http://www.cc.kyoto-su.ac.jp/~atsushi/Programs/VisualWorks/MetaProgrammingMyFirstMVC/Workbook_MyFirstMVC.zip % Total % Received % Xferd Average Speed Time Time Time Current Dload Upload Total Spent Left Speed 100 12862 100 12862 0 0 131k 0 --:--:-- --:--:-- --:--:-- 130k $ unzip Workbook_MyFirstMVC.zip Archive: Workbook_MyFirstMVC.zip creating: Workbook_MyFirstMVC/ inflating: Workbook_MyFirstMVC/Workbook_MyFirstMVC.st creating: Workbook_MyFirstMVC/Workspaces/ inflating: Workbook_MyFirstMVC/Workspaces/01_Bundle.st inflating: Workbook_MyFirstMVC/Workspaces/02_Packages.st inflating: Workbook_MyFirstMVC/Workspaces/03_NameSpace.st inflating: Workbook_MyFirstMVC/Workspaces/04_AJ.MyFirstModel.st inflating: Workbook_MyFirstMVC/Workspaces/05_AJ.MyFirstView.st inflating: Workbook_MyFirstMVC/Workspaces/06_AJ.MyFirstController.st inflating: Workbook_MyFirstMVC/Workspaces/07_AJ.MyFirstModel.image.st inflating: Workbook_MyFirstMVC/Workspaces/08_AJ.MyFirstModel.createView.st inflating: Workbook_MyFirstMVC/Workspaces/09_AJ.MyFirstModel.defaultViewClass.st inflating: Workbook_MyFirstMVC/Workspaces/10_AJ.MyFirstModel.class.example.st inflating: Workbook_MyFirstMVC/Workspaces/11_AJ.MyFirstModel.class.windowSpec.st inflating: Workbook_MyFirstMVC/Workspaces/12_AJ.MyFirstModel.class.menuBar.st inflating: Workbook_MyFirstMVC/Workspaces/13_AJ.MyFirstModel.class.popUpMenu.st inflating: Workbook_MyFirstMVC/Workspaces/14_AJ.MyFirstView.preferredExtent.st inflating: Workbook_MyFirstMVC/Workspaces/15_AJ.MyFirstView.defaultControllerClass.st inflating: Workbook_MyFirstMVC/Workspaces/16_AJ.MyFirstView.displayOn_.st inflating: Workbook_MyFirstMVC/Workspaces/17_AJ.MyFirstController.redButtonPressedEvent_.st inflating: Workbook_MyFirstMVC/Workspaces/18_AJ.MyFirstController.doSomething.st inflating: Workbook_MyFirstMVC/Workspaces/19_Test.st inflating: Workbook_MyFirstMVC/Workspaces/20_Save.st
Smalltalkのファイルブラウザから「Workbook_MyFirstMVC.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-MyFirstMVC'. aPackage comment: 'AJ-MyFirstMVC: My First Model-View-Controller in AokiJuku'. aCollection add: aPackage. (aBundle containedItems includes: aPackage) ifFalse: [aBundle addItem: aPackage]. ^aCollection
==> OrderedCollection ([AJ-System] [AJ-MyFirstMVC])
| 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: #MyFirstModel superclass: #{UI.ApplicationModel} indexedType: #none private: false instanceVariableNames: 'image' classInstanceVariableNames: '' imports: '' category: ''. aClass comment: 'My First Model Instance Variables: image <Image> bind an image, default is screen captured image '. aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-MyFirstMVC'. Smalltalk.Store.XChangeSet current moveWholeObject: aClass toPackage: aPackage. ^aClass
==> AJ.MyFirstModel
| 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: #MyFirstView superclass: #{UI.View} indexedType: #none private: false instanceVariableNames: '' classInstanceVariableNames: '' imports: '' category: ''. aClass comment: 'My First View '. aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-MyFirstMVC'. Smalltalk.Store.XChangeSet current moveWholeObject: aClass toPackage: aPackage. ^aClass
==> AJ.MyFirstView
| 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: #MyFirstController superclass: #{UI.ControllerWithMenu} indexedType: #none private: false instanceVariableNames: '' classInstanceVariableNames: '' imports: '' category: ''. aClass comment: 'My First Controller '. aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-MyFirstMVC'. Smalltalk.Store.XChangeSet current moveWholeObject: aClass toPackage: aPackage. ^aClass
==> AJ.MyFirstController
| aReference aClass aSelector | aReference := #{AJ.MyFirstModel}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass compile: 'image image ifNil: [image := Graphics.Screen default completeContentsOfArea: Graphics.Screen default bounds]. ^image' classified: #accessing attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #image
| aReference aClass aSelector | aReference := #{AJ.MyFirstModel}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass compile: 'createView | aView aController | aView := self defaultViewClass model: self. aController := aView controller. aController menuHolder: [self class popUpMenu]. ^aView' classified: #'interface opening' attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #createView
| aReference aClass aSelector | aReference := #{AJ.MyFirstModel}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass compile: 'defaultViewClass ^#{AJ.MyFirstView} value' classified: #'view accessing' attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #defaultViewClass
| aReference aClass aSelector | aReference := #{AJ.MyFirstModel}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass class compile: 'example "AJ.MyFirstModel example." | aBuilder | aBuilder := self open. ^aBuilder' classified: #examples attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #example
| aReference aClass aSelector | aReference := #{AJ.MyFirstModel}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass class compile: 'windowSpec "Tools.UIPainter new openOnClass: self andSelector: #windowSpec" <resource: #canvas> ^#(#{UI.FullSpec} #window: #(#{UI.WindowSpec} #label: ''My First MVC'' #min: #(#{Core.Point} 200 150 ) #max: #(#{Core.Point} 800 600 ) #bounds: #(#{Graphics.Rectangle} 520 300 920 600 ) #flags: 4 #menu: #menuBar ) #component: #(#{UI.SpecCollection} #collection: #( #(#{UI.ArbitraryComponentSpec} #layout: #(#{Graphics.LayoutFrame} 0 0 0 0 0 1 0 1 ) #name: #ViewHolder #flags: 11 #component: #createView ) ) ) )' classified: #'interface specs' attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #windowSpec
| aReference aClass aSelector | aReference := #{AJ.MyFirstModel}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass class compile: 'menuBar "Tools.MenuEditor new openOnClass: self andSelector: #menuBar" <resource: #menu> ^#(#{UI.Menu} #( #(#{UI.MenuItem} #rawLabel: ''File'' #submenu: #(#{UI.Menu} #( #(#{UI.MenuItem} #rawLabel: ''Quit'' #value: #closeRequest ) ) #(1 ) nil ) ) #(#{UI.MenuItem} #rawLabel: ''Misc'' #submenu: #(#{UI.Menu} #( #(#{UI.MenuItem} #rawLabel: ''Inspect'' #value: #inspect ) ) #(1 ) nil ) ) ) #(2 ) nil ) decodeAsLiteralArray' classified: #resources attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #menuBar
| aReference aClass aSelector | aReference := #{AJ.MyFirstModel}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass class compile: 'popUpMenu "Tools.MenuEditor new openOnClass: self andSelector: #popUpMenu" <resource: #menu> ^#(#{UI.Menu} #( #(#{UI.MenuItem} #rawLabel: ''do something ...'' #value: #doSomething ) ) #(1 ) nil ) decodeAsLiteralArray' classified: #resources attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #popUpMenu
| aReference aClass aSelector | aReference := #{AJ.MyFirstView}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass compile: 'preferredExtent ^self model image extent' classified: #'bounds accessing' attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #preferredExtent
| aReference aClass aSelector | aReference := #{AJ.MyFirstView}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass compile: 'defaultControllerClass ^#{AJ.MyFirstController} value' classified: #'controller accessing' attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #defaultControllerClass
| aReference aClass aSelector | aReference := #{AJ.MyFirstView}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass compile: 'displayOn: aGraphicsContext self model image displayOn: aGraphicsContext' classified: #displaying attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #displayOn:
| aReference aClass aSelector | aReference := #{AJ.MyFirstController}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass compile: 'redButtonPressedEvent: event | aLocus aGraphicsContext aBlock | aLocus := OrderedCollection new. aGraphicsContext := (self view graphicsContext) capStyle: Graphics.GraphicsContext capRound; joinStyle: Graphics.GraphicsContext joinRound; paint: Graphics.ColorValue red; lineWidth: 3; yourself. aBlock := [[self sensor redButtonPressed] whileTrue: [| aPoint | aPoint := self sensor cursorPoint. aLocus add: aPoint. aGraphicsContext displayPolyline: aLocus. Core.Processor yield. 0.025 seconds wait]. self view displayOn: aGraphicsContext]. UI.Cursor crossHair showWhile: aBlock' classified: #events attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #redButtonPressedEvent:
| aReference aClass aSelector | aReference := #{AJ.MyFirstController}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. aSelector := aClass compile: 'doSomething | aRectangle anImage aGraphicsContext | aRectangle := self view topComponent displayBox intersect: Graphics.Screen default bounds. anImage := Graphics.Screen default completeContentsOfArea: aRectangle. aGraphicsContext := self view graphicsContext. self sensor waitNoButton. UI.Cursor hand showWhile: [UI.InputState default cursorPoint: aRectangle center. anImage follow: [self sensor cursorPoint - anImage bounds center] while: [self sensor noButtonPressed] on: aGraphicsContext. self view invalidateNow]. self sensor waitNoButton' classified: #'menu processing' attributes: ((Dictionary new) add: #package -> 'AJ-MyFirstMVC'; yourself). ^aSelector
==> #doSomething
"AJ.MyFirstModel example." | aReference aClass | aReference := #{AJ.MyFirstModel}. aReference bindingOrNil ifNil: [^self error: 'fatal error']. aClass := aReference value. (aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error']. ^aClass example
==> an UIBuilder
| 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 , '-MyFirstMVC' , '.st'. fileName isEmpty ifTrue: [^nil]. aBundle fileOutOnFileNamed: fileName. ^fileName
==> ~/Desktop/AokiJuku-MyFirstMVC.st