'From Squeak3.7-m17n of 30 June 2004 [latest update: #6] on 2 July 2004 at 3:54:08 pm'! !Object methodsFor: 'objects from disk' stamp: 'yo 7/2/2004 13:16'! saveOnFile "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. Does not file out the class of the object. tk 6/26/97 13:48" | aFileName fileStream | aFileName _ self class name asFileName. "do better?" aFileName _ FillInTheBlank request: 'File name?' initialAnswer: aFileName. aFileName size == 0 ifTrue: [^ Beeper beep]. fileStream _ FileStream newFileNamed: aFileName asFileName. fileStream fileOutClass: nil andObject: self.! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'yo 7/2/2004 13:08'! fileOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'" | file slips nameToUse | self checkForConversionMethods. ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. nameToUse := Preferences changeSetVersionNumbers ifTrue: [self defaultChangeSetDirectory nextNameFor: self name extension: 'cs'] ifFalse: [self name , FileDirectory dot , Utilities dateTimeSuffix , FileDirectory dot , 'cs']. (Preferences warningForMacOSFileNameLength and: [nameToUse size > 31]) ifTrue: [nameToUse := FillInTheBlank request: (nameToUse , '\has ' , nameToUse size asString , ' letters - too long for Mac OS.\Suggested replacement is:') withCRs initialAnswer: (nameToUse contractTo: 30). nameToUse = '' ifTrue: [^ self]]. Cursor write showWhile: [[file := self defaultChangeSetDirectory newFileNamed: nameToUse asFileName. file header; timeStamp. self fileOutPreambleOn: file. self fileOutOn: file. self fileOutPostscriptOn: file. file trailer] ensure: [file close]]. Preferences checkForSlips ifFalse: [^ self]. slips := self checkForSlips. (slips size > 0 and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?' chooseFrom: 'Ignore\Browse slips') = 2]) ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]! ! !Class methodsFor: 'class variables' stamp: 'yo 7/2/2004 13:54'! addClassVarName: aString "Add the argument, aString, as a class variable of the receiver. Signal an error if the first character of aString is not capitalized, or if it is already a variable named in the class." | symbol oldState | oldState _ self copy. aString first canBeGlobalVarInitial ifFalse: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol _ aString asSymbol. self withAllSubclasses do: [:subclass | (subclass bindingOf: symbol) ifNotNil:[ ^ self error: aString , ' is already used as a variable name in class ' , subclass name]]. classPool == nil ifTrue: [classPool _ Dictionary new]. (classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" classPool declare: symbol from: Undeclared. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldState to: self]! ! !Morph methodsFor: 'menus' stamp: 'yo 7/2/2004 13:12'! printPSToFileNamed: aString "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag psCanvasType psExtension | fileName := aString asFileName. psCanvasType _ PostscriptCanvas defaultCanvasType. psExtension _ psCanvasType defaultExtension. fileName := FillInTheBlank request: (String streamContents: [ :s | s nextPutAll: 'File name? ("' translated; nextPutAll: psExtension; nextPutAll: '" will be added to end)' translated ]) initialAnswer: fileName. fileName isEmpty ifTrue: [^ Beeper beep]. (fileName endsWith: psExtension) ifFalse: [fileName := fileName , psExtension]. rotateFlag := ((PopUpMenu labels: 'portrait (tall) landscape (wide)' translated) startUpWithCaption: 'Choose orientation...' translated) = 2. (FileStream newFileNamed: fileName asFileName) nextPutAll: (psCanvasType morphAsPostscript: self rotated: rotateFlag); close! ! !Morph methodsFor: 'objects from disk' stamp: 'yo 7/2/2004 13:14'! saveOnFile "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." | aFileName fileStream ok | aFileName _ ('my {1}' translated format: {self class name}) asFileName. "do better?" aFileName _ FillInTheBlank request: 'File name? (".morph" will be added to end)' translated initialAnswer: aFileName. aFileName isEmpty ifTrue: [^ Beeper beep]. self allMorphsDo: [:m | m prepareToBeSaved]. ok _ aFileName endsWith: '.morph'. "don't double them" ok _ ok | (aFileName endsWith: '.sp'). ok ifFalse: [aFileName _ aFileName,'.morph']. fileStream _ FileStream newFileNamed: aFileName asFileName. fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'yo 7/2/2004 15:09'! createButtonBar | bar button narrowFont registeredFonts | registeredFonts _ OrderedCollection new. TextStyle knownTextStyles do: [:st | (TextStyle named: st) fonts do: [:f | f maxAscii < 256 ifTrue: [registeredFonts addLast: f]]]. narrowFont := registeredFonts detectMin: [:ea | ea widthOfString: 'Contents' from: 1 to: 8]. bar := AlignmentMorph newRow. bar color: self backgroundColor; rubberBandCells: false; vResizing: #shrinkWrap; cellInset: 6 @ 0. #(#('New\Archive' #canCreateNewArchive #createNewArchive 'Create a new, empty archive and discard this one') #('Load\Archive' #canOpenNewArchive #openNewArchive 'Open another archive and discard this one') #('Save\Archive As' #canSaveArchive #saveArchive 'Save this archive under a new name') #('Extract\All' #canExtractAll #extractAll 'Extract all this archive''s members into a directory') #('Add\File' #canAddMember #addMember 'Add a file to this archive') #('Add from\Clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('Add\Directory' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('Extract\Member As' #canExtractMember #extractMember 'Extract the selected member to a file') #('Delete\Member' #canDeleteMember #deleteMember 'Remove the selected member from this archive') #('Rename\Member' #canRenameMember #renameMember 'Rename the selected member') #('View All\Contents' #canViewAllContents #changeViewAllContents 'Toggle the view of all the selected member''s contents')) do: [:arr | | buttonLabel | buttonLabel := (TextMorph new) string: arr first withCRs fontName: narrowFont familyName size: narrowFont pointSize wrap: false; hResizing: #shrinkWrap; lock; yourself. (button := PluggableButtonMorph on: self getState: arr second action: arr third) vResizing: #shrinkWrap; hResizing: #spaceFill; onColor: self buttonOnColor offColor: self buttonOffColor; label: buttonLabel; setBalloonText: arr fourth. bar addMorphBack: button. buttonLabel composeToBounds]. ^bar! ! !BookMorph methodsFor: 'menus' stamp: 'yo 7/2/2004 13:05'! printPSToFile "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag | fileName _ ('MyBook') translated asFileName. fileName _ FillInTheBlank request: 'File name? (".ps" will be added to end)' translated initialAnswer: fileName. fileName isEmpty ifTrue: [^ Beeper beep]. (fileName endsWith: '.ps') ifFalse: [fileName _ fileName,'.ps']. rotateFlag _ ((PopUpMenu labels: 'portrait (tall) landscape (wide)' translated) startUpWithCaption: 'Choose orientation...' translated) = 2. (FileStream newFileNamed: fileName asFileName) nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close. ! ! !PasteUpMorph methodsFor: 'objects from disk' stamp: 'yo 7/2/2004 13:21'! saveOnFile "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." | aFileName fileStream ok | self flag: #bob0302. self isWorldMorph ifTrue: [^self project saveAs]. aFileName _ ('my {1}' translated format: {self class name}) asFileName. "do better?" aFileName _ FillInTheBlank request: 'File name? (".project" will be added to end)' translated initialAnswer: aFileName. aFileName isEmpty ifTrue: [^ Beeper beep]. self allMorphsDo: [:m | m prepareToBeSaved]. ok _ aFileName endsWith: '.project'. "don't double them" ok _ ok | (aFileName endsWith: '.sp'). ok ifFalse: [aFileName _ aFileName,'.project']. fileStream _ FileStream newFileNamed: aFileName asFileName. fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"! ! !Scanner methodsFor: 'expression types' stamp: 'yo 7/2/2004 14:04'! scanLitVec | s | s _ WriteStream on: (Array new: 16). [tokenType = #rightParenthesis or: [tokenType = #doIt]] whileFalse: [tokenType = #leftParenthesis ifTrue: [self scanToken; scanLitVec] ifFalse: [tokenType = #word | (tokenType = #keyword) | (tokenType = #colon) ifTrue: [self scanLitWord. token = #true ifTrue: [token _ true]. token = #false ifTrue: [token _ false]. token = #nil ifTrue: [token _ nil]] ifFalse: [(token == #- and: [((typeTable at: hereChar charCode ifAbsent: [#xLetter])) = #xDigit]) ifTrue: [self scanToken. token _ token negated]]]. s nextPut: token. self scanToken]. token _ s contents! ! !Parser methodsFor: 'error correction' stamp: 'yo 7/2/2004 14:02'! correctVariable: proposedVariable interval: spot "Correct the proposedVariable to a known variable, or declare it as a new variable if such action is requested. We support declaring lowercase variables as temps or inst-vars, and uppercase variables as Globals or ClassVars, depending on whether the context is nil (class=UndefinedObject). Spot is the interval within the test stream of the variable. rr 3/4/2004 10:26 : adds the option to define a new class. " | tempIvar labels actions lines alternatives binding userSelection choice action | "Check if this is an i-var, that has been corrected already (ugly)" (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [ ^LiteralVariableNode new name: proposedVariable index: (encoder classEncoding instVarNames indexOf: proposedVariable) - 1 type: 1; yourself ]. "If we can't ask the user for correction, make it undeclared" self interactive ifFalse: [ ^encoder undeclared: proposedVariable ]. "First check to see if the requestor knows anything about the variable" tempIvar _ proposedVariable first canBeNonGlobalVarInitial. (tempIvar and: [ (binding _ requestor bindingOf: proposedVariable) notNil ]) ifTrue: [ ^encoder global: binding name: proposedVariable ]. userSelection _ requestor selectionInterval. requestor selectFrom: spot first to: spot last. requestor select. "Build the menu with alternatives" labels _ OrderedCollection new. actions _ OrderedCollection new. lines _ OrderedCollection new. alternatives _ encoder possibleVariablesFor: proposedVariable. tempIvar ifTrue: [ labels add: 'declare temp'. actions add: [ self declareTempAndPaste: proposedVariable ]. labels add: 'declare instance'. actions add: [ self declareInstVar: proposedVariable ] ] ifFalse: [ labels add: 'define new class'. actions add: [self defineClass: proposedVariable]. labels add: 'declare global'. actions add: [ self declareGlobal: proposedVariable ]. encoder classEncoding == UndefinedObject ifFalse: [ labels add: 'declare class variable'. actions add: [ self declareClassVar: proposedVariable ] ] ]. lines add: labels size. alternatives do: [ :each | labels add: each. actions add: [ self substituteWord: each wordInterval: spot offset: 0. encoder encodeVariable: each ] fixTemps ]. lines add: labels size. labels add: 'cancel'. "Display the pop-up menu" choice _ (PopUpMenu labelArray: labels asArray lines: lines asArray) startUpWithCaption: 'Unknown variable: ', proposedVariable, ' please correct, or cancel:'. action _ actions at: choice ifAbsent: [ ^self fail ]. "Execute the selected action" requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. ^action value! ! !ScriptNameType methodsFor: 'tiles' stamp: 'sw 12/19/2003 23:11'! defaultArgumentTile "Answer a tile to represent the type" | aTile | aTile _ ScriptNameTile new dataType: self vocabularyName. aTile addArrows. aTile setLiteral: #emptyScript. ^ aTile! ! !SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:24'! changeImageNameTo: aString self imageName: aString asSqueakPathName. LastImageName := self imageName! ! !SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:24'! imageName "Answer the full path name for the current image." "SmalltalkImage current imageName" | str | str _ self primImageName. ^ (FilePath pathName: str isEncoded: true) asSqueakPathName. ! ! !SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:30'! imageName: newName "Set the the full path name for the current image. All further snapshots will use this." | encoded | encoded _ (FilePath pathName: newName isEncoded: false) asSystemPathName. self primImageName: encoded. ! ! !SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:23'! primImageName "Answer the full path name for the current image." "SmalltalkImage current imageName" self primitiveFailed! ! !SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:30'! primImageName: newName "Set the the full path name for the current image. All further snapshots will use this." ^ self primitiveFailed! ! !SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:35'! primVmPath "Answer the path for the directory containing the Smalltalk virtual machine. Return the empty string if this primitive is not implemented." "SmalltalkImage current vmPath" ^ ''! ! !SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:36'! vmPath "Answer the path for the directory containing the Smalltalk virtual machine. Return the empty string if this primitive is not implemented." "SmalltalkImage current vmPath" ^ (FilePath pathName: (self primVmPath) isEncoded: true) asSqueakPathName. ! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'yo 7/2/2004 13:34'! saveAsEmbeddedImage "Save the current state of the system as an embedded image" | dir newName newImageName newImageSegDir oldImageSegDir haveSegs | dir _ FileDirectory default. newName _ FillInTheBlank request: 'Select existing VM file' initialAnswer: (FileDirectory localNameFor: ''). newName = '' ifTrue: [^ Smalltalk]. newName _ FileDirectory baseNameFor: newName asFileName. newImageName _ newName. (dir includesKey: newImageName) ifFalse: [^ self inform: 'Unable to find name ', newName, ' Please choose another name.']. haveSegs _ false. Smalltalk at: #ImageSegment ifPresent: [:theClass | (haveSegs _ theClass instanceCount ~= 0) ifTrue: [oldImageSegDir _ theClass segmentDirectory]]. self logChange: '----SAVEAS (EMBEDDED) ', newName, '----', Date dateAndTimeNow printString. self imageName: (dir fullNameFor: newImageName) asSqueakPathName. LastImageName _ self imageName. self closeSourceFiles. haveSegs ifTrue: [Smalltalk at: #ImageSegment ifPresent: [:theClass | newImageSegDir _ theClass segmentDirectory. "create the folder" oldImageSegDir fileNames do: [:theName | "copy all segment files" newImageSegDir copyFileNamed: oldImageSegDir pathName, FileDirectory slash, theName toFileNamed: theName]]]. Smalltalk snapshot: true andQuit: true embedded: true ! ! !SymbolListTile methodsFor: 'user interface' stamp: 'sw 12/19/2003 23:26'! arrowAction: delta "Do what is appropriate when an arrow on the tile is pressed; delta will be +1 or -1" | index | owner ifNil: [^ self]. literal ifNotNil: [(index _ (choices _ self choices) indexOf: literal) > 0 ifTrue: [self literal: (choices atWrap: index + delta). self adjustHelpMessage. self acceptNewLiteral. self labelMorph informTarget]]! ! !SymbolListTile methodsFor: 'user interface' stamp: 'yo 7/2/2004 14:33'! offerAllChoicesInAPopUp "Offer all choices in a pop-up menu" | aMenu s | owner ifNil: [^ self]. aMenu _ MenuMorph new defaultTarget: self. self choices do: [:aSym | s _ aSym = #emptyScript ifTrue: [aSym "translated"] ifFalse: [aSym]. aMenu add: s target: self selector: #acceptNewLiteral: argument: aSym]. aMenu popUpInWorld: ActiveWorld! ! !SystemDictionary methodsFor: 'image, changes name' stamp: 'yo 7/2/2004 13:31'! changeImageNameTo: aString ^ self deprecated: 'Use SmalltalkImage current changeImageNameTo: ', aString block: [SmalltalkImage current changeImageNameTo: aString] ! ! !SystemDictionary methodsFor: 'image, changes name' stamp: 'nk 11/12/2003 10:28'! imageName "Answer the full path name for the current image." "Smalltalk imageName" ^ self deprecated: 'Use SmalltalkImage current imageName' block: [SmalltalkImage current imageName]! ! !SystemDictionary methodsFor: 'image, changes name' stamp: 'yo 7/2/2004 13:31'! imageName: newName "Set the the full path name for the current image. All further snapshots will use this." ^ self deprecated: 'Use SmalltalkImage current imageName: ', newName block: [ SmalltalkImage current imageName: newName ]! ! !SystemDictionary methodsFor: 'image, changes name' stamp: 'nk 11/12/2003 10:35'! vmPath "Answer the path for the directory containing the Smalltalk virtual machine. Return the empty string if this primitive is not implemented." "Smalltalk vmPath" ^ self deprecated: 'Use SmalltalkImage current vmPath' block: [SmalltalkImage current vmPath]! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'yo 7/2/2004 13:32'! m17nVersion ^ 'M17n 5.0' copy ! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'yo 7/2/2004 13:32'! nihongoVersion ^ 'Nihongo7.0' copy ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'yo 7/2/2004 13:35'! saveAsEmbeddedImage "Save the current state of the system as an embedded image" ^ self deprecated: 'Use SmalltalkImage current saveAsEmbeddedImage' block: [SmalltalkImage current saveAsEmbeddedImage] ! ! !TextStyle methodsFor: 'fonts and font indexes' stamp: 'nk 6/12/2004 16:31'! fontIndexOfPointSize: desiredPointSize "Returns an index in fontArray of the font with pointSize <= desiredPointSize" "Leading is not inluded in the comparison" | bestMatch bestIndex d | bestMatch _ 9999. bestIndex _ 1. 1 to: fontArray size do: [:i | d _ desiredPointSize - (fontArray at: i) pointSize. d = 0 ifTrue: [^ i]. (d > 0 and: [d < bestMatch]) ifTrue: [bestIndex _ i. bestMatch _ d]]. ^ bestIndex! ! !TextStyle methodsFor: 'fonts and font indexes' stamp: 'nk 6/12/2004 16:33'! fontOfPointSize: aPointSize ^ fontArray at: (self fontIndexOfPointSize: aPointSize)! ! !Unicode class methodsFor: 'class methods' stamp: 'yo 7/2/2004 13:41'! value: code | l | code < 256 ifTrue: [^ Character value: code]. l _ Smalltalk systemLanguage leadingChar. l = 0 ifTrue: [l _ 255]. ^ MultiCharacter leadingChar: l code: code. ! ! !VersionsBrowser methodsFor: 'init & update' stamp: 'yo 7/2/2004 13:40'! scanVersionsOf: method class: class meta: meta category: category selector: selector | position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp | selectorOfMethod _ selector. currentCompiledMethod _ method. classOfMethod _ meta ifTrue: [class class] ifFalse: [class]. changeList _ OrderedCollection new. list _ OrderedCollection new. self addedChangeRecord ifNotNilDo: [ :change | self addItem: change text: ('{1} (in {2})' translated format: { change stamp. change fileName }) ]. listIndex _ 0. position _ method filePosition. sourceFilesCopy _ SourceFiles collect: [:x | x isNil ifTrue: [ nil ] ifFalse: [x readOnlyCopy]]. method fileIndex == 0 ifTrue: [^ nil]. file _ sourceFilesCopy at: method fileIndex. [position notNil & file notNil] whileTrue: [file position: (0 max: position-150). "Skip back to before the preamble" preamble _ method getPreambleFrom: file at: (0 max: position - 3). "Preamble is likely a linked method preamble, if we're in a changes file (not the sources file). Try to parse it for prior source position and file index" prevPos _ nil. stamp _ ''. (preamble findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [tokens _ Scanner new scanTokens: preamble] ifFalse: [tokens _ Array new "ie cant be back ref"]. ((tokens size between: 7 and: 8) and: [(tokens at: tokens size-5) = #methodsFor:]) ifTrue: [(tokens at: tokens size-3) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp _ tokens at: tokens size-2. prevPos _ tokens last. prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: prevPos. prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos] ifFalse: ["Old format gives no stamp; prior pointer in two parts" prevPos _ tokens at: tokens size-2. prevFileIndex _ tokens last]. (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]]. ((tokens size between: 5 and: 6) and: [(tokens at: tokens size-3) = #methodsFor:]) ifTrue: [(tokens at: tokens size-1) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp _ tokens at: tokens size]]. self addItem: (ChangeRecord new file: file position: position type: #method class: class name category: category meta: meta stamp: stamp) text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector. position _ prevPos. prevPos notNil ifTrue: [file _ sourceFilesCopy at: prevFileIndex]]. sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]. listSelections _ Array new: list size withAll: false! ! !ZipArchiveMember methodsFor: 'accessing' stamp: 'yo 7/2/2004 15:13'! contentStream "Answer my contents as a string." | s | s _ MultiByteBinaryOrTextStream on: (String new: self uncompressedSize). self extractTo: s. ^s reset. ! !