1"====================================================================== 2| 3| Magritte compatibility methods for GNU Smalltalk 4| 5| 6 ======================================================================" 7 8"====================================================================== 9| 10| Copyright 2008 Free Software Foundation, Inc. 11| Written by Paolo Bonzini. 12| 13| This file is part of the GNU Smalltalk class library. 14| 15| The GNU Smalltalk class library is free software; you can redistribute it 16| and/or modify it under the terms of the GNU Lesser General Public License 17| as published by the Free Software Foundation; either version 2.1, or (at 18| your option) any later version. 19| 20| The GNU Smalltalk class library is distributed in the hope that it will be 21| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of 22| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser 23| General Public License for more details. 24| 25| You should have received a copy of the GNU Lesser General Public License 26| along with the GNU Smalltalk class library; see the file COPYING.LIB. 27| If not, write to the Free Software Foundation, 59 Temple Place - Suite 28| 330, Boston, MA 02110-1301, USA. 29| 30 ======================================================================" 31 32 33 34Object subclass: MACompatibility [ 35 36 <category: 'Magritte-Model-Core'> 37 <comment: 'I am providing all the platform compatibility code on my class side, so that porting to different Smalltalk dialects can concentrate in a single place.'> 38 39 ShowLicense := false. 40 41 MACompatibility class >> allSubInstancesOf: aClass do: aBlock [ 42 "Evaluate the aBlock for all instances of aClass and all its subclasses." 43 44 <category: 'environment'> 45 aClass allSubinstancesDo: aBlock 46 ] 47 48 MACompatibility class >> classNamed: aString [ 49 "Return the class named aString, nil if the class can't be found." 50 51 <category: 'environment'> 52 ^(aString subStrings: $.) inject: Smalltalk into: [ :old :each | 53 old at: each asSymbol ifAbsent: [ ^nil ] ] 54 ] 55 56 MACompatibility class >> openWorkspace: aContentsString titled: aTitleString [ 57 "Open a new wokspace with the contents aContentsString and the title aTitleString." 58 59 ShowLicense ifFalse: [ ^self ]. 60 ('%1 61 62%2 63' % { aTitleString asUppercase. aContentsString }) displayOn: stderr 64 ] 65 66 MACompatibility class >> referenceStream: aReadWriteStream [ 67 "Return a stream instance to operate on aReadWriteStream being able to serialize and deserialize objects by sending #nextPut: and #next. Squeak: The implementation of ReferenceStream doesn't work well together with the default WriteStream implementaiton, therefor we have to change it on the fly." 68 69 <category: 'environment'> 70 ^ObjectDumper on: aReadWriteStream 71 ] 72 73 MACompatibility class >> uuid [ 74 "Answer a random object that is extremly likely to be unique over space and time." 75 76 <category: 'environment'> 77 ^UUID new 78 ] 79] 80 81 82 83ByteArray subclass: UUID [ 84 85 <shape: #byte> 86 <category: 'Seaside-Core-Utilities'> 87 <comment: 'I am a UUID. Sending #new generates a UUIDv1.'> 88 89 Node := nil. 90 SequenceValue := nil. 91 LastTime := nil. 92 Generator := nil. 93 GeneratorMutex := nil. 94 95 UUID class >> timeValue [ 96 "Returns the time value for a UUIDv1, in 100 nanoseconds units 97 since 1-1-1601." 98 ^((Time utcSecondClock + (109572 * 86400)) * 1000 99 + Time millisecondClock) * 10000 100 ] 101 102 UUID class >> randomNodeValue [ 103 "Return the node value for a UUIDv1." 104 | n | 105 "TODO: use some kind of digest to produce cryptographically strong 106 random numbers." 107 n := Generator between: 0 and: 16rFFFF. 108 n := (n bitShift: 16) bitOr: (Generator between: 0 and: 16rFFFF). 109 n := (n bitShift: 16) bitOr: (Generator between: 0 and: 16rFFFF). 110 ^n bitOr: 1 111 ] 112 113 UUID class >> update: aSymbol [ 114 "Update the sequence value of a UUIDv1 when an image is restarted." 115 116 aSymbol == #returnFromSnapshot ifTrue: [ 117 "You cannot be sure that the node ID is the same." 118 GeneratorMutex critical: [ 119 Generator := Random new. 120 LastTime := self timeValue. 121 Node := self randomNodeValue. 122 SequenceValue := (SequenceValue + 1) bitAnd: 16383 ]]. 123 ] 124 125 UUID class >> defaultSize [ 126 "Return the size of a UUIDv1." 127 128 <category: 'private'> 129 ^16 130 ] 131 132 UUID class >> initialize [ 133 "Initialize the class." 134 135 <category: 'initialization'> 136 ObjectMemory addDependent: self. 137 Generator := Random new. 138 LastTime := self timeValue. 139 Node := self randomNodeValue. 140 SequenceValue := Generator between: 0 and: 16383. 141 GeneratorMutex := Semaphore forMutualExclusion. 142 ] 143 144 UUID class >> new [ 145 "Return a new UUIDv1." 146 147 <category: 'instance-creation'> 148 ^(self new: self defaultSize) initialize 149 ] 150 151 initialize [ 152 "Fill in the fields of a new UUIDv1." 153 154 <category: 'private'> 155 | t | 156 GeneratorMutex critical: [ 157 t := self class timeValue bitAnd: 16rFFFFFFFFFFFFFFF. 158 t <= LastTime 159 ifTrue: [ SequenceValue := (SequenceValue + 1) bitAnd: 16383 ]. 160 161 LastTime := t. 162 self at: 1 put: ((t bitShift: -24) bitAnd: 255). 163 self at: 2 put: ((t bitShift: -16) bitAnd: 255). 164 self at: 3 put: ((t bitShift: -8) bitAnd: 255). 165 self at: 4 put: (t bitAnd: 255). 166 self at: 5 put: ((t bitShift: -40) bitAnd: 255). 167 self at: 6 put: ((t bitShift: -32) bitAnd: 255). 168 self at: 7 put: (t bitShift: -56) + 16r10. 169 self at: 8 put: ((t bitShift: -48) bitAnd: 255). 170 self at: 9 put: (SequenceValue bitShift: -8) + 16r80. 171 self at: 10 put: (SequenceValue bitAnd: 255). 172 self at: 13 put: ((Node bitShift: -40) bitAnd: 255). 173 self at: 14 put: ((Node bitShift: -32) bitAnd: 255). 174 self at: 15 put: ((Node bitShift: -24) bitAnd: 255). 175 self at: 16 put: ((Node bitShift: -16) bitAnd: 255). 176 self at: 11 put: ((Node bitShift: -8) bitAnd: 255). 177 self at: 12 put: (Node bitAnd: 255)] 178 ] 179 180 printOn: aStream from: a to: b [ 181 <category: 'private'> 182 self from: a to: b do: [:each | 183 aStream nextPut: (Character digitValue: (each bitShift: -4)). 184 aStream nextPut: (Character digitValue: (each bitAnd: 15)) ] 185 ] 186 187 printOn: aStream [ 188 "Print the bytes in the receiver in UUID format." 189 <category: 'printing'> 190 self printOn: aStream from: 1 to: 4. 191 aStream nextPut: $-. 192 self printOn: aStream from: 5 to: 6. 193 aStream nextPut: $-. 194 self printOn: aStream from: 7 to: 8. 195 aStream nextPut: $-. 196 self printOn: aStream from: 9 to: 10. 197 aStream nextPut: $-. 198 self printOn: aStream from: 11 to: 16. 199 ] 200] 201 202 203 204Symbol extend [ 205 isUnary [ 206 "Return true if the symbol represents a Unary selector." 207 <category: 'testing'> 208 209 ^self numArgs = 0 210 ] 211] 212 213FileDescriptor extend [ 214 binary [ 215 "Do nothing, needed for Squeak compatibility." 216 217 <category: 'squeak compatibility'> 218 ] 219] 220 221Object extend [ 222 asString [ 223 "Return the #displayString, needed for Squeak compatibility." 224 225 <category: 'squeak compatibility'> 226 ^self displayString 227 ] 228 229 isCollection [ 230 "Return false, needed for Squeak compatibility." 231 232 <category: 'squeak compatibility'> 233 ^false 234 ] 235 236 isEmptyOrNil [ 237 "Return false, needed for Squeak compatibility." 238 239 <category: 'squeak compatibility'> 240 ^false 241 ] 242 243 isVariableBinding [ 244 "Return false, needed by Magritte-Seaside." 245 246 <category: 'squeak compatibility'> 247 ^false 248 ] 249 250] 251 252Association extend [ 253 isVariableBinding [ 254 "Return false, needed by Magritte-Seaside." 255 256 <category: 'squeak compatibility'> 257 ^true 258 ] 259] 260 261Collection extend [ 262 intersection: b [ 263 "Return the set of elements common to the receiver and B." 264 265 <category: 'squeak compatibility'> 266 ^self asSet & b 267 ] 268 269 hasEqualElements: b [ 270 "Compare the elements in the receiver and B. Can be improved, 271 looking at Squeak's implementation." 272 273 <category: 'squeak compatibility'> 274 ^self asArray = b asArray 275 ] 276 277 isCollection [ 278 "Return true, needed for Squeak compatibility." 279 280 <category: 'squeak compatibility'> 281 ^true 282 ] 283 284 isEmptyOrNil [ 285 "Return true if the collection is empty, needed for Squeak 286 compatibility." 287 288 <category: 'squeak compatibility'> 289 ^self isEmpty 290 ] 291] 292 293SequenceableCollection extend [ 294 sort: aBlock [ 295 "Sort the items of the receiver according to the sort block, 296 aBlock." 297 298 <category: 'squeak compatibility'> 299 self 300 replaceFrom: 1 301 to: self size 302 with: (self asSortedCollection: aBlock) 303 startingAt: 1 304 ] 305] 306 307SortedCollection extend [ 308 sort: aBlock [ 309 "Sort the items of the receiver according to the sort block, 310 aBlock, and change the sort block to aBlock." 311 312 <category: 'squeak compatibility'> 313 sortBlock := aBlock. 314 self sortFrom: firstIndex to: lastIndex. 315 sorted := true. 316 lastOrdered := lastIndex 317 ] 318] 319 320UndefinedObject extend [ 321 isEmptyOrNil [ 322 "Return true, needed for Squeak compatibility." 323 324 <category: 'squeak compatibility'> 325 ^true 326 ] 327] 328 329String extend [ 330 includesSubstring: aString caseSensitive: aBoolean [ 331 "Needed for Squeak compatibility." 332 333 <category: 'squeak compatibility'> 334 aBoolean ifTrue: [ ^(self indexOfSubCollection: aString) > 0 ]. 335 ^(self asLowercase indexOfSubCollection: aString asLowercase) > 0 336 ] 337] 338 339ValueHolder extend [ 340 contents [ 341 "Needed for Squeak compatibility." 342 ^self value 343 ] 344 contents: anObject [ 345 "Needed for Squeak compatibility." 346 self value: anObject 347 ] 348] 349 350Time extend [ 351 print24: boolean24 showSeconds: booleanSec on: aStream [ 352 "Print a representation of the receiver on aStream according 353 to the given flags. Needed for Squeak compatibility." 354 355 <category: 'arithmetic'> 356 | h | 357 h := boolean24 ifTrue: [ self hour24 ] ifFalse: [ self hour12 ]. 358 h printOn: aStream. 359 aStream nextPut: $:. 360 self minutes < 10 ifTrue: [aStream nextPut: $0]. 361 self minutes printOn: aStream. 362 booleanSec ifFalse: [ ^self ]. 363 aStream nextPut: $:. 364 self seconds < 10 ifTrue: [aStream nextPut: $0]. 365 self seconds printOn: aStream 366 ] 367] 368 369Object subclass: MAVisitor [ 370 MAVisitor class >> new [ 371 <category: 'instance creation'> 372 ^super new initialize 373 ] 374 initialize [ 375 <category: 'initialization'> 376 ] 377] 378 379 380 381Eval [ 382 UUID initialize. 383] 384