lobby ensureNamespace: #SRP. SRP addPrototype: #Placeholder derivedFrom: {Cloneable}. SRP Placeholder addSlot: #baseObject. SRP Placeholder addSlot: #memento. SRP Placeholder addSlot: #loaderIndex. SRP Placeholder addSlot: #canDiscard. SRP addPrototype: #Portal derivedFrom: {Cloneable}. SRP addPrototype: #Configuration derivedFrom: {Cloneable}. SRP Configuration addSlot: #metastates. SRP Configuration addSlot: #exchangeRules. SRP addPrototype: #NonMappingConfiguration derivedFrom: {SRP Configuration}. SRP addPrototype: #ActionItem derivedFrom: {Cloneable}. SRP ActionItem addSlot: #placeholder. SRP ActionItem addSlot: #baseObject. SRP ActionItem addSlot: #action. SRP addPrototype: #Marshaler derivedFrom: {Cloneable}. SRP Marshaler addSlot: #stream. SRP Marshaler addSlot: #classTable. SRP Marshaler addSlot: #context. SRP Marshaler addSlot: #hitSequence. SRP Marshaler addSlot: #finishingActions. SRP addPrototype: #ObjectStream derivedFrom: {Cloneable}. SRP addPrototype: #ObjectSaver derivedFrom: {SRP Marshaler}. SRP addPrototype: #ObjectLoader derivedFrom: {SRP Marshaler}. SRP addPrototype: #Metastate derivedFrom: {Cloneable}. SRP addPrototype: #MetastateTable derivedFrom: {Cloneable}. SRP addPrototype: #MetastateTableReference derivedFrom: {Cloneable}. SRP addPrototype: #Context derivedFrom: {Cloneable}. SRP Metastate addSlot: #code. SRP Metastate addSlot: #instanceShape. SRP Metastate addSlot: #behaviorName. SRP Metastate addSlot: #versionNumberArray. SRP Metastate addSlot: #behavior. SRP Metastate addSlot: #allInstVarNames. SRP Metastate addSlot: #namedStoreTypeCodesCollection. SRP Metastate addSlot: #mapTable. SRP Metastate addSlot: #extendedAttributes. SRP addPrototype: #MetastateShape derivedFrom: {Cloneable}. SRP MetastateShape addSlot: #integer. SRP Context addSlot: #originalCurrent. SRP Context addSlot: #mappedCurrent. SRP Context addSlot: #originalStack. SRP Context addSlot: #mappedStack. SRP Context addSlot: #exchangeRules. SRP Context addSlot: #configuration. SRP Context addSlot: #userData. SRP Context addSlot: #encodingVersion. SRP addPrototype: #SaveContext derivedFrom: {SRP Context}. SRP addPrototype: #LoadContext derivedFrom: {SRP Context}. SRP MetastateTable addSlot: #index. SRP MetastateTable addSlot: #dictionary. SRP MetastateTableReference addSlot: #name. SRP MetastateTableReference addSlot: #location. SRP MetastateTableReference addSlot: #accessCode. SRP MetastateTableReference addSlot: #configuration. SRP addPrototype: #StreamEncoding derivedFrom: {Cloneable}. SRP addPrototype: #NativeStreamWrapper derivedFrom: {SRP StreamEncoding}. SRP NativeStreamWrapper addSlot: #stream. SRP NativeStreamWrapper addSlot: #marshaler. SRP ObjectStream addSlot: #stream. SRP ObjectStream addSlot: #initialPosition. SRP ObjectStream addSlot: #previousPosition. SRP ObjectStream addSlot: #metastateTableReference. SRP ObjectStream addSlot: #binary. SRP ObjectStream addSlot: #config. SRP ObjectSaver addSlot: #hitList. SRP ObjectSaver addSlot: #duplicationTypes. SRP ObjectLoader addSlot: #stream. SRP ObjectLoader addSlot: #classTable. SRP ObjectLoader addSlot: #context. SRP ObjectLoader addSlot: #hitSequence. SRP ObjectLoader addSlot: #finishingActions. SRP addPrototype: #SubstituteObject derivedFrom: {Cloneable}. SRP addPrototype: #PmrNamespaceReference derivedFrom: {SRP SubstituteObject}. SRP PmrNamespaceReference addSlot: #namespace. SRP addPrototype: #PmrClassReference derivedFrom: {SRP PmrNamespaceReference}. SRP PmrClassReference addSlot: #classSymbol. SRP addPrototype: #PmrMetaclassReference derivedFrom: {SRP PmrClassReference}. SRP addPrototype: #PmrString derivedFrom: {SRP SubstituteObject}. SRP addPrototype: #PmrIndexable derivedFrom: {SRP SubstituteObject}. SRP addPrototype: #PmrMagnitude derivedFrom: {SRP SubstituteObject}. SRP addPrototype: #PmrNumber derivedFrom: {SRP PmrMagnitude}. SRP addPrototype: #PmrFloat derivedFrom: {SRP PmrNumber}. SRP PmrFloat addSlot: #numerator. SRP PmrFloat addSlot: #denominator. SRP PmrIndexable addSlot: #indexableValues. SRP addPrototype: #PmrArray derivedFrom: {SRP PmrIndexable}. SRP PmrString addSlot: #string. SRP addPrototype: #PmrSymbol derivedFrom: {SRP PmrString}. SRP addPrototype: #State derivedFrom: {Cloneable}. SRP State addSlot: #metastate. SRP State addSlot: #namedValues. SRP State addSlot: #indexableValues. SRP State addSlot: #extendedAttributes. p@(SRP Portal) shortNameForBehavior: ms@(SRP Metastate) [ ms behaviorShortName ]. mst@(SRP MetastateTable traits) initialize [ mst `>> [ dictionary: (Dictionary newSize: 2). index: (ExtensibleArray newSize: 127). ]. mst index addLast: Nil. mst ]. mst@(SRP MetastateTable traits) metastateForType: type [ mst dictionary at: type printName ifAbsent: [] ]. mst@(SRP MetastateTable traits) atCode: integer putMetastate: aMetastate [ (integer - mst index size) timesRepeat: [ mst index add: Nil ]. aMetastate isNil ifTrue: [mst index at: (integer - 1) put: Nil] ifFalse: [mst addMetastate: aMetastate]. ]. mst@(SRP MetastateTable traits) nextAvailableCode [ 32 upTo: (mst index size) do: [ |:i| (mst index at: i) ifNil: [^ i]]. mst index addLast: Nil. (mst index size) - 1 ]. mst@(SRP MetastateTable traits) metastateForCode: code [ mst index size < code ifTrue: [ ^ Nil]. mst index at: (code - 1) ]. mst@(SRP MetastateTable traits) addMetastate: aMetastate [ | existing | aMetastate code isNil ifTrue: [aMetastate code: mst nextAvailableCode]. ifFalse: [ existing: (mst metastateForCode: aMetastate code). existing isNil ifFalse: [mst dictionary removeKey: existing printName] ]. existing: (mst dictionary at: (SRP Portal shortNameForBehavior: aMetastate) ifAbsent: []). existing isNil ifFalse: [ mst index at: (existing code - 1) put: Nil]. mst dictionary at: (SRP Portal shortNameForBehavior: aMetastate) put: aMetastate. (aMetastate code - (mst index size)) timesRepeat: [mst index add: Nil]. mst index at: (aMetastate code - 1) put: aMetastate. aMetastate ]. s@(SRP NonMappingConfiguration traits) allLoadExchangeRules [ "Answer a collection of all the class-based exchange rules that are to be in effect when loading using this configuration." (Set newSize: 1) `>> [ addAll: s dialectLoadExchangeRules. addAll: s selectedLoadExchangeRules] ]. s@(SRP NonMappingConfiguration traits) allSaveExchangeRules [ "Answer a collection of all the class-based exchange rules that are to be in effect when saving using this configuration." (Set newSize: 1) `>> [ addAll: s dialectSaveExchangeRules. addAll: s selectedSaveExchangeRules] ]. s@(SRP Configuration traits) selectedSaveExchangeRules [ s exchangeRules select: [ | :ea | ea useWhenSaving ] ]. s@(SRP Configuration traits) selectedLoadExchangeRules [ s exchangeRules select: [ | :ea | ea useWhenLoading ] ]. s@(SRP Configuration traits) default [ s new ]. s@(SRP Configuration traits) new [ (s clone) `>> [ exchangeRules: (Set newSize: 1). metastates: (ExtensibleArray newSize: 2).] ]. s@(SRP Configuration traits) replicate: anObject [ "A convenience method to replicate anObject using the receiver for configuration settings." | stream | stream: (s newStream). stream nextPut: anObject. (s newStream on: (stream stream contents reader)) next ]. s@(SRP Configuration traits) loadObjectFromBinaryFilename: fname [ | f stream answer | f: (File newNamed: fname &mode: (File Read)). f enable. stream: ((s newStream makeBinary) on: f reader). answer: stream next. stream close. answer ]. s@(SRP Configuration traits) saveObject: anObject toBinaryFilename: fname [ | f stream | f: (File newNamed: fname &mode: (File CreateWrite)). f enable. stream: ((s newStream makeBinary) on: f writer). stream nextPut: anObject. stream close. ]. s@(SRP Configuration traits) loaded: object using: loader [ object ]. c@(SRP Configuration traits) newStream [ (SRP ObjectStream clone) initializeConfiguration: c ]. c@(SRP Configuration traits) newSaveContext [ (SRP SaveContext clone) newConfiguration: c ]. c@(SRP Configuration traits) newLoadContext [ (SRP LoadContext clone) newConfiguration: c ]. c@(SRP Configuration traits) beingUsedForObjectSaver: os [ os ]. c@(SRP Configuration traits) beingUsedForObjectLoader: ol [ ol ]. c@(SRP Configuration traits) beingUsedForObjectStream: os [ os ]. c@(SRP Configuration traits) newMetastateTable [ SRP MetastateTable clone `>> [ initialize. addAllMetastates: c metastates.] ]. m@(SRP MetastateTable traits) addAllMetastates: aCollection [ aCollection do: [|:ea| m atCode: ea putMetaState: ea copy] ]. c@(SRP Configuration traits) initialObjectsExpectedBufferSize [ 10 ]. c@(SRP Configuration traits) initialFinishingActionsBufferSize [ 2 ]. c@(SRP Configuration traits) newHitList [ IdentityDictionary newEmpty ]. c@(SRP Configuration traits) initialEncodings [ {} ]. c@(SRP Configuration traits) loadPreMapCommand [ "Used to declare the code that should be executed to apply inheritance-based mapping rules for all objects as they are traversed for a load just after class-based mapping rules are applied." ^ ([ |:object :context | object srpLoadPreMap: context ]) ]. c@(SRP Configuration traits) loadPostMapCommand [ "Used to declare the code that should be executed to apply inheritance-based mapping rules for all objects as they are traversed for a load just after class-based mapping rules are applied." [ |:object :context | object srpLoadPostMap: context ] ]. c@(SRP Configuration traits) savePreMapCommand [ [ |:object :context | object srpSavePreMap: context ] ]. c@(SRP Configuration traits) savePostMapCommand [ [ |:object :context | object srpSavePostMap: context ] ]. c@(SRP Configuration traits) duplicationTypes [ #(Character True False SmallInteger) ]. c@(SRP Configuration traits) newMetastateTableReferenceNamed: aString [ SRP MetastateTableReference newNamed: aString configuration: c ]. c@(SRP Configuration traits) allSaveExchangeRules [ (Set newSize: 2) `>> [ addAll: c dialectSaveExchangeRules. addAll: c defaultSaveExchangeRules. addAll: c selectedSaveExchangeRules.] ]. c@(SRP Configuration traits) allLoadExchangeRules [ (Set newSize: 2) `>> [ addAll: c dialectLoadExchangeRules. addAll: c defaultLoadExchangeRules. addAll: c selectedLoadExchangeRules.] ]. c@(SRP Configuration traits) dialectSaveExchangeRules [ {} ]. c@(SRP Configuration traits) dialectLoadExchangeRules [ {} ]. c@(SRP Configuration traits) defaultLoadExchangeRules [ (Set newSize: 1) `>> [ add: SRP PmrSymbol. add: SRP PmrString. add: SRP PmrArray. add: SRP PmrFloat.] ]. c@(SRP Configuration traits) defaultSaveExchangeRules [ (Set newSize: 1) `>> [ add: SRP PmrSymbol. add: SRP PmrString. add: SRP PmrArray. add: SRP PmrFloat.] ]. c@(SRP Context traits) recursiveMappingFor: anOriginal [ "Answers nil or the mapped replacement for anOriginal if anOriginal is in the context stack--if it is a recursive reference." | oati mati | 0 to: (c originalStack size - 1) do: [ | :i | (anOriginal == (oati: (c originalStack at: i)) and: [oati ~~ (mati: (c mappedStack at: i))]) ifTrue: [ ^ mati]. ]. Nil ]. c@(SRP Context traits) exchange [ c mappedCurrent: (c preMapCommand applyWith: c mappedCurrent with: c ). c classBasedExchange. " Console ; 'applying postmap command for ' ; (c mappedCurrent printName) ; '\n'." c mappedCurrent: (c postMapCommand applyWith: c mappedCurrent with: c). c mappedCurrent ]. so@(SRP PmrIndexable traits) applyTo: anObject context: context [ (so clone) `>> [ indexableValues: (Array newSize: anObject size). addAll: anObject.] ]. s@(String traits) srpIndexableSize [ s size ]. a@(Array traits) srpIndexableSize [ a size ]. a@(Array traits) srpIndexableValueAt: index [ a at: index ]. a@(Array traits) srpIndexableValueAt: index put: o [ a at: index put: o ]. s@(String traits) srpIndexableValueAt: index [ s at: index ]. so@(SRP PmrIndexable traits) srpIndexableSize [ so indexableValues size ]. so@(SRP PmrIndexable traits) srpIndexableValueAt: index [ so indexableValues at: index ]. ba@(ByteArray traits) srpNew [ ba clone ]. sf@(SingleFloat traits) srpNew [ sf clone ]. ps@(SRP PmrString traits) srpNew [ ps clone ]. pf@(SRP PmrFloat traits) srpNew [ pf clone ]. s@(String traits) srpNew: size [ s newSize: size ]. s@(Symbol traits) srpNew: size [ s newSize: size ]. a@(Array traits) srpNew: size [ a newSize: size ]. s@(String traits) srpIndexableValueAt: index put: c [ s at: index put: c ]. so@(SRP PmrIndexable traits) srpNew: size [ (so clone) `>> [ indexableValues: (Array newSize: size).] ]. so@(SRP PmrIndexable traits) addAll: aCollection [ |index| index: -1. aCollection do: [ |:assoc| index: index + 1. so indexableValues at: index put: assoc]. ]. pf@(SRP PmrFloat traits) asNative [ ((pf numerator) / (pf denominator)) as: Float ]. ps@(SRP PmrString traits) asNative [ ps string ]. ps@(SRP PmrSymbol traits) asNative [ ps string intern ]. ns@(SRP PmrNamespaceReference traits) asNative [ ns resolveNamespace ]. ns@(SRP PmrNamespaceReference traits) resolveNamespace [ ns namespace isNil ifTrue: [ ^ lobby ]. ns namespace sendTo: { lobby } ]. cr@(SRP PmrClassReference traits) asNative [ Console ; 'making ' ; cr classSymbol srpWithoutPlaceholder ; ' as native'. cr classSymbol srpIsPlaceholder ifTrue: [ cr classSymbol srpWithoutPlaceholder sendTo: { cr resolveNamespace } ] ifFalse: [ cr classSymbol sendTo: { cr resolveNamespace } ] ]. " How can we interdict this message send in slate? cr@(SRP PmrClassReference traits) classSymbol [ Console ; 'interrupt\n'. 2 ]. " cr@(SRP PmrMetaclassReference traits) asNative [ 'unimplemented' signal ]. so@(SRP PmrArray traits) asNative [ | answer | answer: (Array newSize: so srpIndexableValues size). 0 upTo: (so srpIndexableValues size - 1) do: [ | :index | answer at: index put: (so srpIndexableValueAt: index) ]. answer ]. so@(SRP SubstituteObject traits) srpLoadPostMap: aContext [ "Answer an object that is to represent the receiver when loaded. Keep in mind that slots of the receiver could still contain placeholders around an object that may yet be mapped. Also be aware that when an object references the receiver, and the receiver also references that object, that the slots for that object may not be fully loaded yet." so asNative ]. so@(SRP SubstituteObject traits) applyTo: anObject context: context [ anObject ]. ps@(SRP PmrString traits) applyTo: anObject context: context [ ps newFromString: anObject ]. ps@(SRP PmrSymbol traits) applyTo: anObject context: context [ ps newFromSymbol: anObject ]. ps@(SRP PmrSymbol traits) newFromSymbol: aSymbol [ (ps clone) fromString: (aSymbol as: String) ]. ps@(SRP PmrString traits) fromString: aString [ ps string: aString. ps ]. ps@(SRP PmrString traits) newFromString: aString [ | p | p: (ps clone). p fromString: aString. p ]. lc@(SRP LoadContext traits) classBasedExchange [ "Private. Remap the mappedCurrent using whatever class-based exchange rules are in effect--and perform any mapping on the results of a previous exchange. Answer the object that will take the place of the nativeCurrent object." | attempts mappingRule original | attempts: 0. [ original: lc mappedCurrent baseObject. mappingRule: (lc exchangeRules at: (original printName intern) ifAbsent: [^ (lc mappedCurrent)]). lc mappedCurrent setBaseObject: (mappingRule applyTo: original context: lc). ((lc mappedCurrent printName == original printName) not) ] whileTrue: [ attempts: attempts + 1. attempts > 31 ifTrue: [lc configuration reportError: 'Recursive mapping rules.']. ]. lc mappedCurrent ]. sc@(SRP SaveContext traits) classBasedExchange [ | attempts mappingRule original | attempts: 0. [ original: sc mappedCurrent. " Console ; 'key is ' ; (original printName intern)." mappingRule: (sc exchangeRules at: (original printName intern) ifAbsent: [^ (sc mappedCurrent)]). sc mappedCurrent: (mappingRule applyTo: original context: sc). "Console ; 'applied res ' ; (sc mappedCurrent printName)." ((sc mappedCurrent printName) == (original printName)) not ] whileTrue: [ attempts: attempts + 1. attempts > 31 ifTrue: [sc configuration reportError: 'Recursive mapping rules.']]. sc mappedCurrent ]. sc@(SRP SaveContext traits) newConfiguration: aConfig [ sc initializeConfiguration: aConfig ]. lc@(SRP LoadContext traits) newConfiguration: aConfig [ lc initializeConfiguration: aConfig ]. lc@(SRP LoadContext traits) preMapCommand [ lc configuration loadPreMapCommand ]. lc@(SRP LoadContext traits) postMapCommand [ lc configuration loadPostMapCommand ]. sc@(SRP SaveContext traits) preMapCommand [ sc configuration savePreMapCommand ]. sc@(SRP SaveContext traits) postMapCommand [ sc configuration savePostMapCommand ]. lc@(SRP LoadContext traits) startedToLoad: aPlaceholder [ "Private. Remap anInstance using whatever mapping rules are in effect." lc originalCurrent: aPlaceholder baseObject. lc mappedCurrent: aPlaceholder. ]. sc@(SRP SaveContext traits) exchangeOriginal: anInstance [ sc originalCurrent: (sc mappedCurrent: (anInstance)). sc exchange. sc mappedCurrent ]. sc@(SRP SaveContext traits) applicableExchangeRules [ sc configuration allSaveExchangeRules ]. lc@(SRP LoadContext traits) applicableExchangeRules [ lc configuration allLoadExchangeRules ]. c@(SRP Context traits) initializeConfiguration: aConfig [ c configuration: aConfig. c originalStack: (ExtensibleArray newSize: 10). c mappedStack: (ExtensibleArray newSize: 10). c userData: Nil. "aConfig contextUserData." c initializeExchangeRules. c ]. c@(SRP Context traits) initializeExchangeRules [ | rules | rules: c applicableExchangeRules. c exchangeRules: (IdentityDictionary newSize: rules size). c addExchangeRules: rules ]. ps@(SRP PmrSymbol traits) applicableClassNames [ {('Symbol' intern)} ]. ps@(SRP PmrString traits) applicableClassNames [ {('String' intern)} ]. pa@(SRP PmrArray traits) applicableClassNames [ {('Array' intern)} ]. pf@(SRP PmrFloat traits) applicableClassNames [ "Answer a collection of all class names whose instances are affected by the receiver. The receiver will be applied to all instances of classes named in the list." { #Float. #SingleFloat. } ]. pf@(SRP PmrFloat traits) applyTo: anObject context: c [ pf fromFloat: anObject ]. pf@(SRP PmrFloat traits) numerator: n denominator: d [ pf clone `>> [ numerator: n. denominator: d. ] ]. pf@(SRP PmrFloat traits) fromFloat: aFloat@(SingleFloat traits) [ "Floats are stored like a fraction so as to avoid making assumptions about the structure the float will be loaded into. This aids portability, but some floats can convert to very large fractions: 1234.567 asFraction --> (15432087500000000091/12500000000000000) Loading such integers could be a problem for any programming language with a maximum supported integer size." | array | array: { 3. 2.}. "= self portal floatAsNumeratorAndDenominator: aFloat." pf numerator: (array at: 0) denominator: (array at: 1) ]. c@(SRP Context traits) addExchangeRules: aCollection [ | rules | rules: c exchangeRules. aCollection do: [ |:each | each applicableClassNames do: [ |:native | rules at: native put: each]]. ]. c@(SRP Context traits) isRoot [ c originalStack isEmpty ]. c@(SRP Context traits) pushStack [ "Private. This should not be sent by anything other than the dumper/loader." c originalCurrent isNil ifFalse: [ c originalStack addLast: c originalCurrent. c mappedStack addLast: c mappedCurrent. ]. c originalCurrent: (c mappedCurrent: Nil). ]. c@(SRP Context traits) popStack [ "Private. This should not be sent by anything other than the dumper/loader." c originalStack isEmpty ifFalse: [ c originalCurrent: (c originalStack at: (c originalStack size - 1)). c originalStack removeLast. c mappedCurrent: (c mappedStack at: (c mappedStack size - 1)). c mappedStack removeLast. ]. ]. sc@(SRP SaveContext traits) initializeConfiguration: aConfig [ resend. sc ]. lc@(SRP LoadContext traits) initializeConfiguration: aConfig [ resend. lc ]. os@(SRP ObjectStream traits) position: newPos [ " Set the zero based position of the underlying stream. " os stream position: newPos ]. os@(SRP ObjectStream traits) reset [ "Console ; 'initial pos is ' ; (os initialPosition as: String) ; '\n'." os position: (os initialPosition) ]. os@(SRP ObjectStream traits) makeBinary [ os binary: True. os ]. os@(SRP ObjectStream traits) close [ os stream close ]. os@(SRP ObjectStream traits) on: aStream [ os stream: aStream. os initialPosition: (os previousPosition: (os stream position)). os ]. os@(SRP ObjectStream traits) initializeConfiguration: aConfig [ os config: aConfig. os initialPosition: 0. os binary: True. os metastateTableName: Nil. "aConfig initialMetastateTableName." aConfig beingUsedForObjectStream: os ]. os@(SRP ObjectStream traits) configuration: [ config ]. os@(SRP ObjectStream traits) metastateTableName: metastateTableName [ | newRef | newRef: (metastateTableName isNil ifFalse: [os config newMetastateTableReferenceNamed: metastateTableName]). os metastateTableReference: newRef ]. os@(SRP ObjectStream traits) defaultStream [ (ByteArray newSize: 256) writer " (PositionableReadWriteStream newOn: (ByteArray newSize: 256)) reset" ]. os@(SRP ObjectStream traits) reader [ | reader | os previousPosition: os stream position. reader: ((SRP ObjectLoader clone) newConfiguration: os config). "Console ; ('setting reader stream\n')." reader stream: os stream encodings: (os config initialEncodings). os binary ifFalse: [reader setEncodingType: #Text]. reader ]. os@(SRP ObjectStream traits) writer [ | writer | os stream isNil ifTrue: [os stream: os defaultStream]. os previousPosition: os stream position. writer: ((SRP ObjectSaver clone) newConfiguration: os config). writer stream: os stream encodings: (os config initialEncodings). os metastateTableReference isNil ifFalse: [ writer setMetastateTable: os metastateTableReference ]. writer ]. m@(SRP Marshaler traits) configuration [ m context configuration ]. m@(SRP Marshaler traits) newConfiguration: aConfig [ m initializeConfiguration: aConfig ]. m@(SRP Marshaler traits) stream: aStream encodings: aCollection [ m stream: (aCollection inject: (SRP NativeStreamWrapper on: aStream for: m) into: [ |:last :ea | ea on: last]) ]. os@(SRP ObjectStream traits) next [ os reader next ]. os@(SRP ObjectStream traits) nextPut: anObject [ os writer nextPut: anObject. anObject ]. nsw@(SRP NativeStreamWrapper traits) next [ nsw stream next ]. nsw@(SRP NativeStreamWrapper traits) nextPut: byte [ nsw stream nextPut: byte ]. nsw@(SRP NativeStreamWrapper traits) on: aStream for: aMarshaler [ | wrapper | wrapper: (SRP NativeStreamWrapper clone). wrapper marshaler: aMarshaler. wrapper stream: aStream. wrapper ]. m@(SRP Marshaler traits) initializeConfiguration: aConfig [ m classTable: aConfig newMetastateTable. m hitSequence: (ExtensibleArray newSize: aConfig initialObjectsExpectedBufferSize). m finishingActions: (ExtensibleArray newSize: aConfig initialFinishingActionsBufferSize) ]. ol@(SRP ObjectLoader traits) initializeConfiguration: aConfig [ resend. ol context: aConfig newLoadContext. aConfig beingUsedForObjectLoader: ol ]. ol@(SRP ObjectLoader traits) next [ ol configuration loaded: (ol loadObject) using: ol ]. ol@(SRP ObjectLoader traits) processFinishingActions [ "Private. Finishing actions are processed after the root object is completely loaded or saved. Anything that responds to #value can be used as a finishing action." ol configuration processPostLoadActions: ol finishingActions for: ol. "ol stream srpFinishByteGroupRead." ]. ol@(SRP ObjectLoader traits) loadAvoid [ Nil ]. ol@(SRP ObjectLoader traits) loadObject [ "Load the next object on the stream and perform any post load processing." | placeholder | "Console ; ('loading state \n')." placeholder: ol loadState. "Console ; ('loaded state \n'). placeholder printOn: (Console writer). " ol processFinishingActions. "placeholder printOn: (Console writer)." (placeholder srpIsPlaceholder ifTrue: [placeholder srpStripPlaceholders] ifFalse: [placeholder]) ]. ol@(SRP ObjectLoader traits) startedToLoad: anInstance [ "Private. Answer anInstance with a placeholder around it. Relative pointers as well as object slot pointers will point to the placeholder instead of directly to anInstance. This allows anInstance to be replaced without losing pointers that were to anInstance." | aPlaceholder | aPlaceholder: (ol configuration usePlaceholders ifTrue: [ ol configuration newPlaceholderFor: anInstance atLoaderIndex: ol hitSequence size + 1 ] ifFalse: [ anInstance ]). ol hitSequence addLast: aPlaceholder. ol context startedToLoad: aPlaceholder. ^ aPlaceholder ]. ol@(SRP ObjectLoader traits) attemptDiscardOfPlaceholder: mutatedObjectPlaceholder [ "Private. The placeholder can be removed at this stage under certain circumstances. Answer mutatedObject without the load placeholder if it is safe to do so." mutatedObjectPlaceholder srpIsPlaceholder ifFalse: [^ mutatedObjectPlaceholder]. mutatedObjectPlaceholder srpCanDiscard ifFalse: [^ mutatedObjectPlaceholder]. ol hitSequence at: (mutatedObjectPlaceholder srpLoaderIndex - 1) put: mutatedObjectPlaceholder srpBaseObject. ^ (mutatedObjectPlaceholder srpBaseObject) ]. ol@(SRP ObjectLoader traits) loadActionsFor: aPlaceholder [ "Private. Do anything that should be done to an object just after it has been loaded, but prior to the root object being completely loaded." | answer postLoadAction | ol context mappedCurrent == aPlaceholder ifFalse: [error: 'Assertion check failed when loading an object.']. answer: ol context exchange. postLoadAction: (ol configuration postLoadActionFor: answer loader: ol). postLoadAction isNil ifTrue: [ ^ (ol attemptDiscardOfPlaceholder: answer) ]. "Console ; 'adding post load action \n'." ol finishingActions add: postLoadAction. answer ]. ol@(SRP ObjectLoader traits) loadState [ "Private. Sent when loading objects referenced from a root object. Leaves any required load placeholder in place for post load processing." | classCodeOrZero aPlaceholder loadClassResponse | [(classCodeOrZero: ol loadUnsigned) = 0] whileTrue: [ ((loadClassResponse: ol loadMarshalDirective) == ol signalIgnoreLoad) ifFalse: [ ^ loadClassResponse ]. ]. "Console ; 'getting metastate ' ; (classCodeOrZero as: String) ; '\n'." aPlaceholder: ((ol classTable metastateForCode: classCodeOrZero) loadInstanceUsing: ol). ol loadActionsFor: aPlaceholder ]. ms@(SRP Metastate traits) newMapTable [ | destination | (destination: ms asBehavior) == ms ifTrue: [ ^ (1 to: ms instSize)]. ms newTableMapping: ms allInstVarNames to: (ms asBehavior slotNames select: [ |:ea| ea ~= #traitsWindow]) ]. ms@(SRP Metastate traits) newTableMapping: oldNames to: newNames [ | answer | answer: (Array newSize: oldNames size). 0 upTo: (oldNames size - 1) do: [ | :i | answer at: i put: (newNames indexOf: (oldNames at: i) ifAbsent: [ Nil ]). ]. answer ]. ms@(SRP Metastate traits) getMapTable [ (ms mapTable) ifNil: [ ms mapTable: ms newMapTable ]. ms mapTable ]. ms@(SRP Metastate traits) asBehavior [ "Answer the behavior (class) residing in the current object space that is resolved using behaviorName. The behavior instance variable is used as a cache to improve load performance." | resident | Console ; 'getting behavior for name ' ; ms behaviorName ; '\n'. ms behavior isNil ifTrue: [ (ms behaviorName last = 'PmrArray') ifTrue: [ ^ (SRP PmrArray) ]. (ms behaviorName last = 'PmrString') ifTrue: [ ^ (SRP PmrString) ]. (ms behaviorName last = 'PmrFloat') ifTrue: [ ^ (SRP PmrFloat) ]. (ms behaviorName last = 'PmrSymbol') ifTrue: [ ^ (SRP PmrSymbol) ]. (ms behaviorName last = 'PmrNamespaceReference') ifTrue: [ ^ (SRP PmrNamespaceReference) ]. (ms behaviorName last = 'PmrClassReference') ifTrue: [ ^ (SRP PmrClassReference) ]. (ms behaviorName last = 'PmrMetaclassReference') ifTrue: [ ^ (SRP PmrMetaclassReference) ]. [ resident: ((ms behaviorName last intern) sendTo: { prototypes }). ] on: (MethodNotFound) do: [ | :x | x exit: Nil ]. resident isNil ifTrue: [ ms ignoreResidentBehavior ] ifFalse: [ ms behavior: resident ]. ]. ms behavior ]. ms@(SRP Metastate traits) ignoreResidentBehavior [ ms behavior: ms ]. ms@(SRP Metastate traits) srpNew: anInteger [ "Answer an instance of the receiver with anInteger number of indexable slots (either variables or bytes depending on the receiver's type). Error if the receiver does not allow variable length instances. Do not override this method." SRP State new: anInteger metastate: ms ]. s@(SRP State traits) new: anInteger metastate: ms [ (s clone) `>> [ metastate: ms. namedValues: (Array newSize: ms instSize). indexableValues: (Array newSize: anInteger). ] ]. s@(SRP State traits) srpIndexableValueAt: index put: anObject [ s indexableValues at: index put: anObject ]. ms@(SRP Metastate traits) loadInstanceUsing: aLoader [ "Create an instance for the receiver and then load the contents of the anInstance from aLoader." | anInstance isVarLength aPlaceholder containsPlaceholders mappingTable inst loadSelector loadedObject mappedIndex indexableSize | " Console ; 'load instance using \n'." ms instanceShape isStateless ifTrue: [ inst: ms asBehavior srpNew. inst: (aLoader startedToLoad: inst). inst srpCanDiscard: True. ^ inst ]. ms instanceShape isSelfTyped ifTrue: [ inst: ( ms primaryLoadingSelector sendTo: {aLoader}). inst: (aLoader startedToLoad: inst). inst srpCanDiscard: True. ^ inst ]. anInstance: ((isVarLength: ms isVariable) ifTrue: [ ms asBehavior srpNew: (indexableSize: aLoader loadUnsigned) ] ifFalse: [ ms asBehavior srpNew ]). aPlaceholder: (aLoader startedToLoad: anInstance). aLoader context pushStack. containsPlaceholders: False. "Load indexed variables -- if there are any." isVarLength ifTrue: [ loadSelector: ms primaryLoadingSelector. 0 upTo: (indexableSize - 1) do: [ | :indexedVarIndex | loadedObject: ( loadSelector sendTo: {aLoader}). anInstance srpIndexableValueAt: indexedVarIndex put: loadedObject. containsPlaceholders: (loadedObject srpIsPlaceholder or: [containsPlaceholders]) ]. ]. "Load named variables -- if there are any." mappingTable: ms getMapTable. 1 upTo: ms instSize do: [ |:instVarIndex | loadSelector: ((ms storeTypeArrays at: (ms namedStoreTypeCodes at: (instVarIndex - 1))) at: 2). loadedObject: (loadSelector sendTo: {aLoader}). Console ; 'setting ' ; (ms allInstVarNames at: (instVarIndex - 1)) ; ' for ' ; (anInstance printName) ; ' on ' ; (loadedObject printName) ; '\n'. ((ms allInstVarNames at: (instVarIndex - 1)) ; ':') intern sendTo: { anInstance. loadedObject.}. ]. aPlaceholder srpCanDiscard: containsPlaceholders not. aLoader context popStack. aPlaceholder ]. ol@(SRP ObjectLoader traits) loadBoolean [ ol loadUnsigned ~= 0 ]. ol@(SRP ObjectLoader traits) loadSigned [ "Save an integer from zero to negative or positive infinity. The least significant bit of the number is ON if the value is a negative number." | unsigned | unsigned: ol loadUnsigned. ^ (unsigned \\ 2 = 0 ifTrue: [ unsigned // 2 ] ifFalse: [ (unsigned // 2) negated ]) ]. ol@(SRP ObjectLoader traits) loadUnsigned [ "Load an unsigned integer (a whole number) from zero to positive infinity. Performance is greatly affected by this method. This is a good candidate for a primitive." | answer shifter atLast readValue | answer: 0. shifter: 1. [ atLast: ((readValue: ((ol stream next) as: Integer)) // 128) = 0. atLast ifFalse: [ readValue: readValue - 128 ]. answer: answer + (readValue * shifter). shifter: shifter * 128. atLast ] whileFalse: []. answer ]. ol@(SRP ObjectLoader traits) loadMarshalDirective [ "A marshal directive is a special command intended for the marshaler itself. It is indicated by a class code of zero followed by the directive number." | directiveNumber | directiveNumber: ol loadUnsigned. directiveNumber = 0 ifTrue: [ ^ (ol specialOperationSignal) ]. ^ ((ol marshalDirectiveLoadArray at: (directiveNumber - 1)) sendTo: { ol }). ]. "Answer an array of selectors that is used to fetch the selector to be performed for a marshal directive code." ol@(SRP ObjectLoader traits) marshalDirectiveLoadArray [ ^ { #loadRelativeOffset. #loadMetastate. #loadSkipBytes. #loadSkipObject. #loadMetastateTableReference. #loadMetastateTableName. #loadEncodingVersion. #loadStateExtended. } ]. ol@(SRP ObjectLoader traits) loadRelativeOffset [ "Private. Load a reference to an object that already started loading. The offset index position of the object is relative to the index position of the object currently being loaded rather than relative to the index position of the root object." | offsetOrZero | (offsetOrZero: ol loadUnsigned) = 0 ifTrue: [ ^ (ol configuration reportError: 'Unexpected relative offset load.') ]. ol hitSequence at: (ol hitSequence size - offsetOrZero) ]. ol@(SRP ObjectLoader traits) loadMetastate [ "Metastates describe data so it can be loaded. It is one of the few data structures directly written by SRP instead of stored as an object that can be mapped." | aMetastate | aMetastate: ol basicLoadMetastate. ol context postMapCommand applyWith: aMetastate with: ol context. ol signalIgnoreLoad ]. ol@(SRP ObjectLoader traits) signalIgnoreLoad [ "Answer an object that can be given to tell the loader to ignore the last object that was loaded." #SrpIgnoreLoadSignal ]. ol@(SRP ObjectLoader traits) basicLoadMetastate [ "Metastates describe data so it can be loaded. It is one of the few data structures directly written by SRP instead of stored as an object that can be mapped." | classCodeOrZero classDef shapeCode namePath | (classCodeOrZero: ol loadUnsigned) = 0 ifTrue: [ ^ (ol configuration reportError: 'Unexpected class code.' )]. shapeCode: ol loadUnsigned. namePath: ol loadCharacterArrayArray. "1 to: namePath size do: [:i | namePath at: i put: (namePath at: i) asSymbol ]." namePath printOn: Console writer. classDef: ((SRP Metastate) code: classCodeOrZero shapeCode: shapeCode behaviorName: namePath). classDef hasVersionNumberArray ifTrue: [ classDef versionNumberArray: ol loadUnsignedArray. ]. classDef hasNamedSlots ifTrue: [ classDef allInstVarNames: (ol loadCharacterArrayArray). "Console ; 'loaded inst var names ' ; (classDef allInstVarNames size as: String) ; '\n'." classDef hasTypedNamedSlots ifTrue: [ "Console ; 'loading name store type codes\n'." classDef namedStoreTypeCodes: ol loadUnsignedArray. ]. ]. ol classTable atCode: classDef code putMetastate: classDef. " Console ; 'put metastate code ' ; (classDef code as: String) ; ' name ' ; (classDef behaviorShortName) ; '\n'." classDef hasExtendedAttributes ifTrue: [ Console ; 'has ext att\n'. classDef extendedAttributes: ol loadObject. ]. classDef ]. " SRP Configuration default saveObject: 1.5 toBinaryFilename: '/home/jewel/float'. SRP Configuration default loadObjectFromBinaryFilename: '/home/jewel/float'. SRP Configuration default saveObject: 'ABC' toBinaryFilename: '/home/jewel/abc'. SRP Configuration default loadObjectFromBinaryFilename: '/home/jewel/abc'. " ol@(SRP ObjectLoader traits) loadCharacter [ ol loadUnsigned as: Character ]. ol@(SRP ObjectLoader traits) loadString [ "Load a collection of characters to be loaded in the native single or double byte string class." | stringSize answer isOneByte int chr | stringSize: ol loadSigned. stringSize < 0 ifTrue: [ ^ (ol loadStringNumLines: stringSize negated)]. answer: (String newSize: stringSize). isOneByte: True. 0 upTo: (stringSize - 1) do: [ |:index | chr: ((int: ol loadUnsigned) as: Character). (isOneByte and: [int > 16rFF]) ifTrue: [ isOneByte: False. answer: = SrpPortal stringAsTwoByteString: answer. ]. answer at: index put: chr. ]. answer ]. ol@(SRP ObjectLoader traits) loadUnsignedArray [ "Load an array of unsigned integers." | answerSize answer | answerSize: ol loadUnsigned. answer: (Array newSize: answerSize). 0 upTo: (answerSize - 1) do: [ |:index | answer at: index put: ol loadUnsigned ]. answer ]. ol@(SRP ObjectLoader traits) loadCharacterArrayArray [ "Answer an array of strings. Similar to #loadStringArray, but stored in an encoding that is more space efficient by at least one byte when array typically contains fewer than 64 items." | namesCount stringSize answer string | stringSize: ol loadSigned. stringSize < 0 ifTrue: [ namesCount: stringSize negated. stringSize: ol loadUnsigned ] ifFalse: [ namesCount: 1 ]. answer: (Array newSize: namesCount). 0 upTo: (namesCount - 1) do: [ |:nameIndex | string: (String newSize: stringSize). 0 upTo: (stringSize - 1) do: [ |:stringIndex | string at: stringIndex put: ((ol loadUnsigned) as: Character). ]. answer at: nameIndex put: string. nameIndex < (namesCount - 1) ifTrue: [ stringSize: ol loadUnsigned ]. ]. answer ]. os@(SRP ObjectSaver traits) initializeConfiguration: aConfig [ resend. os hitList: aConfig newHitList. os duplicationTypes: (aConfig duplicationTypes as: Set). os context: aConfig newSaveContext. aConfig beingUsedForObjectSaver: os ]. os@(SRP ObjectSaver traits) nextPut: anObject [ os saveObject: anObject. os configuration saved: anObject using: os. anObject ]. os@(SRP ObjectSaver traits) saveObject: anObject [ os saveState: anObject " os context encodingVersion > 0" ]. os@(SRP ObjectSaver traits) saveAvoid: anObject [ ^ os ]. os@(SRP ObjectSaver traits) saveBoolean: aBoolean [ os saveUnsigned: (aBoolean ifTrue: [1] ifFalse: [0]) ]. os@(SRP ObjectSaver traits) saveUnsigned: anInteger [ | writeValue carry | carry: (anInteger as: Integer). [writeValue: (carry rem: 128). (carry: (carry quo: 128)) = 0] whileFalse: [ os stream nextPut: writeValue + 128]. os stream nextPut: writeValue. ]. os@(SRP ObjectSaver traits) relativeOffsetOfSaveObject: anObject [ | idx | idx: (os hitList at: anObject ifAbsent: []). idx isNil ifTrue: [^ Nil]. os hitSequence size - idx + 1 ]. os@(SRP ObjectSaver traits) shouldSaveRelativeOffsetTo: anObject [ "You would usually want to save a reference to a previously saved object, but there are special circumstances in which you wouldn't. If mapping rules exchange an object, and the new object references the original (recursion), then you may want to now save the original object rather than a reference to the new object." | mappedRecursive | (mappedRecursive: (os context recursiveMappingFor: anObject)) isNil ifTrue: [^ True]. mappedRecursive srpRecursiveReferencesShouldReferenceMapped ]. os@(SRP ObjectSaver traits) saveRelativeOffset: relativeOffset [ "Private. A marshal directive to refer to an object that has already been saved." os saveUnsigned: 0. "Marshal directive" os saveUnsigned: 1. "Marshal directive code" os saveUnsigned: relativeOffset. ]. os@(SRP ObjectSaver traits) noteAndExchange: anObject [ | allowDuplicates relativeOffset saveObject | (allowDuplicates: (os duplicationTypes includes: anObject printName)) ifFalse: [ relativeOffset: (os relativeOffsetOfSaveObject: anObject)]. (relativeOffset isNil not and: [ os shouldSaveRelativeOffsetTo: anObject]) ifTrue: [ os saveRelativeOffset: relativeOffset. ^ #SRP_FLAG_SAVED_RELATIVE_OFFSET]. os hitSequence addLast: anObject. relativeOffset isNil not ifTrue: [ saveObject: anObject]. ifFalse: [ (anObject isNil \/ allowDuplicates) ifFalse: [ os hitList at: anObject put: os hitSequence size]. saveObject: (os context exchangeOriginal: anObject). (saveObject == anObject) not ifTrue: [ saveObject isNil \/ allowDuplicates ifFalse: [ os hitList at: saveObject put: os hitSequence size]]]. saveObject ]. os@(SRP ObjectSaver traits) saveCharacter: aCharacter [ os saveUnsigned: (aCharacter as: Integer). ]. os@(SRP ObjectSaver traits) saveSigned: anInteger [ | int | int: (anInteger as: Integer). int < 0 ifTrue: [ os saveUnsigned: (int negated * 2) + 1] ifFalse: [ os saveUnsigned: int * 2]. ]. os@(SRP ObjectSaver traits) saveCharacterArray: aString [ | str | str: (aString as: String). os saveSigned: (str size). 0 to: (str size - 1) do: [ |:i| os saveCharacter: (str at: i)] ]. os@(SRP ObjectSaver traits) saveUnsignedArray: anArray [ os saveUnsigned: anArray size. anArray do: [|:anInteger| os saveUnsigned: anInteger]. ]. os@(SRP ObjectSaver traits) saveCharacterArrayArray: anArray [ | str | (1 = anArray size) ifTrue: [ os saveSigned: anArray last size] ifFalse: [ os saveSigned: anArray size negated. os saveUnsigned: anArray first size. ]. 0 upTo: (anArray size - 1) do: [ |:nameIndex | str: (anArray at: nameIndex). 0 upTo: (str size - 1) do: [ |:i| os saveCharacter: (str at: i)]. nameIndex < (anArray size - 1) ifTrue: [os saveUnsigned: (anArray at: nameIndex + 1) size] ]. ]. os@(SRP ObjectSaver traits) saveMetastate: initialClassDef [ | classDef | classDef: initialClassDef. os saveUnsigned: 0. os saveUnsigned: 2. os saveUnsigned: classDef code. os saveUnsigned: classDef shapeCode. os saveCharacterArrayArray: (classDef behaviorName). (classDef versionNumberArray isNil not) ifTrue: [os saveUnsignedArray: classDef versionNumberArray]. classDef hasNamedSlots ifTrue: [ os saveCharacterArrayArray: classDef allInstVarNames. classDef hasTypedNamedSlots ifTrue: [ os saveUnsignedArray: classDef namedStoreTypeCodes]]. "classDef hasExtendedAttributes ifTrue: [self saveObject: classDef extendedAttributes]." " initialClassDef srpSavedAs: classDef." classDef ]. os@(SRP ObjectSaver traits) savedMetastateForType: type [ | classDef | classDef: (os classTable metastateForType: type). classDef ifNil: [ classDef: (os classTable addMetastate: (os configuration newMetastateForType: type)). os saveMetastate: classDef]. classDef ]. c@(Root traits) srpSavedAs: _ [ c ]. x@(Root traits) srpRecursiveReferencesShouldReferenceMapped [ "An original object has been mapped to the receiver, and while saving the receiver there was a reference to the original object. Answer true (the default) if a reference to the mapped object should be saved, or false if the original object should be serialized without remapping. This method should only be overridden to answer false for instances that are only meant for mapping operations--not normal kernel instances." True ]. r@(Root traits) srpSavePreMap: aContext [ "Answer an object that is to represent the receiver when saved. This is sent before class-based save mapping rules are applied." r "Do nothing by default." ]. r@(Root traits) srpSavePostMap: aContext [ r ]. r@(Root traits) srpLoadPreMap: aContext [r]. r@(Root traits) srpLoadPostMap: aContext [r]. os@(SRP ObjectSaver traits) saveState: anObject [ | classDef saveObject| os context pushStack. saveObject: (os noteAndExchange: anObject). saveObject == #SRP_FLAG_SAVED_RELATIVE_OFFSET ifFalse: [ classDef: (os savedMetastateForType: saveObject). classDef saveInstance: saveObject using: os. anObject srpSavedAs: saveObject]. os context popStack ]. os@(SRP ObjectSaver traits) saveString: n@Nil [ os saveCharacterArray: 'Nil'. ]. os@(SRP ObjectSaver traits) saveString: aString [ | str | str: (aString as: String). os saveCharacterArray: str. ]. ms@(SRP Metastate traits) initializeCache [ ms mapTable: Nil. ]. ms@(SRP Metastate traits) extendedAttributes [ "Answer nil or an object that is saved and loaded as an object along with a metastate. The for simplicity, object is expected to conform to basic Smalltalk dictionary protocol. Attributes are associated to avoid potential recursion problems while saving or loading metastate." ms extendedAttributes ]. ms@(SRP Metastate traits) srpLoadPostMap: aContext [ "Notification that the receiver was loaded." ms initializeCache. (ms extendedAttributes isNil not and: [ms asBehavior isNil not]) ifTrue: [ aContext configuration extendedAttributesFor: ms asBehavior are: ms extendedAttributes ]. " aContext configuration loadedMetastate: ms context: aContext." ]. ms@(SRP Metastate traits) shapeCode: anInteger [ ms instanceShape integer: anInteger ]. ms@(SRP Metastate traits) hasVersionNumberArray [ ms instanceShape hasVersionNumberArray ]. ms@(SRP MetastateShape traits) hasVersionNumberArray [ "A version number array is application defined data stored with a metastate. Answer boolean whether a version number array has been set. Bit 14" ms integerAllMask: 2r10000000000000 ]. ms@(SRP Metastate traits) code: classCode shapeCode: shapeCode1 behaviorName: behaviorName1 [ ms clone `>> [ initialize. code: classCode. shapeCode: shapeCode1. behaviorName: behaviorName1.] ]. ms@(SRP Metastate traits) primaryLoadingSelector [ (ms storeTypeArrays at: ms instanceShape primaryStoreTypeCode) at: 2 ]. ms@(SRP Metastate traits) primarySavingSelector [ (ms storeTypeArrays at: ms instanceShape primaryStoreTypeCode) at: 1 ]. ms@(SRP Metastate traits) instSize [ ms allInstVarNames size ]. ms@(SRP Metastate traits) behaviorShortName [ ms behaviorName last ]. ms@(SRP Metastate traits) hasExtendedAttributes [ False ]. ms@(SRP Metastate traits) saveInstance: anInstance using: aSaver [ | savingSelector | aSaver saveUnsigned: ms code. ms instanceShape isStateless ifTrue: [ ^ ms]. (ms instanceShape isSelfTyped and: [aSaver context isRoot not or: [(ms primaryStoreType == #Distinct) not]]) ifTrue: [ (ms primarySavingSelector) sendTo: { aSaver. anInstance}. ^ ms]. ms isVariable ifTrue: [ aSaver saveUnsigned: (anInstance srpIndexableSize). savingSelector: ms primarySavingSelector. 0 upTo: (anInstance srpIndexableSize - 1) do: [ |:indexedVarIndex | savingSelector sendTo: { aSaver. (anInstance srpIndexableValueAt: indexedVarIndex)}]]. 0 upTo: (ms instSize - 1) do: [ |:instVarIndex | savingSelector: ((ms storeTypeArrays at: (ms namedStoreTypeCodes at: instVarIndex)) at: 1). savingSelector sendTo: {aSaver. (anInstance slotValues at: (instVarIndex + 1)).}]. ]. ph@(SRP Placeholder traits) srpBaseObject [ ph baseObject ]. ph@(SRP Placeholder traits) srpLoadPostMap: aContext [ "Answer an object that is to represent the receiver when loaded. Keep in mind that slots of the receiver could still contain placeholders around an object that may yet be mapped. Also be aware that when an object references the receiver, and the receiver also references that object, that the slots for that object may not be fully loaded yet." "Because this is a placeholder, the baseObject can be changed locally, and all references to the placeholder will not be affected." ph baseObject: (ph baseObject srpLoadPostMap: aContext). "Answer the receiver because you don't want to lose the placeholder behavior." ph ]. ph@(SRP Placeholder traits) srpStripPlaceholders [ "Private protocol. This is a recursive method that is used to cleanup all the placeholders used for correctly resolving changing object pointers when loading objects. This should only be done after an entire persistent object has been loaded. To do otherwise may leave some unmutated objects." ph srpStripPlaceholders: (IdentitySet newSize: 1) ]. x@(Root traits) srpStripPlaceholders: recursionSet [ "Private protocol. This is used to cleanup placeholders used for correctly resolving changing object pointers when loading objects. THIS non-recursive method is only run because the receiver has been mutated while loading. This was necessary to prevent rare problems doing special mutations to recursive structures." | item | (recursionSet includes: x) ifTrue: [ ^ x]. recursionSet add: x. ((x slotNames) select: [ |:ea| ea ~= #traitsWindow]) do: [ |:slotName| item: ( slotName sendTo: {x}). item srpIsPlaceholder ifTrue: [ (slotName ; ':') sendTo: { x. (item srpStripPlaceholders: recursionSet). }. ]. ]. x srpHasIndexableValues ifTrue: [ 0 upTo: (x srpIndexableSize - 1) do: [ |:indexedVarIndex| item: (x srpIndexableValueAt: 1). (item srpIsPlaceholder) ifTrue: [ x srpIndexableValueAt: indexedVarIndex put: (item srpStripPlaceholders: recursionSet). ]. ]. ]. x ]. ph@(SRP Placeholder traits) srpStripPlaceholders: recursionSet [ "Private protocol. This is a recursive method that is used to cleanup all the placeholders used for correctly resolving changing object pointers when loading objects." | item newItem | (recursionSet includes: ph) ifTrue: [ ^ (ph baseObject)]. recursionSet add: ph. ((ph baseObject slotNames) select: [ |:ea| ea ~= #traitsWindow]) do: [ |:slotName| item: ( slotName sendTo: {ph baseObject}). (item srpIsPlaceholder or: [ph srpWasMutated]) ifTrue: [ newItem: (item srpStripPlaceholders: recursionSet). item == newItem ifFalse: [ (slotName ; ':') sendTo: { ph baseObject. newItem.} ]. ]. ]. (ph baseObject srpHasIndexableValues) ifTrue: [ 0 upTo: (ph baseObject size - 1) do: [ | :indexedVarIndex | item: (ph baseObject srpIndexableValueAt: indexedVarIndex). (item srpIsPlaceholder or: [ph srpWasMutated]) ifTrue: [ newItem: (item srpStripPlaceholders: recursionSet). item == newItem ifFalse: [ ph baseObject srpIndexableValueAt: indexedVarIndex put: newItem]. ]. ]. ]. ph baseObject ]. ph@(SRP Placeholder traits) srpWasMutated [ "Private protocol." (ph baseObject == ph memento) not ]. ph@(SRP Placeholder traits) newFor: anObject [ ph clone `>> [ setBaseObject: anObject.] ]. sym@(Symbol traits) srpPostLoadActionForLoader: aMarshaler [ [ sym name intern ] ]. ph@(SRP Placeholder traits) srpPostLoadActionForLoader: aMarshaler [ "Answer a command (directed message or block) that will answer an object to take the place of the receiver when sent #value. The command will be sent #value after the root object has been completely loaded. Answer nil if no further processing is required." | actionOrNil | actionOrNil: (ph baseObject srpPostLoadActionForLoader: aMarshaler). actionOrNil isNil ifTrue: [ ^ Nil]. SRP ActionItem forPlaceholder: ph action: actionOrNil ]. ai@(SRP ActionItem traits) forPlaceholder: aPlaceHolder action: newaction [ ai clone `>> [ placeholder: aPlaceHolder. baseObject: aPlaceHolder srpWithoutPlaceholder. action: newaction.] ]. ai@(SRP ActionItem traits) do [ | answer | answer: ai action do. ai baseObject == ai placeholder srpWithoutPlaceholder ifTrue: [ ai placeholder baseObject: answer ]. ai ]. x@(Root traits) srpWithoutPlaceholder [ x ]. ph@(SRP Placeholder traits) srpWithoutPlaceholder [ "This can be sent by mapping rules and in #srpLoaded when it is necessary to ensure an object is not wrapped by a placeholder when loading. If you ever end up with a placeholder after loading and mapping is completely finished then this wasn't sent when it should have been. " ph baseObject ]. ph@(SRP Placeholder traits) setBaseObject: anObject [ ph memento: (ph baseObject: anObject) ]. ph@(SRP Placeholder traits) srpCanDiscard [ ph canDiscard == True ]. ph@(SRP Placeholder traits) srpCanDiscard: bool [ ph canDiscard: bool ]. ph@(SRP Placeholder traits) srpLoaderIndex [ ph loaderIndex ]. ph@(SRP Placeholder traits) srpLoaderIndex: loaderBackpointerIndexPos [ ph loaderIndex: loaderBackpointerIndexPos ]. c@(SRP Configuration traits) postLoadActionFor: loadedObject loader: aMarshaler [ "All loaded objects go through here. This is an opportunity for a configuration to declare actions to be taken with objects after the traversal has been completely loaded, but before load placeholders are stripped. Answer nil if no action is necessary; otherwise answer an object that responds to #value and answers an object to take the place of the loadedObject." loadedObject srpPostLoadActionForLoader: aMarshaler ]. c@(SRP Configuration traits) processPostLoadActions: finishingActions for: aLoader [ "Finishing actions are processed after the root object is completely loaded or saved. Anything that responds to #value can be used as a finishing action." finishingActions do: [ | :ea | ea do ]. ]. c@(SRP Configuration traits) newPlaceholderFor: anObject atLoaderIndex: index [ (SRP Placeholder newFor: anObject) `>> [ srpLoaderIndex: index.] ]. c@(SRP Configuration traits) usePlaceholders [ "Answer boolean whether placeholders should be used to maintain reference integrity of objects exchanged with others while loading. You would normally want to do this, but there are cases where it is safe to not use them and doing without them would load faster." True "One scenario to watch out for is the case where an object containing a reference to itself is exchanged for another object. If you don't use placeholders then the reference will still point to the old 'self' rather than the new 'self'." ]. c@(SRP Configuration traits) saved: anObject using: os [ ]. c@(SRP Configuration traits) newMetastateForType: type [ SRP Metastate newLikeType: type configuration: c ]. mss@(SRP MetastateShape traits) isStateless [ (mss integer bitAnd: 15) = 0 ]. mss@(SRP MetastateShape traits) isSelfTyped [ (mss integer bitAnd: 7) = 1 ]. mss@(SRP MetastateShape traits) isNamed [ mss integerAllMask: 2 ]. mss@(SRP MetastateShape traits) setBit: index [ mss integer: (mss integer bitOr: (1 bitShift: index - 1)) ]. mss@(SRP MetastateShape traits) clearBit: index [ mss integer: ( mss integer bitAnd: (1 bitShift: index - 1) bitInvert) ]. mss@(SRP MetastateShape traits) isTyped: aBool [ aBool ifTrue: [ mss setBit: 1] ifFalse: [mss clearBit: 1] ]. mss@(SRP MetastateShape traits) isTyped [ mss integerAllMask: 2r1 ]. mss@(SRP MetastateShape traits) integerAllMask: anInteger [ anInteger = (mss integer bitAnd: anInteger) ]. mss@(SRP MetastateShape traits) initialize [ mss integer: 0. mss ]. ms@(SRP Metastate traits) hasNamedSlots [ ms instanceShape isNamed ]. ms@(SRP Metastate traits) hasTypedNamedSlots [ ms instanceShape isTyped and: [ ms instanceShape isNamed ] ]. ms@(SRP Metastate traits) initialize [ ms instanceShape: ms newShapeDefinition. ms allInstVarNames: {}. ms ]. ms@(SRP Metastate traits) isVariable [ ms instanceShape isIndexed ]. ms@(SRP Metastate traits) shapeCode [ ms instanceShape integer ]. ms@(SRP Metastate traits) newShapeDefinition [ SRP MetastateShape clone initialize ]. ms@(SRP Metastate traits) newLikeType: type configuration: config [ ms clone `>> [ initialize. conformTo: type configuration: config. ] ]. ms@(SRP Metastate traits) defaultPrimaryStoreTypeForClass: type [ "The primary store type applies to either indexed slots of an object or to the entire object. For most objects the primary store type is #State. The default store type is overridden by type declarations in #srpDataTypeMap for each class of object." ((type printName = 'Symbol') \/ (type printName = 'String')) ifTrue: [ ^#Byte ]. ^#State " (SrpPortal behaviorIsPointers: type) ifTrue: [^#State]. (SrpPortal behaviorIsBytes: type) ifTrue: [^#Byte]. ^#Unsigned" ]. ms@(SRP Metastate traits) primaryStoreType [ (ms storeTypeArrays at: ms instanceShape primaryStoreTypeCode + 1) at: 1 ]. ms@(SRP Metastate traits) primaryStoreType: aSymbol [ ms instanceShape primaryStoreTypeCode: (ms storeTypeCodeForType: aSymbol) ]. ms@(SRP Metastate traits) namedStoreTypeCodes: anArray [ "Specify an array of store type codes with one code for each named instance variable." ms namedStoreTypeCodesCollection: anArray ]. ms@(SRP Metastate traits) namedStoreTypeCodes [ ms namedStoreTypeCodesCollection isNil ifTrue: [ms namedStoreTypeCodesCollection: (ms allInstVarNames collect: [|:ea | 0])]. ms namedStoreTypeCodesCollection ]. i@(Integer traits) bitInvert [ -1 - i ]. ms@(SRP Metastate traits) storeTypeCodeForType: typeName [ | arrays lim | arrays: ms storeTypeArrays. lim: arrays size. 1 to: (lim - 1) do: [ | :arrayIndex | (typeName == ((arrays at: arrayIndex) at: 0)) ifTrue: [^ (arrayIndex )]. ]. 0 ]. ms@(SRP MetastateShape traits) primaryStoreTypeCode [ (ms integer bitShift: -4) bitAnd: 15 ]. ms@(SRP MetastateShape traits) primaryStoreTypeCode: anInteger [ anInteger > 15 ifTrue: [ error ]. ms integer: (anInteger bitShift: 4) + (ms integer bitAnd: 240 bitInvert) ]. ms@(SRP Metastate traits) storeTypeArrays [ "Only add to the bottom of this array to avoid breaking backward compatibility." { {#State. #saveState:. #loadState}. {#Unsigned. #saveUnsigned:. #loadUnsigned}. {#Character. #saveCharacter:. #loadCharacter}. {#Signed. #saveSigned:. #loadSigned}. {#Byte. #saveByte:. #loadByte}. {#String. #saveString:. #loadString}. {#CharacterArray. #saveCharacterArray:. #loadCharacterArray}. {#CharacterArrayArray. #AAAB. #AAAC}. {#ByteArray. #AABB. #AAAC}. {#Boolean. #saveBoolean:. #loadBoolean}. {#StringArray. #AADB. #AAAC}. {#UnsignedArray. #saveUnsignedArray:. #loadUnsignedArray}. {#Proxy. #AAEB. #AAAC}. {#Nil. #saveAvoid:. #loadAvoid}. {#Distinct. #saveDistinct:. #loadDistinct}. } ]. ms@(SRP Metastate traits) conformTo: aClass configuration: config [ | typeMap primaryStoreType selfTyped slotIndex | ms behaviorName: {aClass printName}. (aClass == True) ifTrue: [ ms behaviorName: {'True'}. ]. (aClass == False) ifTrue: [ ms behaviorName: {'False'}. ]. ms instanceShape initialize. ms allInstVarNames: ( (aClass slotNames) select: [ |:ea| ea ~= #traitsWindow]). typeMap: aClass srpDataTypeMap. primaryStoreType: (ms defaultPrimaryStoreTypeForClass: aClass). selfTyped: False. typeMap do: [ | :array | (array at: 1) isNil ifTrue: [ ms allInstVarNames: (ms allInstVarNames reject: [ | :stringOrSymbol | ((array at: 0) intern) = (stringOrSymbol intern)])] ifFalse: [ms instanceShape isTyped: True.]. ((array at: 0) == #self or: [(array at: 0) == #IndexableType]) ifTrue: [ primaryStoreType: (array at: 1). (array at: 0) == #self ifTrue: [ selfTyped: True]. ]. ]. ms primaryStoreType: primaryStoreType. selfTyped ifTrue: [ ms instanceShape isNamed: False. ms instanceShape isIndexed: False. ] ifFalse: [ ms instanceShape isNamed: ms allInstVarNames isEmpty not. ms instanceShape isIndexed: (aClass srpHasIndexableValues). typeMap do: [ |:array | slotIndex: -1. ms allInstVarNames do: [ |:stringOrSymbol | slotIndex: slotIndex + 1. (array at: 0) = stringOrSymbol ifTrue: [ ms namedStoreTypeCodes at: slotIndex put: (ms storeTypeCodeForType: (array at: 1)). ]. ]. ]. ]. "Ms behavior: aClass. ms versionNumberArray: (config versionNumberArrayFor: aClass). ms extendedAttributes: (config extendedAttributesFor: aClass). ms config createdMetastate: self modeledAfter: aClass.! !" ]. mss@(SRP MetastateShape traits) isIndexed [ mss integerAllMask: 4 ]. mss@(SRP MetastateShape traits) isIndexed: aBool [ aBool ifTrue: [mss setBit: 3] ifFalse: [mss clearBit: 3] ]. mss@(SRP MetastateShape traits) isNamed: aBool [ aBool ifTrue: [mss setBit: 2] ifFalse: [mss clearBit: 2] ]. n@Nil srpDataTypeMap [ {{ #self. #Nil.}} ]. t@True srpDataTypeMap [ {{#self. #Boolean.}} ]. f@False srpDataTypeMap [ {{#self. #Boolean.}} ]. x@(Character traits) srpDataTypeMap [ {{#self. #Character.}} ]. x@(Root traits) srpDataTypeMap [ {} ]. x@(Root traits) srpIsPlaceholder [ False ]. x@(SRP Placeholder traits) srpIsPlaceholder [ True ]. x@(Root traits) srpPostLoadActionForLoader: aMarshaler [ "Answer a command (directed message or block) that will answer an object to take the place of the receiver when sent #value. The command will be sent #value after the root object has been completely loaded. Answer nil if no further processing is required." Nil ]. x@(SRP PmrIndexable traits) srpDataTypeMap [ {{#indexableValues. Nil}} ]. pi@(SRP PmrIndexable traits) srpIndexableValues [ pi indexableValues ]. pi@(SRP PmrIndexable traits) srpIndexableValueAt: index put: object [ pi indexableValues at: index put: object ]. x@(String traits) srpDataTypeMap [ {{#IndexableType. #Character}} ]. x@(ByteArray traits) srpHasIndexableValues [ True ]. x@(ByteArray traits) srpIndexableSize [ x size ]. x@(ByteArray traits) srpIndexableValueAt: index [ x at: index ]. x@(ByteArray traits) srpIndexableValueAt: index put: o [ x at: index put: o ]. x@(Root traits) srpNew [ x clone ]. x@(ByteArray traits) srpNew: size [ x newSize: size ]. x@(ExtensibleArray traits) srpNew [ x newSize: 0 ]. x@(ExtensibleArray traits) srpNew: size [ x newSize: size ]. x@(Boolean traits) srpHasIndexableValues [ False ]. x@(SRP PmrString traits) srpHasIndexableValues [ False ]. x@(SRP PmrFloat traits) srpHasIndexableValues [ False ]. x@(String traits) srpHasIndexableValues [ True ]. x@(Integer traits) srpHasIndexableValues [ False ]. x@(SRP PmrIndexable traits) srpHasIndexableValues [ True ]. x@(Array traits) srpHasIndexableValues [ True ]. x@(Root traits) srpHasIndexableValues [ False ]. x@(Integer traits) srpDataTypeMap [ {{#self. #Signed.}} ]. ps@(SRP PmrString traits) srpDataTypeMap [ {{#string. #String}} ]. ps@(SRP PmrSymbol traits) srpDataTypeMap [ {{#string. #String.}. {#string. #String.}} ]. p@(SRP PmrString traits) as: s@(String traits) [ p string ].