ObjectMemory.luon

(*
* Copyright 2024 Rochus Keller <mailto:me@rochus-keller.ch>
*
* This file is part of the Luon Smalltalk-80 VM.
*
* The following is the license that applies to this copy of the
* application. For a license to use the application under conditions
* other than those described here, please email to me@rochus-keller.ch.
*
* GNU General Public License Usage
* This file may be used under the terms of the GNU General Public
* License (GPL) versions 2.0 or 3.0 as published by the Free Software
* Foundation and appearing in the file LICENSE.GPL included in
* the packaging of this file. Please review the following information
* to ensure GNU General Public Licensing requirements will be met:
* http://www.fsf.org/licensing/licenses/info/GPLv2.html and
* http://www.gnu.org/copyleft/gpl.html.
*)

// migrated from the C++ version

module ObjectMemory
  import Files
  
const
    // Objects known to the interpreter
      // small integers:
      objectMinusOne* = 65535
      objectZero* = 1
      objectOne* = 3
      objectTwo* = 5
      // undefined, boolean
      objectNil* = 02h
      objectFalse* = 04h
      objectTrue* = 06h
      // root:
      processor* = 08h // an Association whose value field is Processor, SchedulerAssociationPointer
      smalltalk* = 012h // an Association whose value field is SystemDirectory
      // classes:
      classSmallInteger* = 0ch // max 16383 (16384), min -16384 (-16385), bits 14, bytes 2
      classString* = 0eh
      classArray* = 10h
      classFloat* = 014h
      classMethodContext* = 016h
      classBlockContext* = 018h
      classPoint* = 01ah
      classLargePositiveInteger* = 01ch
      classDisplayBitmap* = 01eh
      classMessage* = 020h
      classCompiledMethod* = 022h
      classSemaphore* = 026h
      classCharacter* = 028h
      // symbols:
      symbolTable* = 00ah // symbol class variable USTable
      symbolDoesNotUnderstand* = 02ah
      symbolCannotReturn* = 02ch
      symbolMonitor* = 02eh
      symbolUnusedOop18* = 024h
      symbolMustBeBoolean* = 034h
      // selectors:
      specialSelectors* = 030h // SystemDictionary class variable, the array of selectors for bytecodes 260-317 octal
      characterTable* = 032h // Character class variable, table of characters
      // extra knowns:
      classSymbol* = 038h
      classMethodDictionary* = 04ch
      classLargeNegativeInteger* = 01da0h
      classProcess* = 07a4h
      classAssociation* = 084h
      currentSelection* = 02392h // ParagraphEditor.CurrentSelection

    // compiled method flags:
      ZeroArguments* = 0
      OneArgument* = 1
      TwoArguments* = 2
      ThreeArguments* = 3
      FourArguments* = 4
      ZeroArgPrimitiveReturnSelf* = 5 // no bytecode
      ZeroArgPrimitiveReturnVar* = 6 // methodTemporaryCount returns index of the instance var to return, no bytecode
      HeaderExtension* = 7
      
      ValueIndex = 1
      methHdrByteLen = 2

type 
      OOP = integer // only 16 bit used
      ByteArray = array of byte
      Object = record cls: integer; 
                    isOdd, isPtr, marked: boolean
                    data: ByteArray
                end
      
var
      slots : array of Object
      registers : array 10 of integer
      temps : hashmap OOP of boolean

  procedure loadFromFile*(path: string):boolean
  var f: Files.File; bytes, objectSpace, objectTable: ByteArray
      objectSpaceLenWords, objectSpaceLenBytes, 
      objectTableLenWords, objectTableLenBytes, size,
      numOfPages, off, i: integer
      
    procedure readSlot( objectTable, objectSpace: ByteArray; i: integer )
    var flags, loc, seg, addr, wordLen, byteLen, cls, slotNr: integer
        obj: Object
    
      procedure isFree(flag: integer):boolean inline
      begin
        return bitand(flag, 020h) # 0
      end isFree

      procedure isPtr(flag: integer):boolean inline
      begin
        return bitand(flag, 040h) # 0
      end isPtr
     
      procedure isOdd(flag: integer):boolean inline
      begin
        return bitand(flag, 080h) # 0
      end isOdd
     
    begin
      flags := objectTable[i+1]
      if not isFree(flags) then
        loc := readU16(objectTable,i+2) // loc is the word index, not byte index
        
        seg := bitand(flags, 0fh) // segment number
        
        // in Bits of History page 49: each segment contains 64k words (not bytes)
        addr := bitshl(seg, 17) + bitshl(loc, 1)
        wordLen := readU16(objectSpace, addr) - 2 // without header
        assert(wordLen < bitshr(0ffffh, 1))
        byteLen := wordLen * 2
        
        cls := readU16(objectSpace, addr + 2 )
        
        // OOP are only even number, slotNr are also odd number, so OOP/2, i.e. i/4
        slotNr := bitshr(i, 2) 
        
        obj := allocate( slotNr, byteLen, cls, isPtr(flags), isOdd(flags) )        
        // copy bytes
        for i := 0 to byteLen-1 do
          obj.data[i] := objectSpace[addr+4+i]
        end
      end
    end readSlot
    
  begin
    f := Files.Open(path)
    if f = nil then
      println("cannot open file")
      return false
    end
    new(bytes,10)
    
    Files.ReadBytes(f, bytes, 4)
    objectSpaceLenWords := readU32(bytes,0)
    objectSpaceLenBytes := objectSpaceLenWords * 2
    Files.ReadBytes(f, bytes, 4)
    objectTableLenWords := readU32(bytes,0)
    objectTableLenBytes := objectTableLenWords * 2
    
    size := Files.ReadBytes(f, bytes, 2)  
    if (size # 2) or (bytes[0] # 0) or (bytes[1] # 0) then
      return false // not in interchange format
    end

    Files.Seek(f, Files.Length(f) - 10)
    size := Files.ReadBytes(f, bytes, 10)
    
    if (size # 10) or (bytes[3] # 020h) or (bytes[6] # 001h) or
            (bytes[7] # 043h) or (bytes[8] # 0f3h) or (bytes[9] # 03bh) then
      return false
    end

    Files.Seek(f, 512)
    
    // Object Space format:
    // | xxxxxxxx xxxxxxxx | word length
    // | xxxxxxxx xxxxxxxx | class
    // | payload of word lenght - 2
    new(objectSpace,objectSpaceLenBytes)
    size := Files.ReadBytes(f, objectSpace, objectSpaceLenBytes)
    if size # objectSpaceLenBytes then return false end
    
    numOfPages := objectSpaceLenBytes div 512
    off := 512 + ( numOfPages + 1 ) * 512
    Files.Seek(f, off)
   
    // Object Table format:
    // | xxxxxxxx | count, unused
    // | ffffssss | flags, segment
    // | llllllll llllllll | location
    new(objectTable, objectTableLenBytes)
    size := Files.ReadBytes(f, objectTable, objectTableLenBytes)
    if size # objectTableLenBytes then return false end
    
    for i := 0 to objectTableLenBytes-1 by 4 do
      readSlot(objectTable, objectSpace, i)
    end
   
    // TODO
    // updateRefs()
    return true
  end loadFromFile
  
  procedure allocate(slot, numOfBytes: integer; cls: OOP; isPtr, isOdd: boolean): Object
  var byteLen: integer; obj: Object
  begin 
    // header
    // 1: cls msb
    // 2: cls lsb
    // 3: isodd
    // 4: isptr
    // ... bytes of object
    assert( (slot < len(slots)) and (slots[slot] = nil) )
    byteLen := numOfBytes
    new(obj) 
    new(obj.data, byteLen)
    obj.isOdd := isOdd
    obj.isPtr := isPtr
    obj.marked := false
    obj.cls := bitshr(cls, 1)
    slots[slot] := obj
    return obj
  end allocate
  
  procedure getClass(obj: Object): OOP inline
  begin
    return bitshl(obj.cls, 1)
  end getClass
  
  procedure readU32(data: ByteArray; off: integer):integer inline
  begin
      return bitshl(data[0+off], 24 ) + bitshl(data[1+off], 16 ) +
            bitshl(data[2+off], 8 ) + data[3+off];
  end readU32
  
  procedure readU16(data: ByteArray; off: integer): integer inline
  begin
    //assert(off+1 < len(data))
    return bitshl(data[off], 8) + data[off+1]
  end readU16
  
  procedure writeU16(data: ByteArray; off, value: integer)
  begin
    //assert(off+1 < len(data))
    data[off] := clip(bitshr(value,8))
    data[off+1] := clip(bitand(value,0ffh))
  end writeU16
  
  procedure isInt(ptr: integer ): boolean inline
  begin
    return bitand(ptr, 1) # 0 
  end isInt
  
  procedure getSlot(oop: OOP): Object inline
  begin
    return slots[ bitshr(oop,1) ]
  end getSlot
  
  procedure fetchClassOf*(objectPointer: OOP): OOP
  var obj : Object
  begin
    if isInt(objectPointer) then return classSmallInteger end
    obj := getSlot(objectPointer)
    if obj # nil then 
      return bitshl(obj.cls,1) 
    else return 0 end
  end fetchClassOf
  
  procedure getWordLen(obj: Object): integer inline
  begin
    return len(obj.data) div 2
  end getWordLen
  
  procedure fetchWordLenghtOf*(objectPointer: OOP): integer 
  var obj : Object
  begin
    if isInt(objectPointer) then return 0 end
    obj := getSlot(objectPointer)
    if obj = nil then return 0 end
    return getWordLen(obj)
  end fetchWordLenghtOf
  
  procedure fetchByteLenghtOf*(objectPointer: OOP): integer 
  var obj : Object; off: integer
  begin
    if isInt(objectPointer) then return 0 end
    obj := getSlot(objectPointer)
    if obj = nil then return 0 end
    return getByteLen(obj)
  end fetchByteLenghtOf
  
  procedure fetchWordOfObject*(fieldIndex: integer; objectPointer: OOP): integer 
  var obj : Object
  begin
    if objectPointer = objectNil then return 0 end
    obj := getSlot(objectPointer)
    if obj = nil then return 0 end
    return readU16( obj.data, fieldIndex * 2 )
  end fetchWordOfObject
  
  procedure fetchPointerOfObject*(fieldIndex: integer; objectPointer: OOP): OOP 
  var obj : Object; off: integer; oop: OOP
  begin
    if objectPointer = objectNil then return objectNil end
    obj := getSlot(objectPointer)
    if obj = nil then return objectNil end
    off := fieldIndex * 2
    oop := readU16( obj.data, off );
    if oop = 0 then // BB (implicitly?) assumes that unused members are nil
      return objectNil
    else
      return oop
    end
  end fetchPointerOfObject
  
  procedure storePointerOfObject*(fieldIndex: integer; objectPointer, withValue: OOP) 
  var obj : Object; off: integer
  begin
    assert(objectPointer # 0)
    if objectPointer = objectNil then return end
    obj := getSlot(objectPointer)
    if obj = nil then return end
    off := fieldIndex * 2
    writeU16(obj.data, off, withValue)
  end storePointerOfObject
  
  procedure fetchByteOfObject*(byteIndex: integer; objectPointer: OOP): byte 
  var obj : Object; off: integer
  begin
    if objectPointer = objectNil then return 0 end
    obj := getSlot(objectPointer)
    if obj = nil then return 0 end
    off := byteIndex
    assert( (not obj.isPtr) and (off < len(obj.data) ) )
    return obj.data[off]
  end fetchByteOfObject
    
  procedure storeByteOfObject*(byteIndex: integer; objectPointer: OOP; withValue: byte) 
  var obj : Object; off: integer
  begin
    obj := getSlot(objectPointer)
    if obj = nil then return end
    off := byteIndex
    assert( (not obj.isPtr) and (off < len(obj.data) ) )
    obj.data[off] := withValue
  end storeByteOfObject
  
  procedure storeWordOfObject*(fieldIndex: integer; objectPointer: OOP; withValue: integer) 
  var obj : Object; off: integer
  begin
    obj := getSlot(objectPointer)
    if obj = nil then return end
    off := fieldIndex * 2
    writeU16(obj.data, off, withValue)
  end storeWordOfObject
  
  procedure swapPointersOf*(firstPointer, secondPointer: OOP) 
  var i1, i2: integer; tmp : Object
  begin
    i1 := bitshr(firstPointer, 1)
    i2 := bitshr(secondPointer, 1)
    assert( (i1 < len(slots)) and (i2 < len(slots)) )
    tmp := slots[i1]
    slots[i1] := slots[i2]
    slots[i2] := tmp
  end swapPointersOf
  
  procedure hasObject*(ptr: OOP): boolean 
  var i: integer
  begin
    i := bitshr(ptr,1)
    if i < len(slots) then
      return slots[i] # nil
    else
      return false
    end
  end hasObject
  
  procedure methodClassOf*(methodPointer: OOP): OOP 
  var literalCount: integer; association: OOP
  begin
    literalCount := literalCountOf(methodPointer)
    association := literalOfMethod(literalCount-1, methodPointer)
    return fetchPointerOfObject(ValueIndex,association)
  end methodClassOf
  
  procedure headerOf(methodPointer: OOP): OOP
  begin
        return fetchPointerOfObject(0,methodPointer) // HeaderIndex
  end headerOf

  procedure literalCountOf(methodPointer: OOP):integer
  var header: OOP
  begin
    header := headerOf(methodPointer)
    return extractBits(9,14,header);
  end literalCountOf
  
  procedure extractBits*( from, to_, of_: integer ): integer
  begin
    assert( (from <= to_) and (to_ <= 15) )
    return bitand( bitshr(of_,(15 - to_)), ( bitshl(1, (to_ - from + 1)) - 1))
  end extractBits
  
  procedure flagValueOf*(methodPointer: OOP): integer // returns compiled method flags 
  var obj: Object
  begin
    assert(methodPointer # 0)
    obj := getSlot(methodPointer)
    if obj = nil then return 0 end    
    assert( getClass(obj) = classCompiledMethod )
    return getMethodFlags( obj.data[0] )
  end flagValueOf
  
  procedure getMethodFlags(data: integer ): integer inline
  begin
    return bitand(bitshr( data, 5 ), 07h)
  end getMethodFlags
  
  procedure largeContextFlagOf*(methodPointer: OOP): boolean 
  var header: OOP
  begin
    assert(methodPointer # 0)
    header := headerOf(methodPointer)
    return extractBits(8,8,header) # 0
  end largeContextFlagOf
  
  procedure primitiveIndexOf*(methodPointer: OOP): integer 
  var obj: Object; flags, literalByteCount, extension: integer
  begin
    obj := getSlot(methodPointer)
    if obj = nil then return 0 end    
    assert( getClass(obj) = classCompiledMethod )
    flags := getMethodFlags( obj.data[0] )
    if flags # HeaderExtension then return 0 end
    literalByteCount := getLiteralByteCount(obj)
    extension := readU16(obj.data, methHdrByteLen
                              + literalByteCount - 4 ); // next to the last literal
    return bitand(bitshr(extension, 1), 0ffh)
  end primitiveIndexOf
  
  procedure getLiteralByteCount( obj: Object ): integer inline

  begin
    return 2 * bitand(bitshr(obj.data[1], 1), 03fh)
  end getLiteralByteCount
  
  procedure literalOfMethod*(index: integer; methodPointer: OOP): OOP 
  var obj: Object; literalByteCount, byteIndex: integer
  begin
    obj := getSlot(methodPointer)
    if obj = nil then return 0 end    
    assert( getClass(obj) = classCompiledMethod )
    literalByteCount := getLiteralByteCount(obj)
    byteIndex := 2 * index
    return readU16( obj.data, methHdrByteLen + byteIndex )
  end literalOfMethod
  
  procedure initialInstructionPointerOfMethod*(methodPointer: OOP): integer inline
  begin
    return ( literalCountOf(methodPointer) + ValueIndex ) * 2 + 1
  end initialInstructionPointerOfMethod
  
  procedure temporaryCountOf*(methodPointer: OOP): integer 
  var header: OOP
  begin
    header := headerOf(methodPointer)
    return extractBits(3,7,header)
  end temporaryCountOf
  
  procedure fieldIndexOf*(methodPointer: OOP): integer inline
  begin
    return temporaryCountOf(methodPointer)
  end fieldIndexOf
  
  procedure objectPointerCountOf*(methodPointer: OOP): integer inline
  begin
    return literalCountOf(methodPointer) + 1
  end objectPointerCountOf
  
  procedure argumentCountOf(methodPointer: OOP): integer 
  var obj: Object; flags, literalByteCount, extension: integer
  begin
    obj := getSlot(methodPointer)
    if obj = nil then return 0 end    
    assert( getClass(obj) = classCompiledMethod )
    flags := getMethodFlags(obj.data[0])
    if flags <= FourArguments then
      return flags
    elsif (flags = ZeroArgPrimitiveReturnSelf) or (flags = ZeroArgPrimitiveReturnVar) then
      return 0
    end
    assert( flags = HeaderExtension )
    literalByteCount := getLiteralByteCount(obj)
    extension := readU16( obj.data, methHdrByteLen
                                       + literalByteCount - 4 ) // next to the last literal
    return bitand(bitshr(extension, 9), 01fh)
  end argumentCountOf
 
  procedure integerObjectOf*(value: integer): OOP 
  var res: OOP
  begin
    res := toTwoComp(value)
    res := bitor(bitshl( res, 1 ), 1)
    return res
  end integerObjectOf
  
  procedure toTwoComp*(value: integer): integer
  var res: integer
  begin
    // ST integers have 15 bit range
    if value >= 0 then
      res := bitand(value, 0011_1111_1111_1111b)
    else
      res := bitnot(abs(value)) + 1
      res := bitand(res, 0111_1111_1111_1111b)
      res := bitor(res, 0100_0000_0000_0000b)
    end
    return res
  end toTwoComp
  
  procedure fromTwoComp*(value: integer): integer
  var negative: boolean; res: integer
  begin
    negative := bitand(value, 0100_0000_0000_0000b) # 0
    if negative then 
      res := -bitand( bitnot(value), 0111_1111_1111_1111b ) - 1
    else
      res := bitand(value, 0011_1111_1111_1111b)
    end
    return res;
  end fromTwoComp
   
  procedure integerValueOf*(objectPointer: OOP): integer 
  var res: integer
  begin
    if isInt(objectPointer) then
      res := bitshr(objectPointer, 1)
      res := fromTwoComp(res)
      return res;
    end
    // else
    return 0
  end integerValueOf
  
  procedure isIntegerObject*(objectPointer: OOP): boolean inline
  begin
    return isInt(objectPointer)
  end isIntegerObject
  
  procedure isIntegerValue*(valueWord: integer): boolean
  begin
    // BB description: Return true if value can be represented as an instance of SmallInteger, false if not
    // BB states "valueWord <= -16384 && valueWord > 16834;" which contradicts with the description
    // Note the additional typo error in "16834" which should state "16384"!
    return (valueWord >= -16384) and (valueWord <= 16383)
  end isIntegerValue
  
  procedure getByteLen(obj: Object): integer
  var res: integer
  begin
    res := len(obj.data) 
    if obj.isOdd then dec(res) end
    return res
  end getByteLen
  
  procedure fetchByteString*(objectPointer: OOP): ByteArray 
  var obj : Object; res: ByteArray; s, i: integer
  begin
    if isInt(objectPointer) then return nil end
    obj := getSlot(objectPointer)
    if obj = nil then return nil end
    return obj.data
  end fetchByteString
  
  procedure fetchString*(objectPointer: OOP):string
  var obj : Object; ba: ByteArray; s, i: integer; c: byte
  begin
    if isInt(objectPointer) then 
      return tostring(integerValueOf(objectPointer))
    end
    obj := getSlot(objectPointer)
    if obj = nil then return "nil" end
    s := getByteLen(obj) + 1
    new(ba, s)
    for i := 0 to s-2 do
      c := obj.data[i]
      if c = 0h then ba[i] := 20h
      elsif (c <= 01fh) or (c >= 07fh) then ba[i] := 03fh // "?" 
      else ba[i] := c
      end
    end
    ba[len(ba)-1] := 0h
    return tostring(ba)
  end fetchString
  
  procedure storeFloat(objectPointer: OOP; v: real) 
  var i: integer
  begin
    assert( fetchByteLenghtOf(objectPointer) = 4 )
    i := realToInt(v)
    storeWordOfObject(0,objectPointer,bitand(bitshr(i, 16), 0ffffh))
    storeWordOfObject(1,objectPointer, bitand(i, 0ffffh))
  end storeFloat
  
  procedure fetchFloat(objectPointer: OOP): real 
  var i: integer
  begin
    assert( fetchByteLenghtOf(objectPointer) = 4 )
    i := bitor(
          bitshl(fetchWordOfObject(0,objectPointer), 16),
          fetchWordOfObject(1,objectPointer)
         )
    return intToReal(i)
  end fetchFloat
    
  procedure getRegister*(index: integer): integer 
  begin
    return registers[index]
  end getRegister
  
  procedure setRegister*(index, value: integer) 
  begin
    assert(index < len(registers))
    registers[index] := value
  end setRegister
  
  procedure addTemp*(oop: OOP) 
  begin
    temps[oop] := true
  end addTemp
  
  procedure removeTemp*(oop: OOP) 
  begin
    temps[oop] := false
  end removeTemp

  procedure instantiateClassWithPointers*(classPointer: OOP; instanceSize: integer): OOP inline
  begin
    return instantiateClass( classPointer, bitshl(instanceSize, 1), true )
  end instantiateClassWithPointers
  
  procedure instantiateClass(cls: OOP; byteLen: integer; isPtr: boolean): OOP
  var slot: integer; isOdd: boolean
  begin
    slot := findFreeSlot()
    if slot < 0 then
        collectGarbage()
        slot := findFreeSlot()
    end
    if slot < 0 then
        println("ERROR: cannot allocate object, no free object table slots")
        assert(false)
    end
    isOdd := bitand(byteLen, 1) # 0
    if isOdd then inc(byteLen) end
    if allocate( slot, byteLen, cls, isPtr, isOdd ) = nil then
        println("ERROR: cannot allocate object, no free memory")
        assert(false)
    end
    return bitshl(slot, 1)
  end instantiateClass
  
  procedure findFreeSlot(): integer
  var i: integer
  begin
    for i := 1 to len(slots)-1 do
      if slots[i] = nil then return i end
    end
    return -1
  end findFreeSlot
  
  procedure collectGarbage()
  var i, count: integer; k: array of OOP; obj: Object
  begin 
    for i := 0 to len(registers)-1 do mark(registers[i]) end
    k := keys(temps)
    for i := 0 to len(k)-1 do mark(k[i]) end
    for i := 0 to classSymbol by 2 do mark(i) end

    for i := 0 to len(slots)-1 do
      obj := slots[i]
      if (obj # nil) and (not obj.marked) then
        slots[i] := nil
        inc(count)
      end
      if obj # nil then
        obj.marked := false
      end
    end
    // print("collected ")println(count)
  end collectGarbage
  
  procedure mark(oop: OOP)
  var obj: Object; s, i: integer; cls, sub: OOP
  begin
    if (oop = 0) or isInt(oop) then return end
    obj := getSlot(oop)
    if obj = nil then return end // already free
    if obj.marked then return end // already visited

    obj.marked := true
    
    cls := bitshl(obj.cls,1) 

    if obj.isPtr then
      s := getWordLen(obj)
      for i := 0 to s-1 do
        sub := fetchPointerOfObject(i, oop)
        mark( sub )
      end
    elsif cls = classCompiledMethod then
      s := literalCountOf(oop)
      for i := 0 to s-1 do
        sub := literalOfMethod(i, oop)
        mark( sub )
      end
    end

    mark( cls )
  end mark
  
  procedure instantiateClassWithWords*(classPointer: OOP; instanceSize: integer): OOP 
  begin
    return instantiateClass( classPointer, bitshl(instanceSize, 1), false )
  end instantiateClassWithWords
  
  procedure instantiateClassWithBytes*(classPointer: OOP; instanceByteSize: integer): OOP 
  begin
    return instantiateClass( classPointer, instanceByteSize, false )
  end instantiateClassWithBytes
  
  procedure getNextInstance*(cls, cur: OOP): OOP 
  var start, i: integer
  begin
    start := 0
    if cur # 0 then
      start := bitshr( cur, 1 ) + 1
    end
    for i := start to len(slots)-1 do
      if (slots[i] # nil) and (getClass(slots[i]) = cls)  then
        return bitshl(i, 1)
      end
    end
    return 0
  end getNextInstance
  
  procedure prettyValue*(oop: OOP): string 
  var cls: OOP
  begin
    case oop of
    | objectNil:
        return "nil"
    | objectFalse:
        return "false"
    | objectTrue:
        return "true"
    | processor:
        return "processor"
    | smalltalk:
        return "smalltalk"
    | symbolTable:
        return "symbolTable"
    | symbolDoesNotUnderstand:
        return "symbolDoesNotUnderstand"
    | symbolCannotReturn:
        return "symbolCannotReturn"
    | symbolMonitor:
        return "symbolMonitor"
    | symbolUnusedOop18:
        return "symbolUnusedOop18"
    | symbolMustBeBoolean:
        return "symbolMustBeBoolean"
    | specialSelectors:
        return "specialSelectors"
    | characterTable:
        return "characterTable"
    | 0:
        return "<invalid oop>"
    end
    cls := fetchClassOf(oop)
    case cls of
    | classSmallInteger:
        return tostring( integerValueOf(oop) )
    | classLargePositiveInteger:
        return "oop(" + tostring(oop) + ") " + 
                tostring( largeIntegerValueOf(oop) ) + "L"
    | classLargeNegativeInteger:
        return "oop(" + tostring(oop) + ") " +
                tostring( -largeIntegerValueOf(oop) ) + "L"
    | classString:
        return '"' + fetchString(oop) + '"'
    | classFloat:
        return tostring( fetchFloat(oop) )
    | classPoint:
        return prettyValue(fetchPointerOfObject( 0, oop )) + "@" + 
              prettyValue(fetchPointerOfObject( 1, oop ))
    | classCharacter:
        return tostring(fetchWordOfObject(0,oop))
    | classSymbol:
        return "#" + fetchString(oop)
    | classAssociation:
        return prettyValue( fetchPointerOfObject( 0, oop ) ) + " = " +
                    prettyValue( fetchPointerOfObject( 1, oop ) )
    | 0:
        return "<instance " + tostring(oop) + " with invalid class oop>"
    end
    return "oop(" + tostring(oop) + ") cls(" + tostring(cls) + ")"
  end prettyValue
  
  procedure largeIntegerValueOf(integerPointer: OOP): integer
  var value, length: integer; cls: OOP
  begin
    if isIntegerObject(integerPointer) then
      return integerValueOf(integerPointer)
    end
    value := 0
    // only large positive and negative integers arrive here
    length := fetchByteLenghtOf(integerPointer)
    case length of
    | 0:
        value := 0 // this obviously can happen
    | 1:
        value := fetchByteOfObject(0,integerPointer)
    | 2:
        value := fetchByteOfObject(0, integerPointer)
        value := value + bitshl(fetchByteOfObject(1, integerPointer), 8)
    | 3: 
        // empirically found from examples
        value := fetchByteOfObject(0, integerPointer)
        value := value + bitshl(fetchByteOfObject(1, integerPointer), 8)
        value := value + bitshl(fetchByteOfObject(2, integerPointer), 16)
    | 4:
        // happens in Delay preSnapshot postSnapshot millisecondClockValue
        // see Time millisecondClockInto and primitive99 for format description
        // Milliseconds 1.1.1901 to 9.6.2020: 3'769'154'954
        // e.g. ac9fbf66 = 1723834284L 1'723'834'284
        value := fetchByteOfObject(0, integerPointer) +
                bitshl( fetchByteOfObject(1, integerPointer), 8 ) +
                bitshl( fetchByteOfObject(2, integerPointer), 16 ) +
                bitshl( fetchByteOfObject(3, integerPointer), 24 )
    else
        print("WARNING: large integer with ")
        print(length)
        println(" bytes not supported")
        value := 0ffffffffh
    end
    return value
  end largeIntegerValueOf
  
  procedure realToInt(x: real): integer extern
  procedure intToReal(x: integer): real extern

begin
  new(slots, bitshr(0ffffh, 1))
  new(registers)
  new(temps)
end ObjectMemory