PC World 1998 October/PCWorld_1998-10_cd.bin/software/prehled/komix/DATA.Z/stgrammar.tcl

Text File | 1997-12-01 | 25KB | 928 lines

#---------------------------------------------------------------------------
#
# Copyright (c) 1997 by Cayenne Software, Inc.
#
# This software is furnished under a license and may be used only in
# accordance with the terms of such license and with the inclusion of
# the above copyright notice. This software or any other copies thereof
# may not be provided or otherwise made available to any other person.
# No title to and ownership of the software is hereby transferred.
#
# The information in this software is subject to change without notice
# and should not be construed as a commitment by Cayenne Software, Inc.
#
#---------------------------------------------------------------------------
#
#       File            : stgrammar.tcl
#       Author          :
#       Original date   : November 1997
#       Description     : Classes for code generation
#
#---------------------------------------------------------------------------


#      File:           @(#)stclassimp.tcl    /main/titanic/2


# This class represents all code generated to implement one class.
# It is also responsible for method and category management:
# keeping names unique and creating and assigning categories.

Class STClassImplementation : {GCObject} {
    method destructor
    method generate
    method getInstanceMethodImplementation
    method getClassMethodImplementation
    method getMethodImplementation
    method methodExists
    method classMethodExists
    constructor
    method addExpression
    method addCommentLine
    method addInstanceVariable
    method addClassVariable
    method addPoolDictionary

    # Name of the class.
    #
    attribute name

    # The comment for this implementation.
    #
    attribute comment

    # List of instance variables of the class.
    #
    attribute instanceVars

    # List of class variables of the class.
    #
    attribute classVars

    # List of pool dictionaries of the class.
    #
    attribute poolDicts

    # The name of the super class of this class.
    #
    attribute super

    # Category of this class.
    #
    attribute category

    # Type of inheritance, empty for normal, or variable or variableByte.
    #
    attribute inheritanceType
    attribute initialize
    attribute release
    attribute printOn
    attribute printVars
    attribute expressionSet
    attribute classMethodCategory
    attribute instanceMethodCategory
    attribute instanceMethodImplementation
    attribute classMethodImplementation
}

method STClassImplementation::destructor {this} {
    # Start destructor user section
    # End destructor user section
}


# Generates all the code to implement one class on section stSection.
# Order: Class declaration, class comment, class message categories, instance message categories,
# expressions.
#
method STClassImplementation::generate {this stSection} {
    # if there is no superclass no code was generated for this class
    if { [$this super] == "" } {
        return
    }

    $stSection append "[$this super] [$this inheritanceType]"

    if {[$this inheritanceType] == "" } {
        $stSection append "subclass"
    } else {
        $stSection append "Subclass"
    }

    $stSection append ": #[$this name]\n"
    $stSection indent +

    $stSection append "instanceVariableNames: \'"
    $stSection append "[[$this instanceVars] contents]\'\n"

    $stSection append "classVariableNames: \'"
    $stSection append "[[$this classVars] contents]\'\n"

    $stSection append "poolDictionaries: \'"
    $stSection append "[[$this poolDicts] contents]\'\n"

    $stSection append "category: \'[$this category]\'!\n"
    $stSection indent -

    if {[$this comment] != "" } {
        $stSection append "\n"
        $stSection append "[$this name] comment: \'"
        $stSection append "[$this comment]\'!\n"
    }

    foreach category [[$this classMethodCategory] values] {
        $stSection append "\n"
        $category generate $stSection
    }

    foreach category [[$this instanceMethodCategory] values] {
        $stSection append "\n"
        $category generate $stSection
    }

    [$this expressionSet] foreach expression {
        $stSection append "\n"
        $expression generate $stSection
        $stSection append "!"
    }
}


# Gets a method implementation object for <selector>;
# creates it in category <category> if it didn't exist yet. If it existed already
# the category is updated.
# The old category is deleted if it is empty.
# The category <category> is created if it didn't exist yet.
# if <category> is empty, the implementation object is returned if it existed already.
#
method STClassImplementation::getInstanceMethodImplementation {this selector category} {
    set selDict [$this instanceMethodImplementation]
    set catDict [$this instanceMethodCategory]
    return [$this getMethodImplementation $selector $category $selDict $catDict ""]
}

method STClassImplementation::getClassMethodImplementation {this selector category} {
    set selDict [$this classMethodImplementation]
    set catDict [$this classMethodCategory]
    return [$this getMethodImplementation $selector $category $selDict $catDict "class"]
}


# Shared code for getInstanceMethodImplementation and
# getClassMethodImplementation.
#
method STClassImplementation::getMethodImplementation {this selector category selectorDict categoryDict type} {
    # if category is "" return implementation if it exists
    if { $category == "" } {
        return [$selectorDict set $selector]
    }

    # create category if needed
    if [$categoryDict exists $category] {
        set methodCategory [$categoryDict set $category]
    } else {
        set methodCategory [STMethodCategory new [$this name] $category $type]
        $categoryDict set $category $methodCategory
    }

    # If selector existed: check if old category gets empty:
    # and delete if this is the case
    if [$selectorDict exists $selector] {
        set implementation [$selectorDict set $selector]
        set oldCategory [$implementation methodCategory]
        $implementation methodCategory $methodCategory
        if [$oldCategory isEmpty] {
            $categoryDict unset [$oldCategory categoryName]
        }
        # trash prevention: remove arguments in case method is both
        # generated and defined by user.
        if { ![[$implementation arguments] empty] } {
            [$implementation arguments] remove 0 end
        }
    } else {
        set implementation [STMethodImplementation new $selector $methodCategory]
        $selectorDict set $selector $implementation
    }
    return $implementation
}


# Returns 1 if the there is a method implementation object with the specified selector
# in the instanceMethodImplementation association.
#
method STClassImplementation::methodExists {this selector} {
    return [[$this instanceMethodImplementation] exists $selector]
}


# Returns 1 if there is a class method object with the specified selector
# in the classMethodImplementation association.
#
method STClassImplementation::classMethodExists {this selector} {
    return [[$this classMethodImplementation] exists $selector]
}


# Initializes all attributes to their specified types (lists and dictionaries)
# and stores <name> in name.
#
constructor STClassImplementation {class this name} {
    set this [GCObject::constructor $class $this]
    $this instanceVars [List new]
    $this classVars [List new]
    $this poolDicts [List new]
    $this expressionSet [List new]
    $this classMethodCategory [Dictionary new]
    $this instanceMethodCategory [Dictionary new]
    $this instanceMethodImplementation [Dictionary new]
    $this classMethodImplementation [Dictionary new]
    $this name $name
    # Start constructor user section
    # End constructor user section
    return $this
}


# Creates a new expression with contents <contents>, add it to the expression association and return it.
#
method STClassImplementation::addExpression {this contents} {
    set expression [STExpression new $contents]
    [$this expressionSet] append $expression
    return $expression
}


# Add a new comment line with contents commentText to instance variable comment.
#
method STClassImplementation::addCommentLine {this commentText} {
    if { [$this comment] != "" } {
        $this comment "[$this comment]\n$commentText"
    } else {
        $this comment $commentText
    }
}


# Adds name to instance variable list.
#
method STClassImplementation::addInstanceVariable {this name} {
    [$this instanceVars] append $name
}


# Add name to class variable list.
#
method STClassImplementation::addClassVariable {this name} {
    [$this classVars] append $name
}


# Add name to pool dictionary list.
#
method STClassImplementation::addPoolDictionary {this name} {
    [$this poolDicts] append $name
}

# Do not delete this line -- regeneration end marker



#---------------------------------------------------------------------------
#      File:           @(#)stexprpart.tcl    /main/titanic/2


# Part of a smalltalk expression. Objects of this class are additional parts,
# objects of subclass Expression are first parts.

Class STExprPart : {GCObject} {
    method destructor
    constructor
    method generate
    method generateExpressions
    method addExpression
    method addArgument

    # Contents of expression part.
    #
    attribute contents

    # Used to store block arguments.
    #
    attribute arguments
    attribute expressionSet
}

method STExprPart::destructor {this} {
    # Start destructor user section
    # End destructor user section
}


# Initializes the expression association,
# the arguments list and sets contents to <contents>.
#
constructor STExprPart {class this contents} {
    set this [GCObject::constructor $class $this]
    $this contents $contents
    $this expressionSet [List new]
    $this arguments [List new]
    return $this
}


# Generates on stSection.
#
method STExprPart::generate {this stSection} {
    # put it on same line if one line, on new lines otherwise
    $stSection append [$this contents]
    $stSection indent +
    $this generateExpressions $stSection
    $stSection indent -
}


# Generates the subexpressions and block arguments of this expression on stSection.
#
method STExprPart::generateExpressions {this stSection} {
    # Do block argument if it exists
    set blockArgument ""
    if { ![[$this arguments] empty] } {
        [$this arguments] foreach argument {
            set blockArgument "$blockArgument :$argument"
        }
        set blockArgument "$blockArgument | "
    }

    # put on new line if multiple lines or line too long.
    if {![[$this expressionSet] empty]} {
        if {[[$this expressionSet] length] > 1 } {
            set newLine 1
        } else {
            set contentsLength [string length [$this contents]]
            set contentsLength [expr $contentsLength+[string length $blockArgument]]
            set expression [[$this expressionSet] index 0]
            set expressionLength [string length [$expression contents]]
            if {[expr $contentsLength+$expressionLength+4] > 70 } {
                set newLine 1
            } else {
                set newLine 0
            }
        }

        if $newLine {
            $stSection append "\n\[$blockArgument"
        } else {
            $stSection append " \[$blockArgument"
        }

        set first 1
        [$this expressionSet] foreach expression {
            if $first {
                set first 0
            } else {
                $stSection append ".\n"
            }
            $expression generate $stSection
        }

        $stSection append "\]"
    }
}


# Create a new expression object, add it to the expression association and return it.
#
method STExprPart::addExpression {this contents} {
    set expression [STExpression new $contents]
    [$this expressionSet] append $expression
    return $expression
}


# Add argument to arguments list.
#
method STExprPart::addArgument {this name} {
    [$this arguments] append $name
}

# Do not delete this line -- regeneration end marker



#---------------------------------------------------------------------------
#      File:           @(#)stmethodca.tcl    /main/titanic/2


# This class represents the code generated for a method category.

Class STMethodCategory : {GCObject} {
    method destructor
    constructor
    method generate
    method isEmpty
    method methodImplementationSet

    # Name of the category.
    #
    attribute categoryName

    # Class to which this category belongs.
    #
    attribute className

    # Type of this category: class or instance.
    #
    attribute categoryType
    attribute _methodImplementationSet
}

method STMethodCategory::destructor {this} {
    # Start destructor user section
    # End destructor user section
}


# Sets className to <className>, categoryName to <categoryName>,
# categoryType to <categoryType> and initialize methodImplementation.
#
constructor STMethodCategory {class this className categoryName categoryType} {
    set this [GCObject::constructor $class $this]
    $this className $className
    $this categoryName $categoryName
    $this categoryType $categoryType
    $this _methodImplementationSet [List new]
    return $this
}


# This method generates the method category on stSection.
#
method STMethodCategory::generate {this stSection} {
    # category header
    $stSection append "![$this className] "
    if { [$this categoryType] == "class" } {
        $stSection append "class "
    }
    $stSection append "methodsFor: \'[$this categoryName]\'!\n\n"

    # methods in this category
    set first 1
    [$this methodImplementationSet] foreach implementation {
        if  !$first {
            $stSection append "\n\n"
        } else {
            set first 0
        }
        $implementation generate $stSection
    }

    # closing !
    $stSection append " !\n"
}


# Returns whether this category is empty
# e.g. the methodImplementation association is empty.
#
method STMethodCategory::isEmpty {this} {
    return [[$this methodImplementationSet] empty]
}

# Do not delete this line -- regeneration end marker

method STMethodCategory::methodImplementationSet {this} {
    return [$this _methodImplementationSet]
}



#---------------------------------------------------------------------------
#      File:           @(#)stfile.tcl    /main/titanic/3


# This class represents the contents of a Smalltalk file.

Class STFile : {GCObject} {
    constructor
    method destructor
    method generate
    method getImplementation
    method setImplementation
    method removeImplementation
    attribute implementation
}

constructor STFile {class this} {
    set this [GCObject::constructor $class $this]
    $this implementation [Dictionary new]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STFile::destructor {this} {
    # Start destructor user section
    # End destructor user section
}


# Generates the contents of all associated objects in stSection.
#
method STFile::generate {this stSection} {
    set first 1
    [$this implementation] foreach name implementation {
        if $first {
            set first 0
        } else {
            $stSection append "\n\n\n"
        }
        $implementation generate $stSection
    }
}


# Gets a STClassImplementation object for class 'name' and creates it if it didn't exist yet.
#
method STFile::getImplementation {this name} {
    if [[$this implementation] exists $name] {
        return [[$this implementation] set $name]
    }

    set newImplementation [STClassImplementation new $name]
    [[$this implementation] set $name $newImplementation
    return $newImplementation
}

# Do not delete this line -- regeneration end marker

method STFile::setImplementation {this name newImplementation} {
    [$this implementation] set $name $newImplementation
}

method STFile::removeImplementation {this name} {
    [$this implementation] unset $name
}



#---------------------------------------------------------------------------
#      File:           @(#)stmethodim.tcl    /main/titanic/2


# This class represents a method implementation: the header, the temporary variables and the
# expressions in the body. It is also responsible for creating unique argument names.

Class STMethodImplementation : {GCObject} {
    method destructor
    constructor
    method generate
    method getNewUniqueArgumentName
    method getUniqueArgumentName
    method addExpression
    method insertExpression
    method addCommentLine
    method addArgument
    method addTemporary
    method getArguments
    method isEmpty
    method methodCategory

    # The message selector of this implementation.
    #
    attribute selector

    # Stores argument name for each part of the selector.
    # Needed for initialize.
    #
    attribute selectorpartToArgument

    # Used to store the non unique argument names and number of occurrences.
    # Needed for efficient generation of unique names.
    #
    attribute argumentToFrequency

    # The argument names of this method.
    #
    attribute arguments

    # Temporary variables of this method.
    #
    attribute temporaries

    # The method comment (appears between method header and method implementation).
    #
    attribute comment

    # Indicates whether this method has a user code part.
    # Is considered to be 1 if isUserDefined is set.
    #
    attribute hasUserCodePart

    # Set if user code was found during
    # regeneration.
    #
    attribute hasUserCode

    # Indicates whether this is a user defined method implementation.
    #
    attribute isUserDefined
    attribute _methodCategory
    attribute expressionSet
}

method STMethodImplementation::destructor {this} {
    # Start destructor user section
    # End destructor user section
}


# Initializes the dictionaries, the associations
# comment to the empty string, the *User* attributes to
# 0 and the lists and sets selector to <selector>
# and methodCategory to <category>.
#
constructor STMethodImplementation {class this selector category} {
    set this [GCObject::constructor $class $this]
    $this selector $selector
    $this methodCategory $category
    $this selectorpartToArgument [Dictionary new]
    $this argumentToFrequency [Dictionary new]
    $this arguments [List new]
    $this temporaries [List new]
    $this expressionSet [List new]
    $this comment ""
    $this isUserDefined 0
    $this hasUserCodePart 0
    $this hasUserCode 0
    return $this
}


# Generates the method implementation on section stSection.
# Insert regeneration markers if required.
# Generate a not implemented comment if the implementation
# has no expressions.
#
method STMethodImplementation::generate {this stSection} {
    # method header
    if [[$this arguments] empty] {
        $stSection append "[$this selector]"
    } elseif { [[$this arguments] length] == 1 } {
        # Workaround for operator- as mentioned in STGOperation
        if { [$this selector] == "operator-" } {
            $stSection append "- [[$this arguments] index 0]"
        } else {
            $stSection append "[$this selector] [[$this arguments] index 0]"
        }
    } else {
        set index 0
        set selectorPartList [split [$this selector] ':']
        [$this arguments] foreach argument {
            if { $index > 0 } {
                $stSection append " "
            }
            set selectorPart [lindex $selectorPartList $index]
            # trash prevention: should go away once qualifier initializer bug
            # is fixed.
            if { $selectorPart == "" } {
                break
            }
            $stSection append "$selectorPart: $argument"
            set index [expr $index+1]
        }
    }

    # comment,     temporaries, "Generated" comment
    # This comment is put in methods without user code
    $stSection indent +
    if {[$this comment] != ""} {
        $stSection append "\n\"[$this comment]\""
    }
    if { (![$this isUserDefined]) && ![$this hasUserCodePart] } {
        $stSection append "\n\"Generated\""
    }
    if {![[$this temporaries] empty]} {
        $stSection append "\n| [[$this temporaries] contents] |"
    }

    # expressions
    set index 0
    set exprCnt [[$this expressionSet] length]
    [$this expressionSet] foreach expression {
        if { $index > 0 } {
            $stSection append ".\n"
        } else {
            $stSection append "\n"
        }

        # if there was user added code it is in the last expression
        # generate this without indent and place a separator if necessary
        if  { [$this hasUserCode] && ($index == [expr $exprCnt-1]) } {
            if { $index > 0 } {
                $stSection append "[$globals startUserCodeMarker]\n"
            }
            $stSection indent -
        }

        $expression generate $stSection

        set index [expr $index+1]
    }

    if  ![$this hasUserCode] {
        if [$this isUserDefined] {
            if { $exprCnt > 0 } {
                $stSection append ".\n[$globals startUserCodeMarker]"
            }
            $stSection append "\n\"Not yet implemented\""
        } elseif [$this hasUserCodePart] {
            if { $exprCnt > 0 } {
                $stSection append "."
            }
            $stSection append "\n[$globals startUserCodeMarker]"
        }
        $stSection indent -
    }
    # closing !
    $stSection append "!"
}


# Gets a new unique argument name and adds it to argument list.
#
method STMethodImplementation::getNewUniqueArgumentName {this name} {
    if [[$this argumentToFrequency] exists $name] {
        set frequency [[$this argumentToFrequency] set $name]
        set uniqueName "$name$frequency"
        [$this argumentToFrequency] set $name [expr $frequency+1]
    } else {
        set uniqueName $name
        [$this argumentToFrequency] set $name 1
    }

    [$this arguments] append $uniqueName
    return $uniqueName
}


# If selectorpart existed in selectorpartToArgument, return argument.
# If not get unique argument name for this selector part and store it in selectorPartToArgument.
#
method STMethodImplementation::getUniqueArgumentName {this selectorpart {name ""}} {
    if [[$this selectorpartToArgument] exists $selectorpart] {
        return [[$this selectorpartToArgument] set $selectorpart]
    }

    set uniqueName [$this getNewUniqueArgumentName $name]
    [$this selectorpartToArgument] set $selectorpart $uniqueName
    return $uniqueName
}


# Create new expression object with contents <contents>, add it to the expression association and return it.
#
method STMethodImplementation::addExpression {this contents} {
    set expression [STExpression new $contents]
    [$this expressionSet] append $expression
    return $expression
}


# Create new expression with contents contents, insert in the expression association and return it.
#
method STMethodImplementation::insertExpression {this contents} {
    set expression [STExpression new $contents]
    [$this expressionSet] insert $expression
    return $expression
}


# Add new line with <commentText> to comment.
#
method STMethodImplementation::addCommentLine {this commentText} {
    if { [$this comment] != "" } {
        $this comment "[$this comment]\n$commentText"
    } else {
        $this comment $commentText
    }
}


# Add argument name to argument list.
#
method STMethodImplementation::addArgument {this name} {
    [$this arguments] append $name
}


# Add temporary name to temporaries list.
#
method STMethodImplementation::addTemporary {this name} {
    [$this temporaries] append $name
}


# Return list of argument names.
#
method STMethodImplementation::getArguments {this} {
    return [$this arguments]
}


# Returns 1 if the expression association is empty, 0 otherwise.
#
method STMethodImplementation::isEmpty {this} {
    return [[$this expressionSet] empty]
}

# Do not delete this line -- regeneration end marker

method STMethodImplementation::methodCategory {this args} {
    if {$args == ""} {
        return [$this _methodCategory]
    }
    set ref [$this _methodCategory]
    if {$ref != ""} {
        [$ref _methodImplementationSet] removeValue $this
    }
    set obj [lindex $args 0]
    if {$obj != ""} {
        [$obj _methodImplementationSet] append $this
    }
    $this _methodCategory $obj
}



#---------------------------------------------------------------------------
#      File:           @(#)stexpressi.tcl    /main/titanic/2


# This class represents one Smalltalk expression.
# It always contains the first part of an expression. If there are more
# parts, these are stored in STExprPart objects.
# This is an optimization compared to the syntax,
# suggested by the fact that additional parts are not very often used by the code generator.
# For regeneration the user added expressions are considered as one expression.

Class STExpression : {STExprPart} {
    constructor
    method destructor
    method generate
    method addExpressionPart
    attribute expressionPartSet
}

constructor STExpression {class this contents} {
    set this [STExprPart::constructor $class $this $contents]
    $this expressionPartSet [List new]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STExpression::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this STExprPart::destructor
}


# Generates expression contents on stSection.
#
method STExpression::generate {this stSection} {
    $stSection append [$this contents]
    $stSection indent +

    # if there are xpression parts use extra indent
    set numberParts [[$this expressionPartSet] length]
    if $numberParts {
        $stSection indent +
    }

    $this generateExpressions $stSection

    $stSection indent -

    # now the other expression parts
    if $numberParts {
        [$this expressionPartSet] foreach expressionPart {
            $stSection append "\n"
            $expressionPart generate $stSection
        }
        $stSection indent -
    }
}


# Creates an ExprPart object, adds it to the expressionPart association and returns it.
#
method STExpression::addExpressionPart {this contents} {
    set expressionPart [STExprPart new $contents]
    [$this expressionPartSet] append $expressionPart
    return $expressionPart
}

# Do not delete this line -- regeneration end marker