!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: bomlastconv.gs,v 1.30 2008-01-09 22:50:08 stever Exp $
!
! Description - 
!   This file contains the subset of bomlast.gs used for repository
!   conversion. (bomlast.gs is not used for conversion).
!=========================================================================

! Fix up methods that would have contained forward reference to PrintStream.
!  PrintStream requires execution to create class; execution not
!  possible until filein2 stage, but we need Object>>printString in 
!  filein1 in order to make topaz execution work ... 
category: 'Formatting'
method: Object
printString

"Returns a String whose contents are a displayable representation of the
 receiver."

"This method uses the printOn: method to create the String."

| ws str |

str := String new.

ws := PrintStream printingOn: str.  

self printOn: ws.
^ ws _collection "contents might have been converted to an EUCString."
%


! compile methods that contain forward references to Float if they are compiled
! earlier in the filein when building a fresh GemStone repository.

category: 'Converting'
method: Integer
asDecimalFloat

"Returns a DecimalFloat representing the receiver."

<primitive: 137>

| factor sum oldRoundingMode |

oldRoundingMode := Float roundingMode.  "nearest even is only right way"
Float roundingMode: 'nearestEven'.

sum := 0.0F0 .
factor := self sign asFloat.
1 to: self size do:
  [:i |
  sum := (self _digitAt: i) * factor + sum.
  factor := factor * 32768.0F0 ].

DecimalFloat roundingMode: oldRoundingMode.
^sum
%

category: 'Truncation and Rounding'
method: Number
ceiling

"Returns the integer that is closest to the receiver, on the same side
 of the receiver as positive infinity.  In particular, returns the
 receiver if the receiver is an integer."

(self <= 0.0)
   ifTrue: [^self truncated]
   ifFalse: [^self negated floor negated truncated]
%

category: 'Arithmetic'
method: Number
degreesToRadians

"Assuming the receiver represents an angle in degrees, returns the angle
 in radians."

^ self / 57.29577951308232
%

category: 'Arithmetic'
method: Number
radiansToDegrees

"Assuming the receiver represents an angle in radians, returns the angle
 in degrees."

^ self * 57.29577951308232
%

method: GsMethodDictionary
rebuildTable: newSize

"Rebuilds the method dictionary by populating a larger method dictionary
 first and doing a (primitive) become:"

"This is a reimplementation of the method in object.gs to handle
instances that have a dependency list."

<primitive: 901>
| newGsMethodDict depList |

tableSize = newSize ifTrue:[ 
  System _disableProtectedMode.
  ^ self "no change in table size"
].
collisionLimit == 536870911 ifTrue:[
  System _disableProtectedMode.
  ^ self 		"avoid recursive rebuild"
  ].

newGsMethodDict := self class new: (newSize * 2).
newGsMethodDict valueConstraint: valueConstraint.
newGsMethodDict keyConstraint: keyConstraint.

self keysAndValuesDo: [ :aKey :aValue |
  newGsMethodDict at: aKey put: aValue.
  ].

(depList := DependencyList for: self) ~~ nil
  ifTrue: [ DependencyList set: nil for: self ].

newGsMethodDict _primitiveBecome: self.

depList ~~ nil
  ifTrue: [ DependencyList set: depList for: self ].
System _disableProtectedMode.
%

!--------------------------------------
! build global float literals for exceptional floats

run
#[ #PlusInfinity , #MinusInfinity, #PlusQuietNaN,
   #MinusQuietNaN, #PlusSignalingNaN, #MinusSignalingNaN ]
 do: [ :aSymbol |
    ( Globals at: aSymbol ifAbsent: [ nil ] ) == nil
      ifTrue: [
        Globals at:aSymbol put: (Float fromString: aSymbol) .
        Globals at: (Symbol withAll: 'Decimal' , aSymbol)
                put: (DecimalFloat fromString: aSymbol) .
      ]
    ] .
^ true
%

!--------------------------------------

category: 'Repository Conversion'
method: Class
_unsafeDisallowSubclasses

""

self _unsafeAt: 2 "offset of format"
           put: (format bitOr: 32 "subclasses disallowed bit") .
self _refreshClassCache
%

category: 'Repository Conversion'
method: Class
_unsafeMakeClassNp

""

self _unsafeAt: 2 "offset of format"
           put: (format bitOr: 16r800"instancesNP bit" ) .
self _refreshClassCache
%

!--------------------------------------
run
| list |
  list := #[ Behavior, Class, Metaclass, Repository, UserProfileSet,
     AbstractUserProfileSet,
     CompiledMethod, Float, DecimalFloat, SmallFloat, SmallDouble,
     Symbol, DoubleByteSymbol, 
     UnimplementedFloat1, UnimplementedFloat2 ,
     MethodContext, Block, SelectionBlock,
     Segment, SymbolList, System, UndefinedObject, UserProfile, Boolean,
     Character, SmallInteger, Integer, LargePositiveInteger,
     LargeNegativeInteger, JISCharacter, StackSegment,
     StackBuffer, Activation, Process, VariableContext, BlockClosure,
     ExecutableBlock, SimpleBlock, ComplexBlock, ComplexVCBlock,

     GsMethod, GsProcess, GsMethodDictionary, GsStackBuffer, 

     SelectBlock , BtreeBasicInteriorNode, BtreeBasicLeafNode, BasicSortNode,
     RcIndexBucket, RcIndexBucketWithCache, RcIndexDictionary, NscBuilder,

     PathTerm, ConstrainedPathTerm, SetValuedPathTerm  "fix bug 11484"
     ].

  list do: [ :aClass | aClass _unsafeDisallowSubclasses ] .

  list do: [ :aClass |
     aClass subclassesDisallowed ifFalse:[ ^ 'Error on ' , aClass name ].
     ] .
  ^ true
%
run
Semaphore _unsafeMakeClassNp .
ProcessorScheduler _unsafeMakeClassNp .
^ true
%

run
Class removeSelector: #_unsafeDisallowSubclasses .
Class removeSelector: #_unsafeMakeClassNp .
^ true
%

run
| list blk |

" allow adding instance variables to the following classes.  fixes bug 6569"
list := #[ UserProfile ] .

blk := [ :aClass |
          aClass _unsafeAt: 4 "instVarNames"
                 put: (Array withAll: (aClass instVarAt: 4)) .
          aClass _unsafeAt: 5 "constraints"
                     put: (Array withAll: (aClass instVarAt: 5)) .
          aClass _refreshClassCache
       ].
list do: blk .
^ true
%

run

|newConstraints|

"Change the constraint on the unwind block of VariableContext.  Fixes bug15424."

newConstraints := Array with: ExecutableBlock.
newConstraints immediateInvariant.
VariableContext _unsafeAt: 5 "constraints"
		put: newConstraints.
VariableContext _refreshClassCache.
^true
%


!--------------------------------------

!--------------------------------------
! clear "conversion in progress flag"   
expectvalue false
run
ConversionStatus at: 1 put: false
%

!--------------------------------------
! Create class documentation for kernel classes that are only placeholders.

category: 'For Documentation Installation only'
classmethod: System
installPlaceholderDocumentation

| str |

str :=
' is a placeholder for another related GemStone product that has not currently
  been installed.' .

" list of placeholder classes for other products "
#[ GsfClassDefinitionInfo, GsfModificationLog ]
  do: [ :aClass |
    | doc txt |
    doc := GsClassDocumentation _newForPrivateGsClass: aClass.
    txt := (GsDocText new) details:
           ((String withAll: (aClass name)) add: str; yourself).
    doc documentClassWith: txt.
    aClass description: doc.
  ].

" list of placeholder classes within the server "
#[ UnimplementedFloat1, UnimplementedFloat2 ]
  do: [ :aClass |
    | doc |
    doc := GsClassDocumentation _newForPrivateGsClass: aClass.
    doc documentClassWith: (GsDocText new).
    aClass description: doc.
  ].
%


!--------------------------------------
! Install class documentation for kernel classes only.

run

| classes |

System installPlaceholderDocumentation.

classes := ClassSet new.
(Globals values) do: [ :each |
  ( (each isKindOf: Class)
      _and:[(each class includesSelector: #installDocumentation)] )
  ifTrue: [ classes add: each.  ].
  ].

classes do: [ :aClass | 
  aClass installDocumentation .
  GsFile gciLogServer:'installed doc for ', aClass name  . 
] .
classes do: [ :aClass |
  (aClass class) removeCategory: 'For Documentation Installation only'.
  ].
^true
%
commit

!------------------------------------------------------------
! Make various methods in the indexing subsystem 'protected'
!  now done via compilation directives during method compilation
!------------------------------------------------------------

!------------------------------------------------------------
! Make various classes in the indexing subsystem 'protected'.
! This prevents accessing an instance through structural access
! 31162: also protect classes for code security.
!------------------------------------------------------------
!
run
" list of classes which will be protected "
#[ SegmentSet,
   SetValuedPathTerm,
   SetValuedPathEvaluator, UserSecurityData,
"31162"
   GsMethod, Class, GsMethodDictionary, SymbolDictionary, SymbolList,
   UserProfile
]
    do: [ :aClass | aClass _makeProtected ].

^ true
%
lev 1
obj AbstractCharacter
lev 0
commit

!------------------------------------------------------------
! Build the dictionary of configuration file parameters
!------------------------------------------------------------
run
Globals at:#ConfigurationParameterDict put:
(System _configFileParameterDict) .
^ true
%
!------------------------------------------------------------
! Build the dictionary of software version information parameters
!------------------------------------------------------------
run
"dictionary to translate names to internal identifiers"
Globals at:#VersionParameterDict put:
(System _versionParameterDict) .
^ true
%
run
"dictionary of image version information"
Globals at:#ImageVersion put: SymbolDictionary new .
^ true
%
input $upgradeDir/version.topaz

! build the set of classes for which instances are disallowed
run
Globals at:#InstancesDisallowed put:
 ( IdentitySet withAll:
  #[ Activation, Character, Behavior, Block, BlockClosure, Boolean,
      Class, GsMethod, ComplexBlock, ComplexVCBlock, DateTime,
      ExecutableBlock, Float, DecimalFloat, SmallFloat, BinaryFloat,
      Integer, JISCharacter, LargeNegativeInteger,
      LargePositiveInteger, Metaclass, MethodContext, Number, Process,
      Repository, Segment, SelectBlock, SelectionBlock, SimpleBlock,
      SmallInteger, StackBuffer, StackSegment, System, UndefinedObject,
      UserProfile, VariableContext ]) .
^ true
%
commit

!------------------------------------------------------------
! Create collating tables for raw ASCII collating order for use with
! String compare methods  in category 'Other comparisons'
!------------------------------------------------------------
run
| a |
a := ByteArray new .
0 to: 255 do:[:j| a add: j ].
Globals at:#AsciiCollatingTable put: a .
^ a size == 256
%
run
| a |
a := DoubleByteString new .
0 to: 255 do:[:j| a add: (Character withValue: j )].
Globals at:#DoubleByteAsciiCollatingTable put: a .
^ a size == 256
%

!-----------
!  ensure bom has created the old canonicalized float zeros

! old oop 1873
expectvalue %Float
obj @239617

! old oop 1875
expectvalue %SmallFloat
obj @239873


! reset weak refs array 
expectvalue true
run
Globals at: #GcWeakReferences put: Array new.
^ true
%

! indexing  not supported, so clear SharedDependencyLists
expectvalue true
run
Globals at: #SharedDependencyLists put: DepListTable new .
^true
%

!-------------
! removal of _unsafesetoop method done later in filein


!------------------------------------------------------------
! fixes 31329 , 31540 - Remove references to Geode
!------------------------------------------------------------

expectvalue %String
run
" remove references to geode without creating Symbols unnecessarily"
| result geodeKeys globalsKeys removeList report |
result := String new .
geodeKeys := #[ 'Geode', 'GeodeGlobals', 'GeodeLauncher',
		'GeodeMaint', 'GeODEDbfHistory', 'ObsoleteGeode' ].
globalsKeys := Globals keys . "collection of Symbols"
removeList := Array new .
geodeKeys do:[ :aGeod |
  globalsKeys do:[ :aGlb | 
     aGlb asString = aGeod ifTrue:[ removeList add: aGeod ]
  ].
].
report := String new .
removeList do:[ :aKey |
  Globals removeKey: aKey asSymbol .
  report add: ' removed ' , aKey , ' ; ' .
  ].
^ report .
%

!------------------------------------------------------------
! Fix 31942, disallow gci store to instances of SymbolList .
! If customers have created subclasses of SymbolList , those are not
! changed .
expectvalue true
run
SymbolList _disallowGciCreateStore .
^ SymbolList _structuralUpdatesDisallowed
%

commit

expectvalue true
run
 "Check that certain kernel classes have only one version defined.
  The virtual machine contains optimizations which assume that
  the classes checked below have only one version, and thus the
  virtual machine can skip looking at the classHistory when doing
  certain isKindOf checks on arguments to primitives.  
  See fix 32339"

| clsList |
clsList := #[ AbstractCharacter,
  Array,
  ExecutableBlock,
  GsProcess,
  GsSocket,
  IdentityBag,
  Interval,
  SequenceableCollection,
  SmallFloat,
  SmallDouble  ].

clsList do:[ :aCls | | hist val sz |
  hist := aCls classHistory .
  sz := hist size .
  sz == 1 ifFalse:[ 
    nil error:'classHistory for ' , aCls name , ' too big' 
  ].
  val := hist at: 1 .
  val == aCls ifFalse:[
    nil error:'classHistory for ' , aCls name , ' is corrupt'
  ].
].   
"primitives for Float do not check classHistory, but explicitly
 check arguments for both SmallDouble and Float ."
true ifTrue:[ | hist val sz |
  hist := Float classHistory .
  sz := hist size .
  sz == 2 ifFalse:[
    nil error: 'classHistory for Float has wrong size.'
  ].
  val := hist at: 1 .
  val == Float ifFalse:[
    nil error:'classHistory for Float, bad value at:1' . 
  ].
  val := hist at: 2 .
  val == SmallDouble ifFalse:[
    nil error:'classHistory for Float, bad value at:1' . 
  ].
].
^ true
%

expectvalue %String
run
| dcSeg |
dcSeg := Globals at:#DataCuratorSegment .
AllUsers segment == dcSeg ifTrue:[
  ^ 'segment ok'
] ifFalse:[
  AllUsers changeToSegment: dcSeg .
  AllUsers do:[ :aUp | 
    aUp segment == dcSeg ifFalse:[ aUp changeToSegment: dcSeg].
  ].
  ^ 'changed segment'
]
%
lev 1
obj AbstractCharacter
lev 0

expectvalue %String
run
	"ensure Association for FdcResults is in DataCurator segment"
| res dcSeg |
dcSeg := Globals at:#DataCuratorSegment .
(Globals includesKey:#FdcResults) ifTrue:[
  (Globals associationAt:#FdcResults) changeToSegment: dcSeg .
  res := 'changed segment of FdcResults' .
] ifFalse:[
  dcSeg setCurrentWhile:[
    Globals at:#FdcResults put: nil .
    res := 'created FdcResults' . 
  ]
].
^ res 
%

! =====================================================================
! adjust existing UserProfiles to grant new inverse privileges
run
| priv setBlk clearBlk inversePrivs LF |
System myUserProfile userId = 'SystemUser' ifFalse:[ nil error:'wrong user'].
LF := Character lf .
inversePrivs := #( #NoPerformOnServer #NoUserAction
             #NoGsFileOnServer #NoGsFileOnClient ) .
setBlk := [ :aUp | 
  inversePrivs do:[ :aPriv | aUp addPrivilege: aPriv ] .
  GsFile gciLogClient:'set inverse priv bits for ' , aUp userId , LF .
].
clearBlk := [ :aUp | 
  inversePrivs do:[ :aPriv | aUp deletePrivilege: aPriv] .
  GsFile gciLogClient:'cleared inverse priv bits for ' , aUp userId , LF .
].
AllUsers do:[ :aUp | | uid |
  uid := aUp userId .
  (UserProfile isSpecialUserId: uid) ifTrue:[
    (uid = 'SystemUser' or:[ uid = 'DataCurator']) ifTrue:[
      clearBlk value: aUp .
    ] ifFalse:[  "gcuser, symboluser, nameless"
      setBlk value: aUp . 
    ].
  ] ifFalse:[
    "preexisting customer user profiles not affected. 
     If customers have blindly set all priv bits those Up's need adjustment.
    "
  ].
]. 
^ true
%



! end of bomlastconv.gs
