Copyright 1988 Digitalk Inc. All rights reserved ! Object class methods ! initDependents "Initialize Dependents dictionary empty DependentsIdentity ! "Initialize detecting recursive data structures RecursiveSetSet . RecursionInError! 腦 " real in bytes | indexed = Small : [ ^ 0 ]. inst * 4. indexed := . Pointers : [ indexedindexed * 4 ] : [ ( Bytes indexed odd]) : [ indexedindexed1] ^ 14indexed! tableOfClasses " TableOfClasses ^ TableOfClasses! ! ! Object methods ! = "This default equality test. are same , <110>! == " are same , <110>! addDependent "Add Dependents (Dependents ԅ Absent Dependents ԅ Ordered ]) add! allDependents " a Set all dependents | ProcessNow ProcessNext Set . ProcessNow dependents. [ProcessNow Empty] ⓒ ProcessNextSet . ProcessNow dodependent ( includesdependent) adddependent. ProcessNext addAlldependent dependents]]. ProcessNowProcessNext ^ ! allReferences " all objects which refer <93> ^ Failed! asParameter " Macintosh Toolbox that converts . Most objects can not be passed directly as parameters Macintosh Toolbox routines ^ : 'can not convert'! ԅ " in . If does not have indexed , or greater than indexed , report <60> ^ Failed! ԅ " . Replace in . If does not have indexed , or greater than indexed , report <61> ^ Failed! At " in . If does not have indexed , or greater than indexed , report <60> ^ Failed! At " . Replace in . If does not have indexed , or greater than indexed , report <61> ^ Failed! Hash "Return hash field in header <97>! " indexed in <62>! become "The takes on identity . All objects system that referenced will now reference <72> ^ Failed! broadcasta "Send argument a as a unary message all ' s dependents dependents dodependent dependent performa ]! broadcasta "Send argument a as a keyword message argument all ' s dependents dependents dodependent dependent performa ]! cantReturn "Initiate a walkback trying exit a more than once : 'attempt exit same more than once'! "The in some general way. Inform all dependents by sending each dependent update message ΅! ΅aParameter "Something has related dependents . Send ' updateaParameter' message all dependents (Dependents ԅ Absent: [#()]) dodependent dependent updateaParameter]! ΅Parameter secondParameter "Something has related dependents . Send ' updateParameter : secondParameter' message all dependents (Dependents ԅ Absent: [#()]) dodependent dependent updateParameter secondParameter]! ΅Parameter secondParameter thirdParameter "Something has related dependents . Send ' updateParameter : secondParameter' message all dependents (Dependents ԅ Absent: [#()]) dodependent dependent updateParameter secondParameter thirdParameter]! " <111> ^ Failed! " a shallow ^ shallowCopy! deepCopy " a shallow copies each | a Vars a . a Variable Vars . a Vars] Vars0. a a Pointers 1 Varsa inst doي instVarAt ܃ instVarAt) ]] 1 Vars doي At ܃ At)]]. ^ ! dependents " a all dependents ^Dependents ԅ Absent: [^ Ordered ]! dependsOn "Add ' s dependents addDependent! doesNotUnderstandaMessage "Initiate a walkback because a message was sent which not understood, i. e., there no matching — ^ : 'message not understood: ', aMessage selector! equals " are same , <110>! a "Create a walkback describing condition message a in label Process queueWalkbacka makeUserIFCurrentProcess UserIF resumable! halt "Initiate a walkback ' halt encountered' message debugging Process queueWalkback: 'halt encountered' makeUserIFCurrentProcess UserIF resumable! hash " integer hash . This default implementation which uses hash assigned creation time <97>! id " integer id <97>! implementedBySubclass "Initiate a walkback because a subclass doesn' t implement a message that it should ^ : 'my subclass should have implemented this message'! inspect "Open inspector on Inspector openOn! instVarAt " in . Both named indexed are indexed <73> ^ Failed! instVarAt " . Replace in . Both named indexed are indexed <74> ^ Failed! invalidMessage "Initiate walkback because inappropriate message was sent ^ : 'inappropriate message this '! Context " Context or one its subclasses, ^ ! KindOfa " a or one its subclasses, ^ inheritsa! MemberOfa " a, ^ a! Nil " nil, ^ ! makeWeakaBoolean "Set weak flag in aBoolean <92>! mustBeBoolean "Initiate a walkback describing that not a Boolean ^ : ' not a Boolean'! mustBeKindOfa "Report not a or one its subclasses ( KindOfa) : 'must be ', (a symbol Vowel : [ ' ' ] : [ 'a ' ]), a , ' or one its subclasses' ]! notNil " not nil, ^ ! performa " sending a unary message selector a. Report arguments expected by selector not zero <145> ^ performa Arguments: #()! performa " sending a binary message selector a argument . Report arguments expected by selector not one <146> ^ performa Arguments )! performa second " sending a keyword message selector a arguments second. Report arguments expected by selector not two ^ performa Arguments: ( second)! performa second third " sending a keyword message selector a arguments , second third. Report arguments expected by selector not three ^ performa Arguments: ( second third)! performa Arguments " sending a message selector a arguments . Report arguments expected by selector not equal | a <84> a aa . ^ : 'performexpects a , not ', ((a ԅ1) Vowel : [' ' , a] : ['a ' , a])]. ^ : 'perform: ' , , ' ' , a , ' did not expect ' , , ' arguments'! Failed "Initiate a walkback label failed message ^ : 'system failed'! Ona "Append ASCII a. This default implementation which prints ' a' (' ') followed by ؗ | a a . (a ԅ1) Vowel a PutAll: ' '] a PutAll: 'a ']. a PutAlla! RecursionOna "This used printing recursive data structures detected in cyclic structure a PutAll: ' ...recursive reference '; PutAll ; PutAll: '... '! " a that ASCII , using On:." | a a RecursiveSetSet . a 20. OnaWrite ona). ^ a ! release "Discard all dependents , any Dependents removeKey Absent: []! release "Discard dependents | dependents dependentsDependents ԅ Absent dependents remove Absent: []. dependents Empty Dependents removeKey] Dependents ԅ dependents ^! respondsToa " or one its superclasses implements a selector equal a ^ canUnderstanda! shallowCopy " a which shares | a a . a Variable . a ] 0. a a Pointers 1 a inst doي instVarAt ܃ instVarAt)]] 1 doي At ܃ At)]]. ^ ! " indexed in <62> ^ Failed! species " a which similar (or same as) which can be used derived copies ^ ! stackOverflow "When stack overflows, we send this message ^ : 'Stack Overflow'! storeOna "Append ASCII a which can be reinstantiated | a noneYet (RecursiveSet includes) RecursiveSetSet . ^ : 'recursive storeOnnot allowed in ']. RecursiveSet add. a . a PutAll: '(('; PutAlla ; PutAll: ' New'. a Variable a Put: $:. Ona a Put: $). noneYet. 1 a inst doي noneYet noneYet a PutAll: 'instVarAt:'. Ona. a PutAll: ' :'. ( instVarAt) storeOna. a Put: $;]. noneYet a PutAll: 'yourself']. a Put: $). RecursiveSet remove Absent: []! store " represented as a which it can be reconstructed | a aWrite on܈ 16). storeOna. ^ a ! updateaParameter "An on whom dependent has . The updates its status accordingly ( default behavior do nothing). The argument aParameter usually identifies kind update! updateParameter secondParameter "An on whom dependent has . The updates its status accordingly ( default behavior do nothing). The argument Parameter usually identifies kind update secondParameter a unary message defined in protocol! updateParameter secondParameter thirdParameter "An on whom dependent has . The updates its status accordingly ( default behavior do nothing). The argument Parameter usually identifies kind update secondParameter a unary message defined in protocol! vmInterrupta "Process virtual machine interrupt Process performa. ^ ! yourself " ^ ! ~= " do not compare equal (using =), ^ ( = ) not! ~~ " are not same , ^ (戀) not! ! ! Behavior class methods ! "Initialize that describe structure masks bits InstPointerBit16r100000. InstIndexedBit16r080000. InstMask := 16rFFFF! ! ! Behavior methods ! addSelectora MethodaCompiledMethod "Add aCompiledMethod message using a as key. If a not a report mustBea. message ԅa aCompiledMethod! addSubclassa "Add a subclasses . Make superclass a ( subclasses includesa) : [^ subclasses܃ subclasses Witha). a superclass! allClasses " a Set all classes contained in | Set . associationsDoeach (each KindOfBehavior) (each trimBlanks Empty) addeach ]]]. ^ ! allVarNames " a Set strings all names defined in its superclasses | VarNames. allSuperclasses do: [:each addAlleach VarNames ^ ! allInstances " all instances <38> Failed! allInstVarNames " strings all names defined in its superclasses | instVarNames. allSuperclasses doeach each instVarNames , ^ ! allSubclasses " Ordered all subclasses in hierarchical order. Classes same hierarchical level are sorted alphabetically | sortedSubclasses Ordered . sortedSubclassesSorted sort sort. sortedSubclasses addAll subclasses. sortedSubclasses doeach addeach; addAlleach allSubclasses ^ ! allSuperclasses " Ordered all superclasses . The superclasses are in inverse hierarchical order, i. e last | super asOrdered. removenil. ^ ! New " . If indexable, then allocate zero indexed . This should never be reimplemented in any subclass Behavior since it allocation message <70> Variable : [^ New0 ^ Failed! New " . Allocate indexed . If does not have indexed reported. This should never be reimplemented in any subclass Behavior since it allocation message <71> Fixed : [^ NotIndexable ^ Failed! canUnderstanda " or any superclasses implement named a, (message includesKeya) : [^ allSuperclasses detecteach | each includesSelectora] None: [^ ^ ! Variable " a all names defined by . The names are separated blanks | . VarNames doeach , each , ( : $ )]. ^ ! comment " comment ^ comment! commentaComment "Set comment aComment (aComment Nil) : [^ commentnil (aComment KindOf) : [^ commentaComment Empty : [nil] aComment]]. : 'comment must be or nil'! compilecode "Compile contained in code. The use resolving . If there are no errors, add message message selector as key compiled as . If there , nil | Compiler compilecode in. notNil addSelector key Method ^ ! compilecode notifyingrequestor "Compile contained in code. The use resolving . If there are no errors, add recevier message message selector as key compiled as . If there requestor sent a message by compiler identitfying this answers nil | Compiler compilecode in notifyingrequestor Fail: [ ^ nil ]. addSelector key Method . ^ ! compileAll "Recompile all methods defined in . If any methods are recompiled, a message on Transcript message Empty : [^ Transcript cr; show: 'recompiling ', . doeach recompileeach ]! compileAllSubclasses "Recompile all methods defined in or in any its subclasses | a allSubclasses do: [:each aeach trimBlanks. (a Empty ora = '']) each compileAll]]! compiledMethodAta " compiled code named a defined in ^ message ԅa Absent: [^ nil]! computeInst "Compute named instances adjust structure accordingly. The based on instances array defined by superclass | superclassnil : [0] superclass inst inst腥instances ! deepCopy " a shallow copies each . Because classes are unique ( cannot be copied), ^ ! NotIndexable "When trying make indexed not indexable, produce a walkback ^ : , 's do not have indexed '! hash " integer hash ^ hash! id "Set id <102> ^ Failed! includesSelectora " message dictionary includes a a, ^ message includesKeya! inheritsa " can inherit methods a, | . [nil] ⓒ (a) : [^ superclass ^ ! Variable " a all names defined by . The names are separated spaces | a aWrite on܈ 16). instVarNames doeach a PutAlleach; space ^ a ! inst " named contained in instances ^ Pointers : [structure bitAndInstMask] 0]! inst腥 "Set named contained in instances ( Bytes ~= 0]) : ' must be zero']. structure܃ structure bitAnd16r3FFF0000) + .! instVarNames " array names defined by instances Nil instances 0 ^ instances! instVarNamesinst "The inst contains a list names separated blanks. Use this list instances array names. Recompute named instances instances all subclasses | ̈́inst asOfSubstrings. instances. computeInst. allSubclasses doc | c computeInst]! Bytes " instances contain 8 bit byte values, ^ Pointers not! Damaged " not a valid or meta . It condsidered damaged any following conditions are : 1) its not a symbol. 2) there no entry in as its key. 3) entry in does not contain , or a whose meta- . 4) table classes entry stored id 1 not . " | ST ~= : [ ^ ]. ST ԅ Absent: [ ^ ]. ( ~= ST ~= ST ]) : [ ^ ]. ^ ( tableOfClasses ԅ id1) ~= ! Fixed " instances do not contain indexed , ^ ( structure bitAndInstIndexedBit) = 0! Pointers " instances contain pointers instead 8 bit values, ^ ( structure bitAndInstPointerBit) ~= 0! Variable " instances contain indexed , ^ Fixed not! kindOfSubclass " a describing type. The choices are:' subclass:', ' Subclass:', ' ByteSubclass:'." Fixed :[^ 'subclass:']. Bytes :[^ 'ByteSubclass:']. Pointers :[^ 'Subclass:']. : 'unknown kind '! " dictionary methods defined in ^ message! ˅aMethod "Change dictionary methods be aMethod˗ aMethod mustBeKindOfMethod. message˄aMethod! methods " Reader initialized ^ Reader 㳅! " . If indexable, then allocate zero indexed . This frequently reimplemented as a message in classes that need special initialization their instances <70> Variable : [^ 0 ^ Failed! " . Allocate indexed . If does not have indexed reported. This frequently reimplemented as a message in classes that need special initialization their instances <71> Fixed : [^ NotIndexable ^ Failed! a "Change be a mustBea. ؄a! Ona "Print on a a PutAll .! recompilea "Recompile named a defined in | „ compiledMethodAta. hasSource : [ ^ Transcript cr; show: ' No ', a ]. . . ݄Compiler compile܃ CodeAta) in. nil : [^ ] keya : 'Lost Source code ', a addSelectora Method „ . notNil ]! removeSelectora "Remove named a methods defined in message removeKeya Absent: []! removeSubclassa "Remove a as a subclass subclasses: ( subclasses asSet removea Absent: []; yourself)! " a Set symbols names methods defined by ^ message keys! sendersOfa " a methods myself my subclasses that send message a | methods implied implieda codeFor. methodsOrdered 30. AllSubclasses do٠ do ( includesa implied) methods add] do ( includesa implied) methods add] ] ^ methods! shallowCopy " a which shares . Because classes are unique (cannot be copied), ^ ! sharedVariable " a all pool dictionary names referred by . The names are separated blanks | a aWrite on܈ 16). sharedPools doeach a PutAlleach; space ^ a ! CodeAta " a code named s in | „ compiledMethodAta. Nil : [^ a] :[ ( KindOfCompiledMethod) hasSource : [^ ]]]. ^ ' *** No available *** "', a, '" in : ', , ' '! structure " integer that describes structure instances . Refer Behavior a definition this integer ^ structure! structure "Change structure that instances will have. The structure defined by . Refer Behavior a definition this integer structure! subclasses " array subclasses subclasses Nil : [^ ] : [^ subclasses]! subclassesa "Change subclasses be classes in a a Empty subclassesnil] :[subclassesa as]! superclass " superclass ^ super ԅ1! superclassa "Set superclass super := ( a), a allSuperclasses, ( nil)! symbol " symbol ^ ! AllSubclasses " Ordered all its subclasses in hierarchical order | Ordered . allSubclasses doeach each trimBlanks Empty addeach]]. ^ ! ! ! Class class methods ! cleanTableOfClasses "THIS METHOD IS DANGEROUS. DO NOT MODIFY IT WITHOUT UNDERSTANDING IT FULLY. What it does , walk through table classes, removing any entries which do not seem be reasonable. WARNINGIf you are doing non-standard things classes, check : Meta>>Damaged carefully before running this . If Damaged will return one your classes, DO NOT RUN cleanTableOfClasses | t c ccl t tableOfClasses. 1 t 1 doi "All entries (except last) must be a smallint..." ((ccl := (ct ԅi) ) ~= Small) " ... or a (or meta-)." (ccl ~= Meta ccl ~= Meta]) markIdFreei ] "If it a , it must be valid..." c Damaged c allInstances doinst | inst becomenil ]. c becomenil. markIdFreei ] " ... right place in table c id1 ~= i markIdFreei] ] ] ] ]! markIdFree "Return i'th entry in TableOfClasses free list Transcript cr; show: 'Returning entry ', , ' table.'. TableOfClasses ԅ TableOfClassesFreeListHead. TableOfClassesFreeListHead! regenerateShutDownList "Re-build shutdown list by looking all classes which can respond message shutdown ShutdownList Ordered . allClasses docl (cl includesSelectorshutdown:) : [ ( ShutdownList) addcl ] ^ ShutdownList! shrinkTableOfClasses "Collapse table classes minimum (plus enough space least 32 classes). bytes saved | old cl Table last "Compute minimum " oldTableOfClasses . [ clTableOfClasses ԅ. cl Nil orcl = Small] ] : [ 脣1 ]. := (32) min2049. >= old "Table already minimum , so just return ^ 0 "Copy entries old table , renumber free list high low Table . Table last) nil. 1 1 by: -1 doi clTableOfClasses ԅi. (cl KindOfBehavior) Table ԅi cl ] Table ԅi last. lasti ] TableOfClasses becomeTable. TableOfClassesFreeListHeadlast. ^ old褣 * 4! sort " a sort block sorting classes alphabetically ^ [ :a :b | a symbol <= b symbol ]! ! ! Class methods ! addVara "Add a named a (a ԅ1) UpperCase : ' names must begin uppercase']. ( allVarNames includesa) : ' already exists']. Pool ԅa nil! addSharedPoola "Add shared pool named a shared pool references ( sharedPools includesa) : ' already contains pool: ', a ( includesKeya) : 'Pool ', a, ' not defined']. sharedPoolssharedPools, ( a)! Pool " dictionary defined in Pool Nil Pool ^ Pool! VarNames " a Set names defined in ^ Pool keys! VarNamesVar "Change defined in be names contained in Var | aSet aSetVar asOfSubstrings asSet. ( Pool keys rejectn | aSet includesn]) do: [:Var| removeVarVar (aSet rejectn | Pool includesKeyn]) do: [:Var| addVarVar]! edit "Open a Browser on Browser openOn! OutOna "Append definition message a | a a cr; PutAll superclass ; space; PutAll kindOfSubclass; space; PutAll store; cr; space; space. Bytes a PutAll: 'VariableNames: '. (a Variable) Empty :[a cr; PutAll: ' ']. a PutAlla store; cr; space; space a PutAll: 'VariableNames: '. (a Variable) Empty :[a cr; PutAll: ' ']. a PutAlla store; cr; space; space; PutAll: 'poolDictionaries: '. (a sharedVariable) Empty :[a cr; PutAll: ' ']. a PutAlla store! "Initialize defined in . Subclasses usually override this message. The default set all nil Pool associationsDo: [:each | each nil]! ճ "Initialize describe a default no methods or message˄Method :2. structure܃ superclassnil structure] :[ superclass structure]). instances 0. Pool 0. sharedPools :0! " a ؗ Nil : [^ '' ]. ^ as! pointerpointerBoolean Boolean "Construct structure specification integer as defined by arguments. Adjust subclasses as required pointerBoolean allSubclasses doc c Pointers : [^ : 'Has pointer subclasses']]]. pointerBoolean : [ structure: ( structure bitOrInstPointerBit)] : [ structure: ( structure bitAndInstPointerBit bitInvert)]. Boolean : [ structure: ( structure bitOrInstIndexedBit)] : [ structure: ( structure bitAndInstIndexedBit bitInvert)]! removeVara "Remove named a ( Pool includesKeya) a, ' not a ']. Pool removeKeya! removeSystem "Remove . Report there are any subclasses or instances | methods meta 2 allInstances notEmpty : [^ : 'Has instances']. allSubclasses notEmpty : [^ : 'Has subclasses']. RemoveKey Absent: []. TableOfClasses Of . 2TableOfClasses Of. superclassnil superclass removeSubclass becomeDeleted . superclassnil superclass removeSubclass becomeDeleted. TableOfClasses ԅ TableOfClassesFreeListHead. TableOfClassesFreeListHead. TableOfClasses ԅ2 TableOfClassesFreeListHead. TableOfClassesFreeListHead2.! removeSharedPoola "Remove reference in shared pool dictionary named a ( sharedPools includesa) : 'shared pool: ', a, ' not defined']. sharedPoolssharedPools Withouta! renamea "Rename a renamea in! renamea inaSystem "Rename a in environment aSystem˗ | a association aa as. (aSystem includesKeya) ^ : 'can''t rename existing ']. nil association keya ] associationaSystem associationAt. aSystem removeKey Absent: []. association keya aSystem addassociation. a. a! sharedPools " symbols pool dictionary names referred by recevier sharedPools Nil sharedPools ^ sharedPools asSet! sharedPoolspool "Change shared pool dictionaries referred by ones named in pool | aSet aSetpool asOfSubstrings asSet. aSetaSet collectn | n as ( sharedPools rejectn | aSet includesn]) dopool | removeSharedPoolpool (aSet rejectn | sharedPools includesn]) dopool | addSharedPoolpool]! subclass VariableNamesVariables VariableNamesVariables poolDictionariespoolDictNames "Create or modify be a subclass specifed , , pool dictionaries | aMeta Bytes : [^ : 'Superclass non-pointers']. aMetaMeta subclassOf named. ^ aMeta ؅ environment subclassOf VariableNamesVariables 元 Variable pointers VariableNamesVariables poolDictionariespoolDictNames comment ΅nil! ByteSubclass VariableNamesVariables poolDictionariespoolDictNames "Create or modify be a byte subclass specified pool dictionaries | aMeta inst0 : [^ : 'Superclass has pointers']. aMetaMeta subclassOf named. ^ aMeta ؅ environment subclassOf VariableNames pointers VariableNamesVariables poolDictionariespoolDictNames comment ΅nil! Subclass VariableNamesVariables VariableNamesVariables poolDictionariespoolDictNames "Create or modify be a subclass specifed , , pool dictionaries | aMeta Bytes : [^ : 'Superclass non-pointers']. aMetaMeta subclassOf named. ^ aMeta ؅ environment subclassOf VariableNamesVariables pointers VariableNamesVariables poolDictionariespoolDictNames comment ΅nil! ! ! MetaClass class methods ! allocateHashaOrMeta "Allocate a hash aOrMeta. The hash set in TableOfClasses1 | Hash (TableOfClasses ԅTableOfClassesFreeListHead) Nil : [ growTableOfClasses ]. HashTableOfClassesFreeListHead. TableOfClassesFreeListHeadTableOfClasses ԅHash. TableOfClasses ԅHash aOrMeta. aOrMeta idHash1. ^ aOrMeta! deallocateHasha "Deallocate a hash | Hash Hasha id1. (TableOfClasses ԅHash) == a : 'Inconsistant hashes' ]. TableOfClasses ԅHash TableOfClassesFreeListHead. TableOfClassesFreeListHeadHash. ^ ! growTableOfClasses "Expand TableOfClasses accomodate more classes | pointer old TableOfClasses >= 2049 : [ : ' table full' ]. := (TableOfClasses * 2) min2049. ̈́ . oldTableOfClasses . 1 old1) TableOfClasses startingAt1. old ܣ1) doaLink ԅaLink aLink1 TableOfClasses become. TableOfClassesFreeListHeadold.! " a metaclass that partially initialized empty message dictionary a default structure ^ super structure structure; Method 2); yourself! subclassOfa nameda " a metaclass that a subclass metaclass a | Meta existing existing ԅa Absent Meta . Meta superclass: (a ] a ]). allocateHashMeta. ^ Meta (existing KindOf) a, ' not a ']. Metaexisting . ^ Meta! ! ! MetaClass methods ! Pool " pool dictionary only (a ) (a metaclass)." ^ Pool! VarNames " a Set names defined in ^ VarNames! " Nil ^ : 'metaclass does not have '] :[^ ԅ]! " a ؗ | a Nil : [^ '' ]. a 6. a 1 . ^ a 1 6 : ' '! ؅ environmentaSystem subclassOfsuperclass VariableNamesOfInstVarNames Boolean pointerspointerBoolean VariableNamesOfVarNames poolDictionariesOfPoolNames commentcomment ΅ "Create or modify metaclass be as defined by arguments | a a ( ԅ1) UpperCase a] a := (( ܣ ԅ1) asUpperCase), ( 2 )) as (aSystem includesKeya) aSystem ԅa. ( KindOf) ^ a, ' not a ']. superclasssuperclass ^ : 'Cannot superclass']. instVarNames = OfInstVarNames asOfSubstrings AllSubclasses doa a allInstances notEmpty : [^ : 'Has instances']]]] . Meta allocateHash. superclass addSubclass. superclass addSubclass. ճ; renamea inaSystem pointerpointerBoolean Boolean; instVarNamesOfInstVarNames; VarNamesOfVarNames; sharedPoolsOfPoolNames. aWrite on܈ 64). OutOna. logSourcea 㳅. compileAll. compileAll. allSubclasses doa a compileAll. a compileAll ^ ! a "Change be a ؄a! sharedPools " symbols pool dictionary names referred by recevier ^ sharedPools! ! ! BitBlt class methods ! bitBltErrorCode "Initiate a walkback label failed message ^ BitBltErrors ԅCode)! ڱd s " a BitBlt d s as its destination Forms ^ super ڱd s! ! ! BitBlt methods ! clipRect " clipping ^ clipX @ clipY : clipWidth @ clipHeight! clipRecta "Set clipping a clipXa left. clipYa top. clipWidtha . clipHeighta ! clipX " x- coordinate clip ^ clipX! clipY " y-coordinate clip ^ clipY! combinationRule "Set rule combining bits destination forms rule! Bits "Copy bits destination form | err <115> "First, check we failed because mode we are using not possible on Mac, so, try handle it using multiple blits errErrorCode. ErrorCode0. err1 : [^ handleExceptionalBlitModes ]. ^ BitBlt bitBltErrorerr! ڱ " destination form ^ ڱ! ڱa "Set destination form a ڱa! ڱd s " d s as its destination Forms s. ڱd. XY0. XY0. clipXclipY0. Ȅd . d . clipWidthd . clipHeightd . rule over! ڱdestination halftonemask combinationRulecombinationRule OriginOrigin OriginOrigin clipRectclipRect "Initialize all ڱdestination. . halftonemask. rulecombinationRule. XOrigin x. XOrigin x. YOrigin y. Ȅ x. y. clipXclipRect left. clipYclipRect top. clipWidthclipRect . clipHeightclipRect . Y :=Origin y! Origina "Set destination a Xa x. Ya y! Recta "Set destination a Xa left. Ya top. Ȅa . a ! X " x- coordinate destination ^ X! X "Set x- coordinate destination X! Y " y- coordinate destination ^ Y! Y "Set y- coordinate destination Y! draw stop "Draw a line stop X x. Y y. drawTostop! drawLoopXxDelta YyDelta "Draw a line destination a distance specified by xDelta yDelta | err <100> errErrorCode. ErrorCode0. ^ BitBlt bitBltErrorerr! drawToa "Draw a line destination point a drawLoopXa xX Ya yY! " a point whose cordinates are transfer area ^ @ ! a "Set transfer area coordinates a Ȅa x. a y! handleExceptionalBlitModes "This code handles modes which Mac toolbox does not support directly | Source oldSource oldHalftone oldRule rule orThru "To handle orThru mode, we do two blits oldHalftonehalftone. rule erase. halftonenil. Bits. halftoneoldHalftone. rule under. Bits. rule orThru. ^ halftone notNil "If we are not in orThru mode, then we failed because we can't use halftones some modes. In this case, we make a which AND old halftone, use this. For two modes (8 11), we assume that C code has already reversed destination, we just convert blit unreversing version oldRulerule. rule8 rule4 rule11 rule7 BitBlt ڱܣSource deepCopy) nil halftonehalftone combinationRule Rule Origin0@0 Origin0@0 clipRect boundingBox; Bits. oldSource. oldHalftonehalftone. halftonenil. Source. Bits. halftoneoldHalftone. oldSource. ruleoldRule. ^ BitBlt bitBltError1! " transfer area ^ ! "Set transfer area ! mask " mask form which provides halftone effect ^ halftone! maskmask "Set mask (halftone) form mask halftonemask! " form ^ ! a "Set form a a! Origina "Set a Xa x. Ya y! Recta "Set a Xa left. Ya top. Ȅa . a ! X " x-coordinate ^ X! X "Set x-coordinate X! Y " y-coordinate ^ Y! Y "Set y-coordinate Y! " transfer area ^ ! ȅ "Set transfer area Ȅ! ! ! CharacterScanner class methods ! ! ! CharacterScanner methods ! alligna ԅa show " -" a ׅ ԅa x + (font distanceOf1 ina) @ a y! blanka ȅ "Blank whose a, , font " blankBitBlt Xa x x; Ya y y; ȅ; font ; Bits.! blankRest "Blank bottom portion starting row blankBitBlt X x; Y y; ȅ ; bottom; Bits! clipRecta "Set clipping super clipRecta. blankBitBlt clipRecta! Chars "Copy bit pattern destination form. Hide cursor in transfer area | err <59> "First, check we failed because mode we are using not possible on Mac, so, try handle it using multiple blits errErrorCode. ErrorCode0. err1 : [^ handleExceptionalModes ]. ^ BitBlt bitBltErrorerr! CharsNonPrim "Copy bit pattern destination form. Hide cursor in transfer area | Char end saveWidth endX + (font Widthtext). saveWidth. Ȅfont . textPos textEnd doٖ Xfont XOf: (Chartext ԅ). Ȅfont charWidthChar. Bits. XXfont . X > end : [ȄsaveWidth. ^ ]].! a ԅa " bit pattern a a in a ׅ1 a ԅa! a ׅ ԅa " bit pattern a starting up last a in . The remaining line after last will be blanked blanka ȅ Ȥa x. Xa x x. Ya y y. Ȅ Ȥa x. font . XY0. texta. textPos. textEnda . Chars. XX.! a ׅ stop ԅa " bit pattern a stop a in blanka font Widtha). NoBlanka ׅ stop ԅa.! Alla ׅLine lastLine ԅcolumn " part a between Line lastLine blankBitBlt X x; Y y; ȅ ; ; Bits. a = 0 : [ ^ ]. Ȅ . font . Y y. XY0. X x - (font distanceOfcolumn1 ina ԅLine)). textPos1. Line lastLine do: [:i texta ԅi. textEndtext . Chars. YY]! Alla ׅLine lastLine XxValue " part a between Line lastLine blankBitBlt X x; Y y; ȅ ; ; Bits. a = 0 : [ ^ ]. Ȅ . font . Y y. XY0. X xxValue. textPos1. Line lastLine do: [:i texta ԅi. textEndtext . Chars. YY]! a ԅa ruleaRule " a a in by aRule Blitter ڱڱ a halftonenil combinationRuleaRule Origin a Origin0@0 a clipRect clipRect; Bits! NoBlanka ׅ stop ԅa " bit pattern a stop a in Xa x x. Ya y y. texta. textPos. textEndstop. Chars! font " font used by ^ font! " framing . Usually it same as clipping latter sometimes a smaller ^ ! a "Set displaying buttons a. super clipRecta.! graya "Color a in gray tone ڱ filla translateBy: ) clippingBox clipRect rule erase mask gray! handleExceptionalModes "This code handles modes which Mac does not support directly | Source oldSource oldHalftone oldFont rule orThru "To handle orThru mode, we do two blits oldHalftonehalftone. rule erase. halftonenil. Chars. halftoneoldHalftone. rule under. Chars. rule orThru. ^ halftone notNil "If we are not in orThru mode, then we failed because we can't use halftones some modes when we are drawing Mac fonts. In this case, we make internal version font, use it oldFontfont. setFontfont internalize. CharsNonPrim. setFontoldFont. ^ BitBlt bitBltError1! Յa fontaFont "Initialize such that its clipping a font aFont. The destination form assumed be , Յa fontaFont څ! Յa fontaFont څa "Initialize such that its clipping a, font aFont, destination form a a. super clipRecta. setFontaFont. ڱa. rule orRule. foreColor black. backColor white. halftonenil. XY0. blankBitBltBitBlt ڱڱ nil halftonenil combinationRule0 Origin0@0 Origin0@0 a clipRecta! reframea "Change a. super clipRecta. blankBitBlt clipRecta! reversea "Reverse color a in blankBitBlt combinationRule reverse; masknil; Rect:(a translateBy: ); Bits; combinationRule over; maskbackColor! CopyToXx Yy "Copy area in a point in same whose coordinates are x y. Normally this used in scrolling Blitter ڱڱ ڱ halftonenil combinationRule over Origin Origin clipRect clipRect; Xx x; Yy y; Bits! setFontaFont "Change font aFont aFont glyphs. aFont . aFont MacFont : [ Ȅ0 "not used." ] : [ Ȅ ]. fontaFont! setForeColorfColor backColorbColor "Set foreground color fColor background color bColor foreColorfColor. backColorbColor. halftonenil. blankBitBlt maskbColor! ! ! Pen class methods ! " a Pen its initialized (using as its destination form)." ^ super initPen! a " a Pen its initialized ( using a as its destination form)." ^ super initPena! ! ! Pen methods ! activate "Cause Graph associated this be made ޗ showDrawing! black "Change pen color black mask black! bounce "If pen touches clipping after moving increment , its direction so that it looks like it bouncing off wall | X Y XclipXclipWidth. YclipYclipHeight. go. X < clipX XclipX. turn180directiondirection] X > X XX. turn180directiondirection]]. Y < clipY YclipY. turn360directiondirection] Y > Y YY. turn360directiondirection]]! centerTexta fontaFont "Write a whose center destination using aFont Scanner Յ clipRect fontaFont څ ڱ; setForeColorhalftone backColor white; a ԅ location - ((aFont Widtha) @ aFont // 2).! Niba "Change form ( nib) a a; Rect0@0 a )! closing "The top being closed top̄nil! colorMandalas diameterd "Draw a mandala s sides d as diameter | vertices radius center angle colors colors := #(blueColor cyanColor greenColor yellowColor redColor magentaColor). center location. vertices s. radiusd // 2. angle360 // s. direction270; up. 1 s doi goradius. vertices ԅi location. placecenter; turnangle down. 1 s1 doj Scheduler active foreColor: (Color performcolors ԅj \\ colors 1)). j1 s doi placevertices ԅj); gotovertices ԅi)]]. Scheduler active foreColorColor blackColor.! colorSpiral angled "Draw a spiral lines where d angle between two successive lines | colors incr j colors := #(blueColor cyanColor greenColor yellowColor redColor magentaColor). incr // colors 1. j1. Scheduler active foreColorColor blueColor. 1 doi i \\ incr0 Scheduler active foreColor: (Color performcolors ԅi // incr1)). go:i; turnd]! darkGray "Change pen color dark gray mask darkGray! defaultNib "Change nib which can be either or a | a ( KindOf) a @ ] a nil; black; Rect0@0 a)! direction " direction pen in degrees 0 359 ^ direction! direction "Set direction degrees direction \\ 360! doneDrawing "Set top nil top̄nil! down "Set pen down downState! dragon "Draw a dragon pattern where recursion factor = 0 go4] > 0 dragon1; turn90; dragon1] dragon: -1; turn: -90; dragon1]]! drawaRect "Outline border a | x y w h waRect . haRect . placexaRect x) @ (yaRect y); gotoxw1 @ y; gotoxw1 @ (yh1); gotox @ (yh1); gotox @ y! ellipse aspectaFraction "Draw ellipse pen as its center, as half , aFraction as ratio ellipse . The will be adjusted by global Aspect | w h w truncated. h := (aFraction abs * w) truncated. EllipsePrim0 " No filling " Xw Yh Xw Yh.! fillAta "Color all pixels that are connected a have same color as that a pattern contained in mask form Rect0@0 ڱ ). fillAtXa x Ya y. Recta )! fillAtXx Yy "Color all pixels that are connected point ( x@ y) have same color as that point pattern contained in mask form | err <89> errErrorCode. ErrorCode0. ^ BitBlt bitBltErrorerr! " clipping pen ^ clipRect! a "Set clipping a super clipRecta! go "Move pen distance pixels along direction. The y- axis will be adjusted by Aspect | x y roundX roundY xdirection integerCos * fractionX. y := (direction integerSin * * Aspect numerator quoAspect ) + fractionY. roundXx50 // 100 * 100. roundYy50 // 100 * 100. fractionXxroundX. fractionYyroundY. roundXroundX // 100. roundYroundY // 100. downState drawLoopXroundX YroundY. XXroundX. YYroundY.! gotoa "Move pen a downState drawLoopXa xX Ya yY placea! gray "Change pen color gray mask gray! grid "Draw a grid within clipping where pixels between lines | i end len iclipX. lenclipYclipHeight1. endclipXclipWidth. [i < end] ⌒ placei @ clipY. gotoi @ len. ii iclipY. lenclipXclipWidth1. endclipYclipHeight. [i < end] ⌒ placeclipX @ i. gotolen @ i. ii]! home "Center pen on destination form place center! initPena " your ڱa nil halftone black combinationRule over Origin0@0 Origin0@0 0@0 clipRect0@0 a ). defaultNib:1@1; north; home. top̄nil. downState! location " a , pen ^ X @ Y! mandalas diameterd "Draw a mandala s sides d as diameter | vertices radius center angle center location. vertices s. radiusd // 2. angle360 // s. direction270; up. 1 s doi goradius. vertices ԅi location. placecenter; turnangle down. 1 s1 doj j1 s doi placevertices ԅj); gotovertices ԅi)]].! EllipsePrimfillFlag x1 y1 x2 y2 "This a Macintosh specific version ellipse code. The ellipse drawn within : ((x1 @ y1) x2 @ y2)). If fillFlag non-zero, then area within ellipse filled in | err <99> errErrorCode. ErrorCode0. ^ BitBlt bitBltErrorerr! title "Open a which has as its only subpane a graph which will draw on. Set 's label title" | ɄGraph Labeledtitle Top Frame on. initPen form; defaultNib4. top̄ top.! north "Set direction pen 270 degrees direction270! placea " pen a fractionXfractionY0. (Xa x) Small fractionX := (X * 100) truncated \\ 100. XX truncated (Ya y) Small fractionY := (Y * 100) truncated \\ 100. YY truncated]! polygonl sidess "Draw a polygon s sides where each length l s timesRepeat gol; turn360 // s]! showDrawing "Cause Graph associated this be made ޗ top Nil : [ top show ].! solidEllipse aspectaFraction "Draw ellipse as half aFraction as aspect ratio pen as center, fill its insides color mask form | w h w truncated. h := (aFraction abs * w) truncated. EllipsePrim1 " Fill it " Xw Yh Xw Yh.! spiral angled "Draw a spiral lines where d angle between two successive lines 1 doi go:i; turnd]! turn "Change direction pen degrees. can be either positive or negative directiondirection \\ 360! up "Lift pen up downState! white "Change color pen white mask white! ! ! Animation class methods ! ! ! Animation methods ! add ؅a colora "Add forms in a color a | pens Nil pensOrdered 0@0. do: [:a maxa pens add: (Pen place0@0; direction0; ; ڱa; "" X1; "form " Y1; "shift count" ȅ x; y; maska Nil nil] :[ ( performa)]); combinationRule orThru; clipRect0@0 under ); up)! " currently moving all objects it overlaps | diff X Y aPen diffXcurPen X. diff <= 0 clipXX. clipWidthcurPen Ȥdiff] clipXcurPen X. clipWidthcurPen diff diffYcurPen Y. diff <= 0 clipYY. clipHeightcurPen diff] clipYcurPen Y. clipHeightcurPen diff hideBlt back; ڱunder; XclipX; XclipX; YclipY; YclipY; ȅclipWidth; clipHeight; Bits. 0. [(1) > pens ] ⓒ aPenpens ԅ. (((aPen X < (clipXclipWidth) clipX < (aPen XaPen )]) aPen Y < (clipYclipHeight)]) clipY < (aPen YaPen )]) aPen ԅaPen X. XaPen X. YaPen Y. halftoneaPen mask. Bits]]. XcurPen X. YcurPen Y. hideBlt under; ڱ; XclipXback x; YclipYback y; Bits.! getCurrentPena "Set pen pen a | pens . [ < 1] ⓒ (curPenpens ԅ) ڱ = a : [^ 1 : ' not found'! Յa "Initialize speed4. shiftRate1. (a KindOf) undera] under ׭a back under ; ҅under . back back boundingBox ׅunder 0@0 rule over. hideBltBitBlt combinationRule over; clipRect clipRect. ڱunder. Ȅa . a . rule orThru. halftonenil! move bya "Move pen by distance as defined by a | remain count shiftCount halftonecurPen mask. countcurPen . remain. curPen X. shiftCountcurPen Y. [remain > 0] ⌒ shiftCount < 2 shiftCountshiftRate. curPen X: ( \\ count1)] shiftCountshiftCount1 curPen YshiftCount. XcurPen X. YcurPen Y. curPen performa speed. . remainremainspeed]! setBackground "Set background form back ׭! shiftRate "Specify how many times picture will be copied before shifting one shiftRate! speed "Change distance between consecutive copies speed! tella bounce "Tell pen a bounce by a distance getCurrentPena. move bybounce:! tella direction "Tell pen a its direction degrees getCurrentPena. curPen direction! tella go "Tell pen a go a distance getCurrentPena. move bygo:! tell gotoa "Tell go a | w h count shiftCount moveCount factor incX incY getCurrentPen. halftonecurPen mask. countcurPen . wa xcurPen X. ha ycurPen Y. w >= 0 incX1] incX := -1. w0w h >= 0 incY1] incY := -1. h0h curPen X. shiftCountcurPen Y. moveCount0. XcurPen X. YcurPen Y. w >= h factorw // 2. [moveCount > w] ⓒ curPen XcurPen XincX. factorfactorh. factor < 0 curPen YcurPen YincY. factorfactorw moveCountmoveCount1. (moveCount \\ speed = 0) shiftCount < 2 shiftCountshiftRate. curPen X: ( \\ count1)] shiftCountshiftCount1 curPen YshiftCount. ]]] factorh // 2. [moveCount > h] ⓒ curPen YcurPen YincY. factorfactorw. factor < 0 curPen XcurPen XincX. factorfactorh moveCountmoveCount1. (moveCount \\ speed = 0) shiftCount < 2 shiftCountshiftRate. curPen X: ( \\ count1)] shiftCountshiftCount1 curPen YshiftCount. ]]]. moveCount1 \\ speed = 0 curPen placea. ]! tella placea "Tell pen a be placed a getCurrentPena. XcurPen X. YcurPen Y. curPen placea. ! tella turn "Tell pen a turn by degrees getCurrentPena. curPen turn! ! ! Commander class methods ! " aCommander initialized pens ^ New Յ! ! ! Commander methods ! clipRectAlla "Set clipping every pen a pens doaPen | aPen clipRecta]! defaultNiba "Forward a pens pens doaPen | aPen defaultNiba]! direction "Set direction every pen degrees pens doaPen | aPen direction]! down "Set all pens down pens doaPen | aPen down]! ellipse aspectaFraction "Make each pen draw ellipse pens doaPen aPen ellipse aspectaFraction]! fanOut "Change direction each pen by increment 360 / pens 2 pens doي (pens ԅ) turn: (1) * (360 / pens ) ]! go "Move all pens a distance in their direction | 1. [ > pens ] ⓒ (pens ԅ) go. 1]! gotoa "Move pen a then move remaining pens by same distance direction as move | delta deltaapens location. pens doaPen aPen gotoaPen locationdelta]! Յ "Initialize pens pens pens . 1 doي pens ԅ Pen ]! initPena "Initialize form all pens super initPena. pens doaPen | aPen initPena ]! lineUp end "Place all pens on equi- distant points on line defined by end 1 pens doي (pens ԅ) place: + (end * (1) // (pens 1))]! location " a indicating pen ^ pens location! placea "Set pen a modify remaining pens by amount in pen. No drawing takes place | delta deltaapens location. pens doaPen aPen placeaPen locationdelta]! solidEllipse aspectaFraction "Make each pen draw ellipse pens doaPen aPen solidEllipse aspectaFraction]! turn "Change direction all pens by degrees pens doaPen | aPen turn]! up "Lift all pens pens doaPen | aPen up]! ! ! Boolean class methods ! "Disallow instantiation booleans because there only one one ^ invalidMessage! "Disallow instantiation booleans because there only one one ^ invalidMessage! ! ! Boolean methods ! deepCopy " a shallow copies each . Because there only one one , ^ ! Ona "Append ASCII a a PutAll: ( : [''] :[''])! shallowCopy " a which shares . Because there only one one , ^ ! storeOna " . Append sequence a which can be reconstructed Ona! ! ! False class methods ! ! ! False methods ! & aBoolean " both aBoolean are , ^ ! a "If , evaluating a ( no arguments), ^ ! asParameter " Macintosh Toolbox that converts . In this case, 0 ^ 0! eqvaBoolean " equivalent aBoolean, ^ aBoolean not! a "If , evaluating a ( no arguments), nil ^ a ! è "If , evaluating è, evaluating . Both blocks are evaluated no arguments ^ ! a "If , evaluating a ( no arguments), nil ^ nil! è "If , evaluating è, evaluating . Both block are evaluated no arguments ^ ! not " , ^ ! ora "If , evaluating a ( no arguments), × ^ a ! xoraBoolean " not equivalent aBoolean, ^ aBoolean! | aBoolean " either or aBoolean are , ^ aBoolean! ! ! True class methods ! ! ! True methods ! & aBoolean " both aBoolean are , ^ aBoolean! a "If , evaluating a ( no arguments), ^ a ! asParameter " Macintosh Toolbox that converts . In this case, -1 ^ -1! eqvaBoolean " equivalent aBoolean, ^ aBoolean! a "If , evaluating a ( no arguments), nil ^ nil! è "If , evaluating è, evaluating . Both blocks are evaluated no arguments ^ è ! a "If , evaluating a ( no arguments), nil ^ a ! è "If , evaluating è, evaluating . Both block are evaluated no arguments ^ è ! not " , ^ ! ora "If , evaluating a, × ^ ! xoraBoolean " not equivalent aBoolean, ^ aBoolean not! | aBoolean " either or aBoolean are , ^ ! ! ! ClassBrowser class methods ! ! ! ClassBrowser methods ! accepta ׅa "Accept a as updated compile it. Notify a compiler detects errors | ݄ compilea notifyinga. Nil : [^ ] logSourcea Selector key in. keyMethod Method key. restoreSelected: Method ^ ]! OrInstancea "Change state browser based on a a == # : [ ˄browsed ] : [ ˄browsed ]. Methodnil. ; text! dictionaries " dictionary types ( )." ^ #( )! dictionarya "Change dictionary type a == # ˄browsed ] :[˄browsed Methodnil. ; text! OutMethod "Write in chunk format a whose built ؗ | a execute . a := Disk noOldܙMethod Without: $:), '.mth'. a Nil : [ ^ ]. a lineDelimiter lineDelimiter. browsed OutOna. a ChunkPut . (Reader 㳅) OutMethod Ona. a close. normal ! implementors "Pop- up a implementors Method Method Nil implementorsOfMethod]! messages "Open a modalless dialog on all messages sent by — | Method Nil : [^ nil := ( compiledMethodAtMethod) messages asSorted. Empty : [ ^ Dialog message: 'None' ]. ListChooser openOn : 'Messages in ', Method 100 @ 100 450 @ 230) buttons: #(Senders Implementers Cancel) actions: ( sel | sel Nil : [ ] : [ sendersOfsel. ]] sel | sel Nil : [ ] : [ implementorsOfsel. ]] sel | ])! Method " text a template in text ; selectornil; text! openOna "Create a browser on a. Define type, behavior relative each schedule | aTop twoLineHeight (a KindOf) : [^ nil browseda. aTop̄Top labela , ' | Browser'; minimum300 @ 150; yourself. twoLineHeightFont menuFont * 216. aTop addSubpane: (VerticalButton model; OrInstance:; buttons: #(Instance ); framing: [:box| box : box // 4 @ twoLineHeight]; push1). ˄browsed. aTop addSubpane: ( := (List model; ; selector:; menuselectorMenu; framing: [:box| box + (0 @ twoLineHeight) : box // 4 @ (box twoLineHeight)])). aTop addSubpane: ( := (Text model; text; accept::; framing: [:box| box + ((box // 4) @ 0) box ])). aTop open schedule! removeSelector "Remove — Method Nil : [^ nil removeSelectorMethod. logEvaluate: , 'removeSelector: #', Method. Methodnil. restore; text! selectora " selector a in text Methoda. text! selectorMenu " selector menu ^ (Menu labels: 'Senders\Implementors\Messages\ Out Method\New Method\Remove Method' breakLinesAtBackSlashes lines: #(3) : #(senders implementors messages OutMethod Method removeSelector)) title: 'Methods'! " a sorted list dictionary type ( or )." ^ asSorted! senders "Pop- up a senders — Method Nil sendersOfMethod]! template " template methods ^ 'messagePattern "comment" | temporaries statements'! text " text — Method Nil : [ ^ template ] : [ ^ CodeAt: Method ].! ! ! ClassHierarchyBrowser class methods ! ! ! ClassHierarchyBrowser methods ! accepta ׅa "Accept a as updated or specification compile it. Notify a compiler detects errors | a SelectedLast ^ accepta ׅa aSelectedLast : [ ] : [ ]. ݄ compilea notifyinga ina. Nil ^ ] logSourcea Selector key ina. keyMethod Method key. restoreSelected: Method ^ ]! accepta ׅa "Accept a as updated specification compile it. Notify a compiler detects errors | ݄Compiler evaluatea innil nil notifyinga Fail: [^ logEvaluatea. ^ ( KindOf)! addClassesa ԅ "Add a classes browsedClasses, each preceded by spaces. indicates level in hierarchy (a asSorted sort) do٠ symbol trimBlanks Empty browsedClasses add: (( ) AllPut: $ ) , symbol. (hiddenClasses includes) browsedClasses add: browsedClasses removeLast, '' "'...'"] addClasses subclasses ԅ1]]]! addSub "Add a subclass . If a , prompt user a add it as a subclass | subclassType Nil : [ ^ ]. := Dialog Subclass , ' subclass:' 兙 Variable pointers Pointers. ( ԅ1) : [ ^ ]. ԅ2. Empty : [ ^ ]. ( ԅ1) UpperCase ԅ1 ܣ ԅ1) asUpperCase as. ( includesKey) : [ ^ , ' already exists' ]. ( ԅ4) " it pointers?" ( ԅ3) " it ?" : [ (( Subclass VariableNames: '' VariableNames: '' poolDictionaries: '') KindOf) : [^ ] ] : [ (( subclass VariableNames: '' VariableNames: '' poolDictionaries: '') KindOf) : [^ ] ] ] : [ (( ByteSubclass VariableNames: '' poolDictionaries: '') KindOf) : [^ ] := (( : ( ԅ as) allSuperclasses ) AllPut: $ ), . update! browse "Open a Browser on Nil edit]! a "Change state browser so that messages are SelectedLastSelectedLast. instances; ; text! classes " ^ #()! HighlightaBoolean "Highlight classes menu appropriately | m s m menuBar menuAt: 'Classes'. s := #(update hideShow browse Out addSub remove). aBoolean : [ s dosel | m enablesel ] ] : [ s dosel | m disablesel ] ]! OrInstancea "Change state browser based on a | changingText changingTextSelectedLast or: [ TextModified ]. SelectedLast. (SelectedLasta == #Instance) : [ classes ] : [ instances ]. . changingText : [ text ].! collapsedLabel " label use when collapsed ^ 'CHB'! compilea notifyinga ina "Accept a as updated compile it. Notify a compiler detects errors | old old. execute . a compilea notifyinga. old . ^ ! expandedLabel " label use when not collapsed ^ ' Hierarchy Browser'! Out "Write in chunk format a named reduced 8 characters, extension 'cls'." | a cr Nil : [^ write . cr lineDelimiter. aDisk noOld: ( extension: 'cls'). a Nil : [ ^ ]. a lineDelimiter lineDelimiter. OutOna. a ChunkPut . (Reader 㳅 ) OutOna. (Reader 㳅) OutOna. a close. normal ! OutMethod "Write in chunk format a whose built ؗ | a ( Nil orSelectedLast not]) : [^ execute . a := Disk noOldܙMethod Without: $:), '.mth'. a Nil : [ ^ ]. a lineDelimiter lineDelimiter. OutOna. a ChunkPut . (Reader : (SelectedLast ] ])) OutMethod Ona. a close. normal ! hideShow "Change hide/show status | m Nil : [ ^ nil ]. execute . m menuBar menuAt: 'Classes'. (hiddenClasses includes) m labelhideShow as: 'Hide Subclasses'; enablehideShow. hiddenClasses remove] subclasses Empty m labelhideShow as: 'Show Subclasses'; enablehideShow. hiddenClasses add]]. Methodnil. SelectedLast. updateoriginalClasses; hierarchy restoreSelected. normal .! hierarchy " indented list classes, Ordered strings ^ browsedClasses! hierarchya " in selector list | m hidden a. (hidden last == $) 1 1 ԅ trimBlanks as AbsentUndefined "If he clicked in same place there something see, then hideShow ( : [ (hidden or: [ subclasses notEmpty ]) : [ Terminal underDoubleClickDelay ] ]) : [ ^ hideShow ]. "Set up appropriate menu entry m menuBar menuAt: 'Classes'. Nil Highlight. ( menuBar menuAt: 'Methods') enable. menuBar . a last == $ : [ m labelhideShow as: 'Show Subclasses'; enablehideShow. ] subclasses notEmpty m labelhideShow as: 'Hide Subclasses'; enablehideShow. ] m labelhideShow as: 'Hide Show'; disablehideShow. ]]. Highlight. SelectedLast | ( ~= ) . SelectedLast. Methodnil. ; text]! implementors "Pop- up a implementors — Method Nil implementorsOfMethod]! a "Change state browser so that messages are SelectedLast. SelectedLast. classes; ; text! instances " ^ #()! menu " hierarchy menu ^ (Menu labels: ('Update\Browse \Hide Show\Show Text/1\', ' Out \New Subclass\Remove ') breakLinesAtBackSlashes lines: #(4) : #(update browse hideShow toggle Out addSub remove) ) title: 'Classes'! messages "Open a modalless dialog on all messages sent by — | SelectedLast not | Method Nil : [^ nil := ((SelectedLast ] ]) compiledMethodAtMethod) messages asSorted. Empty : [ ^ Dialog message: 'None' ]. ListChooser openOn : 'Messages in ', Method 100 @ 100 450 @ 230) buttons: #(Senders Implementers Cancel) actions: ( sel | sel Nil : [ ] : [ sendersOfsel. ]] sel | sel Nil : [ ] : [ implementorsOfsel. ]] sel | ])! HighlightaBoolean "Highlight methods menu appropriately | m s m menuBar menuAt: 'Methods'. s := #(senders implementors messages OutMethod removeSelector). aBoolean : [ s dosel | m enablesel ] ] : [ s dosel | m disablesel ] ]! Text " text — | m m := (SelectedLast : [ ] : [ ]) compiledMethodAtMethod. ^ m Field CodeAtm selector! Method " text a template in text Nil : 'no ']. ; selectornil; text! openOna "Create a hierarchy browser giving access classes in a their subclasses. Define type, behavior relative each schedule | aTop listLineHeight ratio a execute . hiddenClassesSet 64. (a includes) a do٠ subclasses do: [:each each subclasses Empty hiddenClasses addeach]]]] a do٠ subclasses Empty hiddenClasses add]]]. ratio2 / 5. updatea. listLineHeightFont menuFont 12. SelectedLast. SelectedLast. aTop̄Top model; label expandedLabel; minimum300 @ 200; yourself. aTop. aTop addSubpane: (a := (List model; hierarchy; hierarchy:; menumenu; framingRatio: (0 @ 0 1/2 @ ratio))). aTop addSubpane: (a := (List model; ; selector:; menuselectorMenu; framing: [:box| box + (box // 2 @ 0) : (box 1 // 2) @ ((box * ratio) truncated - listLineHeight)])). aTop addSubpane: (Button model; OrInstance:; buttons: #(Instance ); framingbox box + (box // 2 @ ((box * ratio) truncated - listLineHeight)) box 1 // 2 @ listLineHeight ]; push1). aTop addSubpane: (a := (Text model; text; accept::; framingRatio0 @ (2/5) 1 @ 1))). aTop open. Highlight. ( menuBar menuAt: 'Methods') disable. aTop schedule! remove "Remove system | Nil : [ ^ ]. execute . . nil. (Dialog noOrYes: 'Remove "', , '"?') : [ normal . . ^ nil removeSystem. update.! removeSelector "Remove — | a SelectedLast : [^ nil Method Nil : [^ nil (Dialog noOrYes: 'Remove "', Method, '"?') : [ ^ nil ]. SelectedLast removeSelectorMethod. a ] removeSelectorMethod. a logEvaluate: a, ' removeSelector: #', Method. SelectedLast. Methodnil. restore; text! selectora " in text SelectedLast Highlight Methoda. SelectedLast. text! selectorMenu " selector menu ^ (Menu labels: 'Senders\Implementors\Messages\ Out Method\New Method\Remove Method' breakLinesAtBackSlashes lines: #(3) : #(senders implementors messages OutMethod Method removeSelector)) title: 'Methods'! " a sorted list dictionary type ( or )." Nil : [^ SelectedLast ^ asSorted] ^ asSorted]! senders "Pop- up a senders — Method Nil sendersOfMethod]! template " template methods ^ 'messagePattern "comment" | temporaries statements'! text " text or definition , or comment | a cr Nil : [^ aSelectedLast ] SelectedLast Method Nil : [^ template] : [^ Text]]. Write on܈ 100). OutOn. ^ ! toggle " either all panes in browser, or just text | f f2 p collapsed : [ ^ ]. f . f20 @ (f y - (f * 5 // 3)) f 1. subpanes doeach (each KindOfText) each = (1@1) : [ ^ reframe ]. each reframef2. peach ] each reframe0 @ 0 0 @ 0) ] p dependents dodep | dep reframef2 ]. invalidatePortRect. ! update "Recompute browsed classes them execute . Methodnil. SelectedLast. updateoriginalClasses. ( KindOf) hierarchy restoreSelected: . := ԅ trimBlanks as. ( menuBar menuAt: 'Classes') labelhideShow as: 'Hide Show'; disablehideShow. ] hierarchy. nil. ( menuBar menuAt: 'Classes') labelhideShow as: 'Hide Show'. Highlight. ( menuBar menuAt: 'Methods') disable. menuBar . ; text! updatea "Recompute list browsed classes a originalClassesa. browsedClassesOrdered 120. addClassesa ԅ0.! ! ! ClassReader class methods ! 㳅a " a ^ seta.! ! ! ClassReader methods ! Ina "Read chunks a until empty chunk (a single '!!') found. Compile each chunk as a described by . Log code log | a Sources ԅ2. setToEnd. HeaderOn. [(aa Chunk) Empty] :[ ݄ compilea. notNil a]]. ChunkPut: ''; flush! Out Ona " out named described by a, in chunk format ԅ Absent : 'Method missing']. a cr. HeaderOna. a cr; ChunkPutܠ CodeAt); ChunkPut: ''; cr! OutOna " out all methods described by a, in chunk format a cr. HeaderOna. asSorted doselector a cr; ChunkPutܠ CodeAtselector)]. a ChunkPut: ''; cr! HeaderOna "Write a header a which identifies described by . The header precedes code methods a cr; Put: $!!; PutAll ; space; PutAll: 'methods !!'! seta "Set described by a a! ! ! Collection class methods ! " a only one , ^ add; yourself! second " a two , second ^ add; addsecond; yourself! second third " a three , , second, third ^ add; addsecond; addthird; yourself! second third fourth " a four , , second, third, fourth ^ add; addsecond; addthird; addfourth; yourself! ! ! Collection methods ! add " . Add ^ implementedBySubclass! addAlla " a. Add each a a doٻ | add ^ a! as " all | . 1. doٻ ԅ . 1 ^ ! asBag " a Bag ^ (Bag ) addAll; yourself! asOrdered " Ordered ^ (Ordered ) addAll; yourself! asSet " a Set ^ (Set ) addAll; yourself! asSorted " a Sorted sorted in ascending order ^ (Sorted ) addAll; yourself! asSorteda " a Sorted sorted according a ^ (Sorted ) sorta; addAll; yourself! collecta "For each in , evaluate a that as argument. a results as its a evaluations | species . doٻ adda )]. ^ ! deepCopy " a shallow copies each | species . do: [: add ^ ! detecta " that causes a evaluate ( that as argument). If no such found, report ^ detecta None Absent]! detecta Noneexception " that causes a evaluate ( that as argument). If no such found, evaluate exception ( no arguments)." doٻ (a ) : [^ ]]. ^ exception ! doa "For each in , evaluate a that as argument. This should be implemented in ^ implementedBySubclass! Absent "Report effect that desired was not found in ^ : ' not in '! NotIndexable "Report effect that not indexable ^ , 's do not respond indexing messages'! includes " contains equal , doٻ = : [^ ]]. ^ ! injectinitialValue intoaBinary "For each in , evaluate aBinary that as argument. Starting initialValue, block also provided its own previous evaluation. this end block evaluations | initialValue. doٻ aBinary ^ ! Empty " contains no , ^ = 0! notEmpty " contains one or more , ^ > 0! occurrencesOf " contained in that are equal ^ inject0 intooccurrences : occurrences + ( = 1] 0])]! Limit " maximum characters output screen per each menu show it ^ 2000! Ona "Append ASCII a | limit (RecursiveSet includes) : [^ RecursionOna RecursiveSet add. limita Limit. Ona. a Put: $(. doٻ (a > limit) '...etc...)' Ona. RecursiveSet remove Absent: []. ^ Ona. a space a Put: $). RecursiveSet remove Absent: []! rejecta "For each in , evaluate a that as argument. a those which a evaluates ^ ٻ (a ) not]! remove " . Remove equal . If such not found, report ^ remove Absent Absent]! remove Absenta " . Remove equal . If such not found, evaluate a ( no arguments)." ^ implementedBySubclass! removeAlla " a. Remove all contained in a a doٻ | remove ^ a! a "For each in , evaluate a that as argument. a those which a evaluates × | species . doٻ (a ) add]]. ^ ! shallowCopy " a which shares ʗ ^ ( species ) addAll; yourself! storeOna "Append ASCII a which can be reinstantiated (RecursiveSet includes) RecursiveSetSet . ^ : 'recursive storeOnnot allowed']. RecursiveSet add. a PutAll: '(('; PutAll ; PutAll: ' )'. ( inject intoTime : Time a Put: $;]. a PutAll: 'add: '. storeOna. ]) a PutAll: ';yourself']. a Put: $). RecursiveSet remove Absent: []! ! ! Bag class methods ! " empty Bag ^ New ! ! ! Bag methods ! add " . Add ԅ ܃ occurrencesOf) + 1. ^ ! add Occurrences " . Add times ԅ ԅ Absent0]) + . ^ ! ԅ " . Report since bags are not indexable NotIndexable! ԅ "Replace . Report , since bags are not indexable NotIndexable! doa "For each in , evaluate a that as argument | associationsDoassociation association . [ > 0] ⌒ a association key. 1]]! includes " contains equal , ԅ Absent: [^ ^ ! " be empty ʄ ! occurrencesOf " equal ^ ԅ Absent: [^ 0]! remove Absenta " . Remove one occurrence . If not , evaluate a ( no arguments)." | occurrences (occurrences ԅ Absent: [^ a ]) = 1 removeKey] ԅ occurrences1 ^ ! " in | 0. associationsDoٻ ^ ! ! ! IndexedCollection class methods ! ! ! IndexedCollection methods ! , a " a followed by a | 1 2 1 . 21a . species 2. 1 1 startingAt1. 11 2 a startingAt1. ^ ! = a " contained by are equal contained by argument a | a : [^ ( a ) : [^ . ~= a : [^ [ <= 0] ⓒ ( ԅ) = (a ԅ) : [^ 1 ^ ! accessEmpty "Report effect that accessed was empty ^ : ' empty'! asBitMap " converted a bitmap | Bitmap . 1 doi ԅi ܃ ԅi) ^ ! Alla " after replacing those , indexed by indices contained in a, a doي ԅ ]! AllPut " after each has been replaced 1 ! check "Check that argument a valid . If it found be invalid, report ( KindOf) ^ : 'Indexed collections are indexed by integers']. ( between1 ) : [^ InBounds]! stop " a indexed through stop | stop1. <= 0 : [ ^ species ]. ^ ( species ) 1 startingAt! Replace stop a " a a positions through stop replaced a ^ ( 1 1) , a , ( stop1 )! With " a added it as ^ , ( species )! Without " a excluding every that equals , any | Of Absent: [^ ^ ( 1 1), (( 1 ) Without)! doa " . For each in , evaluate a that as argument | 1. . [ > ] ⓒ a ܃ ԅ). 1]! InBounds "Report effect that invalid ^ : ': ', , ' outside bounds'! findFirsta " that causes a evaluate ( that as argument). If no such found, report | . 1. [ <= ] ⌒ (a ܃ ԅ) ) : [^ 1 ^ Absent! findLasta " last that causes a evaluate ( that as argument). If no such found, report | . [ > 0 ] ⌒ (a ܃ ԅ)) : [ ^ ]. 1 ^ Absent! " . Report has no ʗ Empty : [^ accessEmpty ^ ԅ1! grow " expanded in accomodate more ʗ | . species grow. 1 . become! grow " that expand by ^ // 310! hash " integer hash ^ ! includes " contains equal , | 1. [(1) > 0] ⌒ = ( ԅ) : [^ ]]. ^ ! Of " equal in . If no such found, zero ^ Of Absent: [^ 0]! Of Absenta " equal in . If no such found, evaluate a (without any arguments)." | . 1. [ <= ] ⌒ ( ԅ) = : [^ 1 ^ a ! last " last . Report has no ʗ Empty : [ ^ accessEmpty ^ ԅ ! stop a " . Replace positions through stop, a. The being replaced must be same as in a, report stop1 = a ^ : 'replacement has wrong ']. stop a startingAt1! stop a startingAtrepStart "Replace positions through stop consecutive a beginning repStart. | 1 2 (a repStart < ]) : [ "do backward move same " 2repStartstop. 1stop. [ <= 1] ⌒ ԅ1 a ԅ2). 111. 221 ^ "do forward move" 2repStart. 1. [1 <= stop] ⌒ ԅ1 a ԅ2). 111. 221]! stop "Replace each positions through stop . | . [ <= stop] ⌒ ԅ . 1 ^ ! reversed " a in reverse order ^ (Read on) reverseContents! reverseDoa "For each in , starting last , evaluate a that as argument | . [ > 0] ⌒ a ܃ ԅ). 1]! shallowCopy " a which shares ʗ ^ 1 ! " ^ implementedBySubclass! a doa "For each pair ( second a), evaluate a those as arguments. The a must contain same , report | a1 a2 = a : [^ : 'Collections are differing length']. a1Read on. a2Read ona. [a1 End] ⓒ a a1 a2 ]! ! ! FixedSizeCollection class methods ! " a only one , | 1. ԅ1 . ^ ! second " a two , second | 2. ԅ1 . ԅ2 second. ^ ! second third " a three , , second, third | 3. ԅ1 . ԅ2 second. ԅ3 third. ^ ! second third fourth " a four , , second, third, fourth | 4. ԅ1 . ԅ2 second. ԅ3 third. ԅ4 fourth. ^ ! ! ! FixedSizeCollection methods ! add "Add . This reports since fixed collections cannot grow ^ invalidMessage! collecta "For each in , evaluate a that as argument. a results a evaluations as its ʗ | . Ordered . 1. [ > ] ⓒ adda ܃ ԅ)). 1 ^ ( species ) 1 ! Replace stop a " a entries indexed through stop being replaced by a | 1 2 1a . 2 1 - (stop1). species 2. 1 1 startingAt1. 11 a. ^ 1 2 startingAtstop1! deepCopy " a shallow copies each ^ shallowCopy! remove Absenta "Remove . This reports since cannot be removed fixed collections, they can only be Η ^ invalidMessage! a "For each in , evaluate a that as argument. a those which a evaluates × | . Ordered . 1. [ > ] ⓒ ԅ. (a ) add 1 . ^ ( species ) 1 ! shallowCopy " a which shares ʗ | . 1 startingAt1. ^ ! " indexed <62>! storeOna "Append ASCII a which can be reinstantiated | Time . a PutAll: '(('; PutAll ; PutAll: ' : '. Ona. a Put: $). 1. Time. [ <= ] ⌒ Time a Put: $;]. Time. a PutAll: ': '. Ona. a PutAll: ' : '. ( ԅ) storeOna. 1 Time a PutAll: ';yourself']. a Put: $)! ! ! Array class methods ! ! ! Array methods ! Ona "Append ASCII a | limit (RecursiveSet includes) : [^ RecursionOna RecursiveSet add. limita Limit. a Put: $(. 1 1 doٻ (a > limit) '...etc...)' Ona. RecursiveSet remove Absent: []. ^ ( ԅ) Ona. a space Empty last Ona a Put: $). RecursiveSet remove Absent: []! setTBF "Cause receive all objects be finalized <94> ^ ! storeOna "Append ASCII a which can be reinstantiated | Time (RecursiveSet includes) RecursiveSetSet . ^ : 'recursive storeOnnot allowed']. RecursiveSet add. . a PutAll: '(('; PutAll ; PutAll: ' : '. Ona. a Put: $). 1. Time. [ <= ] ⌒ Time a Put: $;]. Time. a PutAll: ': '. Ona. a PutAll: ' : '. ( ԅ) storeOna. 1 Time a PutAll: ';yourself']. a Put: $). RecursiveSet remove Absent: []! ! ! CompiledMethod class methods ! compressa " a which compressed form a. Compression replaces frequently occurring sequences characters a single > 127. Characters > 127 are preceded by escape 128 | a lf cr Piece a a˄ Compression. lfPiece := ( Lf). cr := ( Cr). aRead ona. Write on܈ a ). [(Piece = lf orPiece = cr]) Puta countBlanks129) as (Piecea Piece) == nil] ⓒ (a includesKeyPiece) Puta ԅPiece) as] PutAllPiece]]. ^ ! decompressa " a which decompressed form a. Decompression replaces values > 128 that represents | lf a a lf. aRead ona. Write on܈ 200). [a End] ⓒ aa . (a asciiValue) > 128 lf : [ 129 : $ . lf] : [ PutAll: (Decompression ԅ128)]] = 128 aa lf := (a = Cr | (a = Lf)). lf : [ cr] Puta ]]. ^ ! UserPrimitives "Force any user methods in system be in 'unloaded' state. This will cause them be automatically loaded time they are run allInstances dom m UserPrimitive m unloadUserPrimitive ] ]! ! ! CompiledMethod methods ! = aCompiledMethod " only aCompiledMethod are same , ^ aCompiledMethod! argumentCount " arguments needs when invoked ^ byteCode ԅ2! byteCode " ' s array byte codes ^ byteCode! byteCodeͅb "Set 's byteCode byteCodë́b.! Field " in which was compiled ^ ! Fieldb "Set b.! has " contains any unoptimized blocks ^ (byteCode ԅ4) ~= 0! hasSource " compiled has , ^ between1 Sources ! includes impliedCode " in , <39>! b "Set b.! " ^ byteCode ԅ3! Ona "Append ASCII a. For CompiledMethods this selector ^ a PutAll: , '>>', selector ! referencesa "Return given symbol in methods literal Pool" dolit (lit ) : [ (a equalslit key) : [ ^ ]] : [ a = lit : [ ^ ]] ^ ! selector " selector ^ selector! selectoraSelector "Set 's selector selectoraSelector! " a code | a hasSource nil aSources ԅ . a . ^a Chunk trimBlanks! " uncompressed code | old old. read . . nil : [^ nil = 2 decompress old . ^ ! a "Write a log record it as code | old a old. write . aSources ԅ2. a setToEnd. 2 a . a ChunkPuta trimBlanks. old ! tempCount " temporary used by ^ byteCode ԅ1! unloadUserPrimitive "Mark as unloaded user UserPrimitive : [ ԅ2 0 ] : [ : 'not a user ' ]! ! ! Bitmap class methods ! ! ! Bitmap methods ! AllPutaByte "Replace bytes aByte. aByte 1 aByte as. ^ aByte! stop a startingAtrepStart "Replace bytes positions through stop consecutive bytes a beginning repStart. <105> super stop a startingAtrepStart! stop aByte "Replace bytes positions through stop aByte. aByte <106> ^ super stop aByte asciiValue! ! ! ByteArray class methods ! ! ! ByteArray methods ! stop a startingAtrepStart "Replace positions through stop consecutive a beginning repStart. <105> super stop a startingAtrepStart! ! ! Interval class methods ! ׅbeginning end " Interval beginning end incrementing by one ^ New initBeginbeginning endend incr1! ׅbeginning end byincrement " Interval beginning end incrementing by increment ^ New initBeginbeginning endend incrincrement! ! ! Interval methods ! ԅ " in interval | > 0 := beginning : (beginning + (increment * (1))). (increment < 0 betweenend beginning]) : [ ^ ]. (increment > 0 betweenbeginning end]) : [ ^ ] ^ InBounds! ԅ a "Replace in indexed by argument a. This message not valid intervals since interval collections are implicitely defined ( are computed)." ^ invalidMessage! increment " increment Interval ^ increment! initBeginbeginning endend incrincrement " after initializing beginning, end increment beginningbeginning. endend. incrementincrement. increment = 0 : [^ : 'interval increment 0']! " ^ 0 maxend beginning // increment1! species " as species Interval ^ ! ! ! String class methods ! MacFType "Convert given integer into a four | 4. ԅ1 ܦ bitShift: -24) as. ԅ2 : (( bitShift: -16) bitAnd16rFF) as. ԅ3 : (( bitShift: -8) bitAnd16rFF) as. ԅ4 ܦ bitAnd16rFF) as. ^ ! ! ! String methods ! < a " before a, . The comparison not case sensitive ^ (a "as" <= ) not! <= a " before or equal a, . The comparison not case sensitive <56> ^ Failed! = a " equal a, . The comparison case sensitive <55> ^ Failed! > a " after a, . The comparison not case sensitive ^ ( <= a) not! >= a " after or equal a, . The comparison not case sensitive ^ a <= ! asOfSubstrings " array substrings . The divided into substrings occurrences one or more space characters | a Ordered . aRead on. [a End] ⓒ [a End : [^ as a peek > Space] ⓒa a 1. [a End ora peek <= Space]] ⓒa add: ( a )]. ^ as! asAsciiZ " a all characters followed by ASCII zero ^ , ( 0 as)! asDate " a Date representing date described by . The must contain day then month then year separated by blanks ^ Date ׈! as " integer conversion ; expected be a sequence digits optional leading minus sign | char 0. = 0 : [ ^ ]. ( ԅ1) = $- ^ ( 2 ) as negated 1 doي (char ԅ) Digit : [^ * 10char digitValue ^ ! asLowerCase " a alphabetic characters in lower case | a . . 1. [ <= ] ⌒ (a ԅ) UpperCase a := (a asciiValueUpperToLower) as ԅ a. 1 ^ ! asMacFType " converted a Macintosh FType (represented by a 32 bit integer)." = 4 : [ : ' must be 4' ]. ^ ( ԅ1) asciiValue * 256 + ( ԅ2) asciiValue * 256 + ( ԅ3) asciiValue * 256 + ( ԅ4) asciiValue! asParameter " Macintosh Toolbox that converts . In this case, Str255 as its ^ (Str255 Record) storage! asStr255 " Str255 as its ^ Str255 Record! as " a ReadWrite on ^ ReadWrite on! as " representing ( itself)." ^ ! as " a symbol whose characters are same as ^ intern! asUpperCase " a alphabetic characters in upper case | a . . 1. [ <= ] ⌒ (a ԅ) LowerCase a := (a asciiValueUpperToLower) as ԅ a. 1 ^ ! ԅ " in <63> check. ^ Failed! ԅ a " a. At in a <64> check. checka. ^ Failed! At " in <63> check. ^ Failed! At a " a. At in a <64> check. checka. ^ Failed! breakLinesAtBackSlashes " where each occurrence \ has been replaced a line delimiter 1 doي ( ԅ) = $\ ԅ LineDelimiter ] ]! checka "Report argument a not (a KindOf) ^ : 'can''t hold ' , a ,'s']! ReplaceAlla "Replace all occurences a | pattern range a = : [ ^ ]. patternPattern a. ݄. range1@1. [ (rangepattern match range x) Nil] ⓒ ݄ Replacerange x range y ^ ! Ata "Output directly onto screen a Ata fontSysFont! Ata fontaFont "Output onto screen in white a font aFont Ata fontaFont څ! Ata fontaFont څa "Output onto screen in white a font aFont Scanner Յa boundingBox fontaFont څa; setForeColor white backColor black; ԅa! edit "Open a workspace as ӗ | aTop aTop̄Top . aTop label: 'Workspace'; modelaTop ; menuworkSpaceMenu; minimum150@80; rightIcons: #(resize collapse zoom); addSubpane: (Text model; framingbox | box]). aTop save: ''. aTop open schedule! equalsa " equal argument a, . Note that comparison case sensitive, but not sensitive, (ie. any two Byte objects same values will compare as equal)." <87> ^ Failed! hash " integer hash | Hash <107> Hash0. 1 ܃ min16) doi Hash := (Hash bitShift1) + (( ԅi) asciiValue)]. ^ Hash bitAnd16r3FFFFFFF! outputToPrinter "For compatability onlyOn Mac we use a Print or a TPrPort printing : 'Unsupported printing mechanism'! Ona "Append as a quoted a doubling all internal single quote characters a Put: $'. do a Put. = $' a Put]]. a Put: $'! Alla "Replace all occurences a | pattern range a = : [ ^ ]. patternPattern a. ݄. range1@1. [ (rangepattern match range x) Nil] ⓒ ݄ Replacerange x range y ^ ! stop a startingAtrepStart "Replace characters positions through stop consecutive characters a beginning repStart. <105> super stop a startingAtrepStart! stop a "Replace characters positions through stop a. a <106> ^ super stop a! " <62>! storeOna "Append ASCII a which can be reinstantiated Ona! Hash " integer hash | Hash <107> Hash0. 1 ܃ min16) doi Hash := (Hash bitShift1) + (( ԅi) asciiValue)]. ^ Hash bitAnd16r3FFFFFFF! symbolHash " integer representing hash | hash <162> . hash1 * 16. = 0 hashhash + ( ԅ) asciiValue * 4 + ( ԅ1 // 2) asciiValue * 4 + ( ԅ1) asciiValue ^ hash bitAnd16r7FFF! trimBlanks " a leading trailing blanks removed | nonBlank a nonBlank. aRead on. [a End ornonBlanka > Space]] :[]. nonBlank a ] : [^ 0 a 1. [a > Space] ⓒa skip: -2 ^ a ! Crs " where each occurrence \ has been replaced a line-feed 1 doي ( ԅ) = $\ ԅ Cr]]! ! ! Symbol class methods ! allocateHashsymbol "Allocate a hash symbol. The hash set symbol in Hashͤ1 | Hash (Hash ԅHashFreeListHead) Nil : [ growHash ]. HashHashFreeListHead. HashFreeListHeadHash ԅHash. Hash ԅHash symbol. symbol idHash1. ^ symbol! deallocateHasha "Deallocate a hash symbol " | Hash symbolTable removea Absent : 'System symbol not valid ' Hasha id1. (Hash ԅHash) == a : 'System inconsistant symbol hashes' Hash ԅHash HashFreeListHead. HashFreeListHeadHash. ^ ! growHash "Expand Hash accomodate more symbols | pointer old Hash >= 16379 : [ : 'symbol table full' ]. := (Hash * 2) min16379. ̈́ . old:= Hash . 1 old1) Hash startingAt1. old ܣ1) doaLink ԅaLink aLink1 Hash become. HashFreeListHeadold.! interna " a whose sequence same as that a | length symbol symbolTable symbolTable symbolTable. symbolsymbolTable symbolAta. symbol Nil lengtha . symbol := (super length) 1 length a. allocateHashsymbol. symbolTable addsymbol. ^ symbol! mustBea "Report a not a (a ) : 'Must be a ']! ignoreArgument " . This reports ^ invalidMessage! removeUnusedSymbols "Collect all unusedSymbols using finalization, by: 1) Making Table Hash weak. 2) Calling garbage collector. 3) Going through finalized giving back symbol hashes symbols it contains. 4) Unweakening Table Hash. amount space (in bytes) which was saved | finalized dead savedSpace savedSpace0. finalized̈́ Hash . finalized setTBF. symbolTable makeWeak. Hash makeWeak. unusedMemory. "Force a garbage [(finalized ԅ1) Nil] ⓒ 1 finalized doi deadfinalized ԅi. dead Nil savedSpacesavedSpace14dead . deallocateHashdead. finalized ԅi nil. ] ] allInstances. symbolTable makeWeak. Hash makeWeak. ^ savedSpace! shrinkHash "Collapse symbol hashing array minimum (plus enough space least 100 symbols). bytes saved | old sym last "Compute minimum " old脞Hash . [ symHash ԅ. sym Nil orsym = Small] ] : [ 脣1 ]. := (100) min8096. >= old " already minimum , so just return ^ 0 "Copy entries old array , renumber free list high low ̈́ . last) nil. 1 1 by: -1 doi symHash ԅi. (sym = ) ԅi sym ] ԅi last. lasti ] Hash become. HashFreeListHeadlast. ^ old褣 * 4! symbolTable " pointer symbol table ^ Table! symbolTableaSet "Set symbol table (Set) be used by system aSet (aSet MemberOfSet) : [ : 'Must be Table' ]. TableaSet! ! ! Symbol methods ! = a " argument a, <110>! as " a characters contained by ^ ( ) 1 ! as " a . The itself answered since it a ^ ! ԅ a "Replace in indexed by argument a. This message not valid symbols, since they are not allowed ŗ ^ invalidMessage! deepCopy " a shallow copies each . Because symbols are unique (cannot be copied), ^ ! hash " integer hash ^ symbolHash! id "Set id <102> ^ Failed! Ona "Append ASCII a a PutAll! shallowCopy " a which shares . Because symbols are unique (cannot be copied), ^ ! species " as species symbols ^ ! storeOna "Append ASCII a which can be reconstructed a Put: $#; PutAll! ! ! OrderedCollection class methods ! " Ordered capable holding 12 initially ^ 12! " initialized Ordered capable holding ʗ ^ (super ) initPositions! ! ! OrderedCollection methods ! , a " Ordered all followed by all a ^ deepCopy addAlla; yourself! add " . Add after last end = SpaceAtEnd endend1. ԅend . ^ ! add afterold " . Insert immediately after old in . If old not in , report | 1. [ <= ] ⌒ old = ( ԅ) : [^ add after 1 ^ AbsentElement! add after " . Insert + 1 in . If out bounds, report SpaceAfter. ^ ԅ1 ! add beforeold " . Insert immediately before old in . If old not in , report | 1. [ <= ] ⌒ old = ( ԅ) : [^ add before 1 ^ AbsentElement! add before " . Insert 1 in . If out bounds, report SpaceAfter1. ^ ԅ ! addAllFirsta " a. Add all contained in a before its | a . [ <= 0] ⓒ addFirsta ԅ). 1 ^ a! addAllLasta " a. Add all contained in a after its last | a . 1. [ <= ] ⌒ addLasta ԅ). 1 ^ a! addFirst " . Add before = 1 SpaceAtStart 笄笤1. ԅ . ^ ! addLast " . Add after last end = SpaceAtEnd endend1. ԅend . ^ ! after " that immediately follows in . If not , report ^ after None: [^ AbsentElement]! after Nonea " that immediately follows in . If not , a evaluated ( no arguments)." | . [ < end] ⌒ = ( ԅ) : [^ ԅ1 1 ^ a ! ԅ " . If invalid , report | 笤1. ( <= <= end]) ^ InBounds ^ ԅ! ԅ " . Replace . If invalid , report | 笤1. ( <= <= end]) ^ InBounds ԅ . ^ ! before " that immediately precedes in . If not , report ^ before None: [^ AbsentElement]! before Nonea " that immediately precedes in . If not , a evaluated ( no arguments)." | 1. [ <= end] ⌒ == ( ԅ) : [^ ԅ1 1 ^ a ! beginning end " Ordered beginning through end | ( species ) 笅1 endendbeginning1. ^ 1 endbeginning1 startingAtbeginning! doa " . For each in , evaluate a that as argument | 笤1. [(1) <= end] ⌒a ԅ)]! AbsentElement "Produce a walkback effect that desired was not in ^ : 'attempt access absent '! grow " expanded in accomodate more ʗ growTo grow! growTo " expanded accomodate ʗ | a a . a end startingAt. ӄa! includes " contains equal , | 笤1. [(1) > end] ⓒ = ( ԅ) : [^ ]]. ^ ! initPositions " after initializing it be empty Ordered slots 笄1. end0. ӄ ! inspect "Open inspector on OrderedInspector openOn! SpaceAfter " room immediately after | end = SpaceAtEnd = 0 = 1 SpaceAtStart 笄笤1. ^ endend1. 1. [ > ] ⌒ ԅ1 ܃ ԅ). 1]! SpaceAtEnd " room more following last | = 1 : [^ grow] . // 2. 0. [ < ] ⌒ ԅ ԅ). 1 笄. end1 . [ > end] ⌒ ԅ nil. 1]! SpaceAtStart " room more before | end end = grow . end end1 // 2. 0. [ < ] ⌒ ԅend ԅend). 1 笄end1. endend. 1. [ < ] ⌒ ԅ nil. 1]! remove Absenta " . Remove . If not , a evaluated ( no arguments)." | . [ <= end] ⌒ = ( ԅ) remove. ^ 1 ^ a ! removeFirst "Remove . If empty, report | > end : [^ AbsentElement ԅ. ԅ nil. 笄1. ^ ! remove " . Remove . If invalid , report | ( between end) : [^ AbsentElement . [ < end] ⌒ ԅ ԅ1). 1 ԅend nil. endend1! removeLast "Remove last . If empty, report | > end : [^ AbsentElement ԅend. ԅend nil. endend1. ^ ! stop a " a Ordered whose through stop have been replaced by a | final a . final脃 - (stop1). final > growTofinal + (final // 310)]. 笅 end . final startingAtstop1. 1 a startingAt1. 笅 endfinal1. end1. [ <= ] ⌒ ԅ nil. 1 ^ ! shrink " expanded in accomodate more ʗ shrinkTo grow! shrinkTo " collapsed requested | a End a ܥ max ). a 1 ܣEndend1) startingAt. 笄1. endEnd. ӄa! " contained by ^ end - (笤1)! 笅 endend " . Set last , arguments stop respectively 笄. endend! ! ! Process class methods ! breakpointInterrupt "Implement breakpoint interrupt CurrentProcess debugger Nil CurrentProcess debugger breakpoint]! controlBreakInterrupt "Initiate a control- break walkback KeyboardSemaphore hasWaitingProcesses : [ ControlBreakOccurred. KeyboardSemaphore signal ] : [ Process queueWalkback: 'Control break' makeUserIF resumable ]! Stack " a NewProcess stack ӗ <152>! dropSenderChain "Discard stacked message sends (sent but not answered) outermost send, input request loop <109>! enableInterruptsaBoolean " previous interrupt enable state. Set interrupt enable state aBoolean <149>! BiasUnit " amount Bias by one pointer ^ 4! gcCompactInterrupt "Implement gc compact interrupt Processor status compact. enableInterrupts. ^ ! gcFlipInterrupt "Implement gc flip interrupt Processor status flip. enableInterrupts. ^ ! interruptinterrupt "Put interrupt in virtual machine queue <150>! ioErrorInterrupt "Initiate OS critical walkback enableInterrupts. MTrap osErrorErrorCode32! keyboardInterrupt "Implement keyboard interrupt KeyboardSemaphore signal. ^ ! " a NewProcess ^ super ! overrunInterrupt "Initiate interrupt queue overrun walkback Process queueWalkback: 'Interrupt queue overrun' makeUserIF resumable! queueWalkbacka makeUserIFBoolean resumableresumeBoolean "Enter a walkback process in pending event queue. Create user interface process Boolean × | process Time []. Time. Process enableInterrupts. processProcess Stack. Time : [ "before resume" Time. CurrentProcessProcess . Boolean : [ CurrentProcess makeUserIF ]. PendingEvents addMessage selectorIn:label: ; arguments process a)). KeyboardSemaphore signal. "force null event" Process enableInterrupts. Boolean : [ Scheduler run ] : [ Process enableInterrupts. Processor schedule ] ] : [ "after resume" resumeBoolean : 'process not resumable'] ]! stepInterrupt "Implement debugger step interrupt CurrentProcess debugger Nil CurrentProcess debugger singleStep]! timerInterrupt "Implement timer interrupt Time checkDelay. PendingEvents add: (Message selectorclockEvent:; arguments 1)). KeyboardSemaphore signal. enableInterrupts! unknownInterrupt "Implement unknown interrupt reverse. enableInterrupts! ! ! Process methods ! contextFor " context stack ^ ( At) has : [ At ҅5 ] : [ nil ]! debugger " debugger associated , or nil none ^ debugger! debuggeraDebugger "Set 's debugger aDebugger debugger:= aDebugger! dropFrame "Discard top stack | TopFrame pc TopFrame FrameAt0. pc:= icAt0. end - ( 0) timesRepeat removeLast addLastpc. topFrameTopFrame! dropToaCompiledMethod "Discard all stack entries preceding last occurence aCompiledMethod | dropCount dropCount findFrameOfaCompiledMethod. dropCount1 timesRepeat dropFrame]! findFrameOfaCompiledMethod " last occurrence aCompiledMethod, or 0 none | biasUnit 0. biasUnitProcess BiasUnit. := (topFrameBias) // biasUnit. [( ԅ) = 0] ⓒ aCompiledMethod == ( ԅ3) : [ ]. 1. := (( ԅ) + Bias) // biasUnit ^ ! At ҅ " + 1 stack indicated by җ | ToProcess: . ^ ԅ! At ҅ "Set +1 stack indicated by | ToProcess: . ԅ ! Bias " Bias ^ Bias! AtwalkbackFrame " process +1 stack | process biasUnit biasUnitProcess BiasUnit. processtopFrame. walkbackFrame timesRepeat process : (processBias) // biasUnit. process = 0 : 'End stack chain']]. ^ process! ToProcess " process +1 stack ^ (( At) + Bias) // Process BiasUnit! homeFrameOf " stack associated block or identified by | context homeOffset (context contextFor) Nil : [^ (homeOffsetcontext Offset) = 0 : [^ 0]. "already exited" homeOffset := (context OffsetBias4) negated. 0. ҄topFrame. [ = 0] ⓒ ҄ : (Bias) // Process BiasUnit. 1. = homeOffset : [^ ]]. ^ 0! icAt " instruction counter stack ^ At ҅2! "Initialize priorityCurrentProcess priority. UserIF. := 'Background'. runable. interruptFrame0! inspect "Open inspector on (should be a Debugger)." Inspector openOn! interruptFrameaFramePointer "Set interrupt aFramePointer interruptFrame:= aFramePointer! UserIF " a user interface process ^ UserIF! lastFrame " process oldest stack | process biasUnit biasUnitProcess BiasUnit. processtopFrame. [( process+Bias)//biasUnit) = 0] : [ process ]. ^ process! makeUserIF "Make be user interface process UserIF. := 'User I/F'. priorityProcessor userPriority. UserInterfaceProcess! At " compiled stack ^ At ҅3! At compiledMethod "Update compiled stack At ҅3 compiledMethod. At ҅4 compiledMethod byteCode! " process ؗ ^ ! ؅a "Set process a ؄a! FrameAt " Frame entry stack ^ At ҅0! Frame "Print top 0 ^ Dialog message: ( At) , ' ', ( last) ]. ^ Menu message: ( At) , ' ', ( icAt) ! Ona "Print something useful about process a PutAll: 'Process({', , '} Prio:', priority , ' '. UserIF : [ a PutAll: 'userIF ' ]. debugger Nil : [ a PutAll: 'debugging ']. a PutAll: ')'.! priority " integer representing process priority ^ priority! prioritya "Change priority process a (a between1 8) : 'priority ', a , ' out range']. prioritya! At " stack ^ : (( At ҅1) + Bias) // Process BiasUnit! " stack ^ (( At ҅1) + Bias) // Process BiasUnit! restartAt "Restart process described in stack | context „ At. 1 tempCount doي tempAt nil context contextFor. timesRepeat dropFrame context Nil context Offset: Bias negated4topFrame. removeLast. "Throw away old pc addLast22. resume0! resume "Resume process CurrentProcess. resume0! resumeaFrame "Resume process aFrame stack <153> ^ Failed! sendFrame " sendFrame ^ sendFrame! sendFrameaFramePointer "Set send aFramePointer sendFrame:= aFramePointer! stackOverflow "Pop-up a walkback describing stack overflow condition (too many stacked message sends). This message sent by virtual machine : 'stack overflow'! tempAt temp " temp temp stack | context „ At. temp > ( tempCount argumentCount) : 'temp too big']. (context contextFor) Nil "Access temp stored in stack ^ At ҅temp negated ] "Access temp stored in context" ^ context ԅtemp ]! tempAt temp "Set temp temp stack | context „ At. temp > ( tempCount argumentCount) : 'temp too big']. (context contextFor) Nil "Access temp stored in stack ^ At ҅temp negated ] "Access temp stored in context" ^ context ԅtemp ]! walkbackOncollector maxLevelsa " stacked message sends on collector | a stopSelector stopSelector := collector Debugger nil] : [#Doit 0. [(1) > a or: [( FrameAt1) = 0]] ⓒ ( homeFrameOf) = collector PutAll: '[] in ']. a := ( At) . a UpperCase collector PutAlla . „ At. Nil collector PutAll: '>>-unknown selector-'] Field = a collector Put: $(; PutAll Field ; Put: $)]. collector PutAll: '>>'; PutAll selector. selector = stopSelector : [^ collector cr]]. collector cr]]! ! ! SortedCollection class methods ! " a Sorted capable holding which will sort in ascending order ^ (super ) sorta :b | a <= b]! sorta " aSorted which will sort in order defined by a ^ (super 10) sorta! ! ! SortedCollection methods ! add " . Add in sorted | end = SpaceAtEnd end. endend1. [ < ] ⓒ ԅ. (sort ) ^ ԅ1 ԅ1 . 1 ^ ԅ1 ! add afterold "Add after old in . This reports since sort determines order ^ invalidMessage! add beforeold "Add before old in . This reports since sort determines order ^ invalidMessage! addAlla " a. Add all in a in sorted order a doٻ super addLast reSort. ^ a! addAllFirsta "Add all a before its . This reports since sort determines order ^ invalidMessage! addAllLasta "Add all a after its last . This reports since sort determines order ^ invalidMessage! addFirst "Add before . This reports since sort determines order ^ invalidMessage! addLast "Add after last . This reports since sort determines order ^ invalidMessage! ԅ "Replace in . This reports since sort determines order ^ invalidMessage! beginning end " a Sorted beginning through end | species . beginning end do: [:i add܃ ԅi)]. ^ ! grow " doubled in accomodate more ʗ | a asort. super grow. sorta! reSort " resorted according sort sort end! sortlower upper "Sort in that are between lower upper positions | t terminate mid low up swapper i lastLow lowlower. upupper. [(terminate := (iuplow) <= 1) : [ "only 0, 1 or 2 " i = 1 : [ "2 " (sort i ԅup) swapper ԅlow)) : [ "exchange" ԅlow i. ԅup swapper]]] midlowup // 2. t ԅmid. ԅmid ԅlow). ilastLowlow. [ii1. (sort ԅi) t) (lastLowlastLow1) = i swapper ԅi. ԅi ԅlastLow). ԅlastLow swapper]]. i < up] : []. ԅlow ԅlastLow). ԅlastLow t. mid < lastLow sortlastLow1 up. uplastLow1] sortlow lastLow1. lowlastLow1]]. terminate] : []! sort " block that determines sort ordering ^ sort! sorta " . Set sort block a resort sorta. reSort! ! ! Set class methods ! " a Set ^ 4! " a Set initial capacity ʗ ^ super : ( 1 max)! ! ! Set methods ! add " Add does not already contain it | Nil adjust. ( : ( findElement)) Nil CountCount1. ^ ԅ ^! adjust " If set getting full, expand it accomodate more objects (Count * 10) >= ( 2 * 9) grow]! ԅ "Access in This reports since sets cannot be indexed ^ NotIndexable! ԅ "Replace in This reports since sets are not indexable ^ NotIndexable! " ^! doa " For each in , evaluate a that as argument | . [ > 0] ⌒ ( ԅ) == nil a 1]! findElement " in or empty | indexed last last . := ( hash) \\ last1. [(indexed ԅ) = ] ⓒ (indexednil) (1) > last : [ " wraparound" 1]]. ^! grow " expanded accomodate more ʗ | aSet aSet species * 4 // 310. doٻ | aSet add ӄaSet ! includes " includes as one its , ^(( : ( findElement)) == nil) not! Յ "Initialize Count zero, Count0. ӄ ! occurrencesOf " 1 includes as one its , zero ( includes) 1 ^0! rehash "Rehash last | delete last search test last . delete. [(deletedelete1) > last : [ " wraparound" delete1 (test ԅdelete) == nil] : [ "test relocation" search findElementtest. ( ԅsearch) == nil : [ "found move" ԅsearch test. ԅdelete nil]]! remove Absenta " Remove If not , a evaluated ( no arguments)." | findElement. ( ԅ) == nil a ԅ nil. CountCount1. rehash. ^! " contained in ^Count! ! ! Dictionary class methods ! ! ! Dictionary methods ! add " . Add | findKey key. ( ԅ) == nil CountCount1. ԅ ] adjust. ^ ! addAlla " a. Add each a a associationsDoٻ | add ^ a! associationAtaKey " whose key equals aKey . If not found, report ^ associationAtaKey Absent AbsentKey]! associationAtaKey Absenta " whose key equals aKey . If not found, evaluate a ( no arguments)." | ^ ( lookUpKeyaKey) == nil a ] ]! associationsDoa " . For each key/ pair in , evaluate a that pair as argument super doa! ԅaKey " key/ pair whose key equals aKey . If not found, report | ^ ( lookUpKeyaKey) == nil AbsentKey] ]! ԅaKey Absenta " key/ pair whose key equals aKey . If not found, evaluate a ( no arguments)." | ^ ( lookUpKeyaKey) == nil a ] ]! ԅaKey " . If contains key/ pair whose key equals aKey, pair . Else add aKey/ pair add keyaKey ). ^ ! deepCopy " a shallow copies each | species . associationsDo: [: add ^ ! doa " . For each in , evaluate a that as argument super doassociation a association ]! AbsentKey "Report effect that desired key was not found in : 'Key missing'! findKeyaKey " key/ pair in whose key equals aKey or empty where such pair would be stored | . := (aKey hash) \\ 1. [((DŽ ԅ) Nil) oraKey = key]] ⓒ (1) > 1]]. "wrap-around" ^ ! grow " doubled in accomodate more key/ pairs | a a˄ * 2. associationsDo٦ a add ӄa ! includes " contains key/ pair whose equals , doٻ = : [^ ]]. ^ ! includesKeyaKey " contains aKey, ^ ( lookUpKeyaKey) notNil! inspect "Open a dictionary inspector on Inspector openOn! keyAtValue " key in whose paired equals . If not found, nil ^ keyAtValue Absentnil]! keyAtValue Absenta " key in whose paired equals . If not found, evaluate a ( no arguments)." associationsDo٦ = : [^ key]]. ^ a ! keys " a Set all keys in | Set * 2. associationsDoassoc addassoc key ^ ! keysDoa " . For each key in , evaluate a key as argument associationsDo٦ a key]! lookUpKeyaKey " association in whose key equals aKey or nil it doesn't exist | limit limit . := (aKey hash) \\ limit1. [((DŽ ԅ) == nil) oraKey = key]] ⓒ (1) > limit 1]]. "wrap-around" ^ ! occurrencesOf " key/ pairs in , whose values are equal | 0. doٻ = : [1]]. ^ ! rehash "Re-hash reciever | . associationsDoeach | addeach ӄ ! rehash "Rehash keys last | search . . [(1) > 1]. "wrap-around" (DŽ ԅ) Nil] : [ "test assoc relocation" search findKey key. ( ԅsearch) Nil : [ "found assoc move" ԅsearch . ԅ nil]]! remove Absenta "Remove key/ pair whose dictionary. This reports since values are not unique in a dictionary, keys are ^ invalidMessage! removeDž " after has been removed it. If not in , report removeKey key! removeKeyaKey " key/ pair whose key equals aKey removed. If such a pair not found, report ^ removeKeyaKey Absent AbsentKey! removeKeyaKey Absenta " aKey. Remove key/ pair whose key equals aKey . If such a pair not found, evaluate a ( no arguments)." | | findKeyaKey. ( ԅ) == nil : [^ a ԅ nil. CountCount1. rehash. ^ aKey! a "For each key/ pair in , evaluate a part pair as argument. a those key/ pairs which a evaluates × | species . associationsDoeach (a each ) addeach]]. ^ ! shallowCopy " a which shares ʗ | species . associationsDo: [: add ^ ! storeOna "Append ASCII a which can be reinstantiated | Time Time. a PutAll: '(('; PutAll ; PutAll: ' )'. associationsDoassoc Time a Put: $;]. a cr; PutAll: 'add: ('. assoc storeOna. a Put: $). Time Time a PutAll: ';yourself']. a Put: $)! values " a Bag all values key/ pairs in | Bag . associationsDoassoc addassoc ^ ! ! ! IdentityDictionary class methods ! initial " initial that a Identity contains ^ 8! " a Identity˗ ^ (super initial * 2)! "Create a initial capacity . This reports since identity dictionary must be a power 2 ^ invalidMessage! 腦 " Identity capable ʗ ^ (super * 2)! ! ! IdentityDictionary methods ! add " . Add ԅ key . ^ ! adjust " . If getting full, expand it accomodate more objects (Count * 20) >= ( 2 * 9) : [^ grow]! associationAtaKey Absenta " , aKey its corresponding aKey exists in , evaluate a ( no arguments)." | findKeyaKey. ( ԅ) == nil : [^ a ^ key ԅ) ԅ1)! associationsDoa " . For each key/ pair in , evaluate a that pair as argument 1 by2 doي ( ԅ) Nil a : ( key ԅ) ԅ1))]]! ԅaKey " key/ pair whose key equals aKey . If not found, report | findKeyaKey. ( ԅ) == nil : [^ AbsentKey ^ ԅ1! ԅaKey Absenta " key/ pair whose key equals aKey . If not found, evaluate a ( no arguments)." | findKeyaKey. ( ԅ) == nil : [^ a ^ ԅ1! ԅaKey " . If aKey exists in , corresponding , add aKey/ pair | aKey Nil : 'key cannot be nil']. findKeyaKey. ( ԅ) Nil CountCount1. ԅ aKey. ԅ1 . adjust] ԅ1 ^ ! doa " . For each in , evaluate a that as argument 1 by2 doي ( ԅ) Nil a : ( ԅ1)]]! findKeykey " key/ pair in whose key equals aKey or empty where such pair would be stored | last last . := ((key hash) bitAndlast // 21) * 21. [key == ( ԅ)] ⓒ ( ԅ) Nil : [^ (2) > last : [ " wraparound" 1]]. ^ ! grow " doubled in accomodate more key/ pairs | a a˄ species . "this doubles " associationsDo٦ a add ӄa ! includesKeyaKey " contains aKey, ^ ( ܃ findKeyaKey)) notNil! keyAtValue Absenta " key in whose paired equals . If not found, evaluate a ( no arguments)." 1 by2 doي ( ԅ1) = ( ԅ) == nil : [^ ԅ]]]. ^ a ! keys " a Set all keys in | Set * 2. 1 by2 doي ( ԅ) == nil add ԅ)]]. ^ ! rehash "Rehash keys last | search . . [(2) > : [ " wraparound" 1 ( ԅ) Nil] : [ "test key relocation" search findKey. ( ԅsearch) Nil : [ "found key move" ԅsearch ԅ). ԅ nil. ԅsearch1 ԅ1). ԅ1 nil]]! removeKeyaKey Absenta " aKey. Remove key/ pair whose key aKey . If aKey not in , evaluate a ( no arguments)." | | findKeyaKey. ( ԅ) == nil : [^ a ԅ nil. ԅ1 nil. CountCount1. rehash. ^ aKey! values " a Bag all values key/ pairs in dictionary | Bag . 1 // 2 doi i * 21. ( ԅ) Nil add ԅ1)]]. ^ ! ! ! MethodDictionary class methods ! "Initialize Removing! ! ! MethodDictionary methods ! add " . Add . Flush cache in case old has Η | key intState key key. (key MemberOf) : [^ : 'key must be ']. intStateProcess enableInterrupts. super add keykey ). Process enableInterruptsintState. Removing flushCachekey ^ ! ԅa aMethod " aMethod. Enter a aMethod as a key/ pair in . Flush cache in case old has Η | intState mustBea. intState