src/mobius/types.slate

   1 define: #Type &parents: {Types Type}
   2   &slots: {#dispatcher -> Cloneable clone}.
   3 "A dispatching object for statically determining which pidgin method to invoke."
   4
   5 t@(Type traits) clone
   6 [
   7   resend `>> [dispatcher := t dispatcher clone. ]
   8 ].
   9
  10 t@(Type traits) dependencies
  11 [Set new `>> [addDependency: t withVisited: Set new. remove: t. ]].
  12
  13 c addDependency: t@(Type traits) withVisited: visited
  14 [
  15 ].
  16
  17 t@(Type traits) alignment
  18 [| bits |
  19   (bits := t bitSize) >= LongInt bitSize \/ [bits = 0]
  20     ifTrue: [LongInt bitSize]
  21     ifFalse: [bits]
  22 ].
  23
  24 t@(Type traits) byteSize
  25 [
  26   (t bitSize + Char bitSize - 1) // Char bitSize
  27 ].
  28
  29 t@(Type traits) wordSize
  30 [
  31   (t bitSize + LongInt bitSize - 1) // LongInt bitSize
  32 ].
  33
  34 define: #NamedType &parents: {Type} &slots: {#cName}.
  35
  36 define: #Pointer &parents: {Type} &slots: {#targetType}.
  37
  38 p@(Pointer traits) to: targetType
  39 "Creates a new Pointer Type for the targetType."
  40 "TODO: Map an IdentityDictionary from types to types of pointers to those
  41 types, and unify implicitly?"
  42 [
  43   p clone `>> [targetType := targetType. ]
  44 ].
  45
  46 p@(Pointer traits) cName ['P' ; p targetType slateName].
  47 p@(Pointer traits) slateName ['UndefinedSlatePointer'].
  48
  49
  50 _@(Pointer traits) bitSize
  51 [
  52   LongInt bitSize
  53 ].
  54
  55 t@(Type traits) pointer
  56 [
  57   Pointer to: t
  58 ].
  59
  60 p@(Pointer traits) = q@(Pointer traits)
  61 [p targetType = q targetType].
  62
  63 c addDependency: p@(Pointer traits) withVisited: visited
  64 [
  65   (visited includes: p)
  66     ifFalse:
  67       [visited include: p.
  68        (p targetType isSameAs: Synonym)
  69           ifTrue: [c addDependency: p targetType withVisited: visited]]
  70 ].
  71
  72 define: #Integer &parents: {Type} &slots: {#pointerType. #cPrintName}.
  73
  74 _@(Integer traits) baseByteSize [overrideThis].
  75
  76 n@(Integer traits) byteSize &platform: p
  77 [
  78   n baseByteSizeOn: (p `defaultsTo: Platform Current)
  79 ].
  80
  81 n@(Integer traits) bitSize &platform: p
  82 [(n byteSize &platform: p) * 8].
  83
  84 n@(Integer traits) cName
  85 [n cPrintName `defaultsTo: n printName name fromCamelCase].
  86
  87 n@(Integer traits) slateName
  88 [n printName].
  89
  90 n@(Integer traits) pointer
  91 [n pointerType `defaultsTo: (Pointer to: n)].
  92
  93 define: #Signed &parents: {Integer}.
  94 define: #Unsigned &parents: {Integer}.
  95
  96 define: #Char &parents: {Signed}.
  97 _@(Char traits) baseByteSizeOn: _ [1].
  98 define: #UnsignedChar &parents: {Unsigned}.
  99 _@(UnsignedChar traits) baseByteSizeOn: _ [1].
 100 define: #ShortInt &parents: {Signed}.
 101 _@(ShortInt traits) baseByteSizeOn: _ [2].
 102 define: #UnsignedShortInt &parents: {Unsigned}.
 103 _@(UnsignedShortInt traits) baseByteSizeOn: _ [2].
 104 define: #LongInt &parents: {Signed}.
 105 _@(LongInt traits) baseByteSizeOn: p [p bytesPerWord].
 106 define: #UnsignedLongInt &parents: {Unsigned}.
 107 _@(UnsignedLongInt traits) baseByteSizeOn: p [p bytesPerWord].
 108 define: #LongLongInt &parents: {Signed}.
 109 _@(LongLongInt traits) baseByteSizeOn: p [p bytesPerWord * 2].
 110 define: #UnsignedLongLongInt &parents: {Unsigned}.
 111 _@(UnsignedLongLongInt traits) baseByteSizeOn: p [p bytesPerWord * 2].
 112 define: #Float &parents: {Type}.
 113 _@(Float traits) baseByteSizeOn: p [4].
 114 define: #Double &parents: {Float}.
 115 _@(Double traits) baseByteSizeOn: p [8].
 116 define: #Void &parents: {Type}.
 117 _@(Void traits) baseByteSizeOn: _ [0].
 118
 119 define: #FixedInteger &parents: {Integer}.
 120
 121 define: #FixedSigned &parents: {FixedInteger}.
 122 define: #FixedUnsigned &parents: {FixedInteger}.
 123
 124 define: #Modifier &parents: {Type}
 125   &slots: {#baseType -> Type}.
 126
 127 t@(Modifier traits) derive
 128 [| newT lowerName |
 129   newT := resend.
 130   lowerName := newT printName copy toLowercase intern.
 131   _@(newT traits) modifierName [lowerName].
 132   [| :t | newT for: t] asMethod: lowerName on: {Type traits}.
 133   newT
 134 ].
 135
 136 t@(Modifier traits) cName [t modifierName ; ' ' ; t baseType cName].
 137
 138 m@(Modifier traits) for: b
 139 [m clone `>> [baseType := b. ]].
 140
 141 define: #Mutability &parents: {Modifier}.
 142 define: #Const &parents: {Mutability}.
 143 define: #Volatile &parents: {Mutability}.
 144
 145 define: #Storage &parents: {Modifier}.
 146 Storage traits None     ::= Storage clone.
 147 Storage traits Auto     ::= Storage clone.
 148 Storage traits Static   ::= Storage clone.
 149 Storage traits Extern   ::= Storage clone.
 150 Storage traits Register ::= Storage clone.
 151
 152 define: #Array &parents: {Type} &slots:
 153   {#elementType -> UnsignedLongInt.
 154    #size -> Nil}.
 155
 156 t@(Array traits) of: elementType size: size
 157 [t clone `>> [elementType := elementType. size := size. ]].
 158
 159 t@(Array traits) of: elementType
 160 [t of: elementType size: Nil].
 161
 162 c addDependency: t@(Array traits) withVisited: visited
 163 [
 164   (visited includes: t)
 165     ifFalse:
 166       [
 167         visited include: t.
 168         c addDependency: t elementType withVisited: visited
 169       ]
 170 ].
 171
 172 t@(Array traits) bitSize
 173 [
 174   t elementType bitSize * t size
 175 ].
 176
 177 define: #Synonym &parents: {NamedType}
 178   &slots: {#targetType. #pointer -> Pointer. #isExported -> False}.
 179
 180 t@(Synonym traits) newNamed: name type: type
 181 [
 182   t clone `>> [| :newT |
 183     cName := name.
 184     pointer := t pointer to: newT.
 185     targetType := type. ]
 186 ].
 187
 188 t@(Synonym traits) export
 189 [
 190   t isExported := True.
 191   t
 192 ].
 193
 194 c addDependency: t@(Synonym traits) withVisited: visited
 195 [
 196   (visited includes: t)
 197     ifFalse:
 198       [visited include: t.
 199        c include: t.
 200        c addDependency: t targetType withVisited: visited]
 201 ].
 202
 203 t@(Synonym traits) bitSize
 204 [
 205   t targetType bitSize
 206 ].
 207
 208 define: #Structure &parents: {NamedType}
 209   &slots: {#basis. #pointer -> Pointer. #isExported -> False.
 210            #elementSpecs -> ExtensibleArray new}.
 211
 212 t@(Structure traits) newNamed: name basedOn: basis
 213 [
 214   t clone `>>
 215    [| :newT | cName := name. basis := basis.
 216     pointer := t pointer to: newT.
 217     "pointer rules rawAddDelegate: #basisPointer valued: basis pointer rules.
 218     pointer dispatcher rawAddDelegate: #basisPointer valued: basis pointer dispatcher."
 219     elementSpecs := basis elementSpecs copy.
 220     elementSpecs do:
 221       [| :se | [| :_ | se type] asMethod: se cName asInferenceRule
 222                                 on: {newT}]. ]
 223 ].
 224
 225 t@(Structure traits) newNamed: name
 226 [
 227   t clone `>> [| :newT |
 228     cName := name.
 229     basis := Nil.
 230     pointer := t pointer to: newT.
 231     elementSpecs := t elementSpecs new. ]
 232 ].
 233
 234 t@(Structure traits) export
 235 [
 236   t isExported := True.
 237   t
 238 ].
 239
 240 c addDependency: t@(Structure traits) withVisited: visited
 241 [
 242   (visited includes: t)
 243     ifFalse:
 244       [
 245         visited include: t.
 246         c include: t.
 247         t elementSpecs do: [| :se | c addDependency: se type withVisited: visited]
 248       ]
 249 ].
 250
 251 t@(Structure traits) doElements: block
 252 [| previousSE bits |
 253   previousSE := t elementSpecs first.
 254   block applyTo: {previousSE. 0}.
 255   bits := previousSE bitSize.
 256   t elementSpecs allButFirstDo:
 257     [| :se |
 258       previousSE packed /\ [se packed]
 259         ifFalse:
 260           [| alignment |
 261             alignment := se type alignment.
 262             previousSE packed
 263               ifTrue:
 264                 [alignment := alignment max: previousSE type bitSize].
 265             bits := (bits / alignment) ceiling * alignment].
 266       block applyTo: {se. bits}.
 267       bits += se bitSize.
 268       previousSE := se]
 269 ].
 270
 271 t@(Type traits) walkElements: block &bitOffset: offset
 272 [
 273   t walkElements: block withPath: Stack new atBitOffset: (offset ifNil: [0])
 274 ].
 275
 276 _@(Type traits) walkElements: _ withPath: _ atBitOffset: _
 277 [
 278 ].
 279
 280 t@(Structure traits) walkElements: block withPath: path atBitOffset: baseOffset
 281 [
 282   t doElements:
 283     [| :se :offset |
 284      path push: se.
 285      block applyTo: {path. baseOffset + offset}.
 286      se type walkElements: block withPath: path atBitOffset: baseOffset + offset.
 287      path pop]
 288 ].
 289
 290 t@(Structure traits) unpaddedSize
 291 [| lastSE lastOffset |
 292   t elementSpecs isEmpty
 293     ifTrue: [^ 0].
 294   t doElements:
 295     [| :se :offset |
 296       lastSE := se.
 297       lastOffset := offset].
 298   lastOffset + lastSE bitSize
 299 ].
 300
 301 t@(Structure traits) alignment
 302 [
 303   t elementSpecs inject: 0 into:
 304     [| :maxAlign :se | maxAlign max: se type alignment]
 305 ].
 306
 307 t@(Structure traits) bitSize
 308 [| maxAlign |
 309   maxAlign := t alignment.
 310   (t unpaddedSize / maxAlign) ceiling * maxAlign
 311 ].
 312
 313
 314 define: #Union &parents: {Structure}.
 315
 316 t@(Union traits) doElements: block
 317 [
 318   t elementSpecs do:
 319     [| :se | block applyTo: {se. 0}]
 320 ].
 321
 322 t@(Union traits) unpaddedSize
 323 [| maxSize |
 324   maxSize := 0.
 325   t doElements:
 326     [| :se :_ |
 327       maxSize := maxSize max: se type bitSize].
 328   maxSize
 329 ].
 330
 331 define: #StructureElement &parents: {NamedType}
 332   &slots: {#type -> UnsignedLongInt}.
 333
 334 se@(StructureElement traits) newNamed: name type: type
 335 [
 336   se clone `>> [cName := name. type := type. ]
 337 ].
 338
 339 t@(Structure traits) addElement: se
 340 [
 341   t elementSpecs
 342     do: [| :each | each cName = se cName
 343           ifTrue: [warn: 'Attempted Redefinition of type StructureElement, named "' ; each cName ; '".'.
 344             ^ each]].
 345   [| :_ | se type] asMethod: se cName asInferenceRule on: {t}.
 346   [| :_ | se type] asMethod: se cName asInferenceRule on: {t pointer}.
 347   t elementSpecs addLast: se
 348 ].
 349
 350 t@(Structure traits) addElementNamed: name &type: type
 351 [
 352   type `defaultsTo: UnsignedLongInt.
 353   t addElement: (StructureElement newNamed: name type: type)
 354 ].
 355
 356 t@(StructureElement traits) bitSize
 357 [
 358   t type bitSize
 359 ].
 360
 361 _@(StructureElement traits) packed
 362 [
 363   False
 364 ].
 365
 366 define: #PackedStructureElement &parents: {StructureElement}
 367   &slots: {#bitSize -> 0}.
 368
 369 se@(PackedStructureElement traits) newNamed: name size: size
 370 [
 371   (se newNamed: name type: UnsignedLongInt) `>> [bitSize := size. ]
 372 ].
 373
 374 t@(Structure traits) addPackedElementNamed: name size: size
 375 [
 376   t addElement: (PackedStructureElement newNamed: name size: size)
 377 ].
 378
 379 _@(PackedStructureElement traits) packed
 380 [True].
 381
 382 define: #Function &parents: {Type}
 383   &slots: {#argumentTypes -> {}. #resultType -> Void}.
 384
 385 fun@(Function traits) from: argumentTypes to: resultType
 386 [
 387   fun clone `>>
 388    [| :newFun | argumentTypes := argumentTypes as: newFun argumentTypes.
 389     resultType := resultType. ]
 390 ].
 391
 392 define: #FunctionPointer &parents: {Pointer}.
 393
 394 fun@(Function traits) pointer
 395 [
 396   FunctionPointer to: fun
 397 ].
 398
 399 _@(FunctionPointer traits) from: argumentTypes to: resultType
 400 [
 401   (Function from: argumentTypes to: resultType) pointer
 402 ].
 403
 404 define: #Module &parents: {Type}.
 405