home *** CD-ROM | disk | FTP | other *** search
- #---------------------------------------------------------------------------
- #
- # 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 : @(#)wrpex.tcl /main/titanic/7
- # Original date : Fri May 2 09:36:47 MET DST 1997
- # Author : heli
- # Description : Write Forte pex file from (selected) cex/hex files.
- # If '-hex-only' is specified, then only (selected)
- # hex files will be included. Else (selected) cex
- # files--plus needed hex files--will be included.
- # If no files of some type are are selected, then all
- # available files of that type will be used, if
- # needed.
- #
- #---------------------------------------------------------------------------
- # SccsId = @(#)wrpex.tcl /main/titanic/7 30 Oct 1997 Copyright 1997 Cayenne Software Inc.
- #---------------------------------------------------------------------------
-
- global SCCS_W; set SCCS_W "
- @(#)wrpex.tcl /main/titanic/7
- "
- global progName; set progName "wrpex.tcl"
-
- OTShRegister::objectCustomization
-
- source [m4_path_name tcl cginit.tcl]
- require fstorage.tcl
- require caynutil.tcl
-
- #------------------------------------------------------------------------------
-
- Class SectionList : {GCObject} {
- constructor
- method destructor
- method addSects
- method getSection
- method setSection
- method removeSection
- attribute section
- }
-
- constructor SectionList {class this} {
- set this [GCObject::constructor $class $this]
- $this section [Dictionary new]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method SectionList::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method SectionList::addSects {this nameList} {
- foreach name $nameList {
- if {[$this getSection $name] == ""} {
- $this setSection $name [TextSection new]
- }
- }
- }
-
- method SectionList::getSection {this name} {
- return [[$this section] set $name]
- }
-
- method SectionList::setSection {this name newSection} {
- [$this section] set $name $newSection
- }
-
- method SectionList::removeSection {this name} {
- [$this section] unset $name
- }
-
- #------------------------------------------------------------------------------
-
- global guard
- set guard(includes) "PROJECT INCLUDES"
- set guard(forward) "FORWARD CLASS DECLARATIONS"
- set guard(forwardCursor) "FORWARD CURSOR DECLARATIONS"
- set guard(constant) "CONSTANT DEFINITIONS"
- set guard(C_datatype) "C DATA TYPE DEFINITIONS"
- set guard(typedef) "TYPEDEF DEFINITIONS"
- set guard(class) "CLASS DEFINITIONS"
- set guard(service) "SERVICE OBJECT DEFINITIONS"
- set guard(cursor) "CURSOR DEFINITIONS"
- set guard(method) "METHOD DEFINITIONS"
- set guard(eventHandler) "EVENT HANDLER DEFINITIONS"
-
- global handledFiles; set handledFiles {}
-
-
- Class PEXwriter : GCObject {
- attribute cc
- attribute outList
- attribute sectNameSet
- attribute sections
- attribute includesList
- attribute forwardList
- attribute forwardCursorList
- attribute systemName
- attribute hasErrors
- constructor
- method error
- method warning
- method message
- method addOut
- method addOutInclDeps
- method addFile
- method selectFiles
- method doIncludes
- method doForward
- method doClass
- method doInterface
- method doCursor
- method doService
- method doConstant
- method doTypedef
- method doCdatatype
- method parseFiles
- method writeFiles
- }
-
- constructor PEXwriter {class object} {
- set this [GCObject::constructor $class $object]
-
- $this cc [ClientContext::global]
- $this systemName [[[[$this cc] currentSystem] system] name]
- $this outList [List new]
- $this includesList [List new]
- $this forwardList [List new]
- $this forwardCursorList [List new]
- $this hasErrors 0
-
- $this sectNameSet [List new]
- [$this sectNameSet] contents {
- header
- includes
- forward
- forwardCursor
- constant
- C_datatype
- typedef
- class
- service
- cursor
- method
- eventHandler
- trailer
- }
- $this sections [SectionList new]
- [$this sections] addSects [[$this sectNameSet] contents]
-
- return $this
- }
-
- method PEXwriter::error {this msg} {
- puts stderr "ERROR \[$progName]: $msg."
- $this hasErrors 1
- }
-
- method PEXwriter::warning {this msg} {
- puts stderr "WARNING \[$progName]: $msg."
- }
-
- method PEXwriter::message {this msg} {
- puts stderr "$msg."
- }
-
- method PEXwriter::addOut {this file} {
- if {[[$this outList] search $file] == -1} {
- [$this outList] append $file
- }
- }
-
- method PEXwriter::addOutInclDeps {this file depTbl {_isRecCall 0}} {
- global handledFiles
- if {!$_isRecCall} {
- set handledFiles {}
- }
- if {[$depTbl exists $file]} {
- if {[lsearch -exact $handledFiles $file] != -1} {
- # already handled
- return
- }
- lappend handledFiles $file
- [$depTbl set $file] foreach dep {
- $this addOutInclDeps $dep $depTbl 1
- }
- }
- $this addOut $file
- }
-
- method PEXwriter::addFile {this fileList file} {
- if {[$fileList search -exact $file] == -1} {
- if {[fstorage::exists $file]} {
- $fileList append $file
- } else {
- $this error "$file: no such file"
- }
- }
- }
-
- method PEXwriter::selectFiles {this {argv {}}} {
- # for an explanation, see `Description' at the top of this file
- #
- set hexOnly 0
- set cfileList [List new]
- set hfileList [List new]
- while {![lempty $argv]} {
- set arg [lvarpop argv]
- switch -glob -- $arg {
- -hex-only {set hexOnly 1}
- *.cex {$this addFile $cfileList $arg}
- *.hex {$this addFile $hfileList $arg}
- default {$this warning "$arg: file of this type is ignored"}
- }
- }
-
- set doAllcex [$cfileList empty]
- set doAllhex [$hfileList empty]
- if {!$doAllcex && $hexOnly} {
- $cfileList remove 0 end
- }
- if {!$doAllhex && !$hexOnly} {
- $hfileList remove 0 end
- }
-
- set cmsg ""
- if {!$doAllcex} {
- set cmsg " selected"
- }
- if {$hexOnly} {
- set hmsg ""
- if {!$doAllhex} {
- set hmsg " from selected hex files"
- }
- $this message "Generating pex file$hmsg, while ignoring$cmsg cex files"
- set doAllcex 0
- } else {
- $this message "Generating pex file from$cmsg cex files"
- set doAllhex $doAllcex
- }
-
- # get all hex files, and optionally all cex files
- #
- set allhfileList [List new]
- foreach fileV [[[$this cc] currentSystem] localFileVersions] {
- set type [[$fileV file] type]
- if {$type == "hex"} {
- $allhfileList append [[$fileV file] name].$type
- } elseif {$doAllcex && $type == "cex"} {
- $cfileList append [[$fileV file] name].$type
- }
- }
- $allhfileList sort
- $cfileList sort
-
- # get dependencies from hex files
- #
- set depTbl [Dictionary new]
- $allhfileList foreach hfile {
- if {[catch {set fd [fstorage::open $hfile r]} reason]} {
- puts stderr $reason
- return -1
- }
-
- set readingDeps 0
- set foundDep 0
- while {![eof $fd]} {
- set line [gets $fd]
- if {[regexp "^-- dependency " $line]} {
- set readingDeps 1
- regexp {.*dependency ([^;]*);} $line dummy dependee
- set dependee $dependee.hex
- if {$dependee == $hfile} {
- continue
- }
- set foundDep 1
- if {![$depTbl exists $hfile]} {
- # add slot for dependant in depTbl
- $depTbl set $hfile [List new]
- }
- if {[[$depTbl set $hfile] search $dependee] == -1} {
- # add dependee to dependant's list of dependees
- [$depTbl set $hfile] append $dependee
- }
- } elseif {$readingDeps} {
- break
- }
- }
- if {!$foundDep && ($doAllhex || [$hfileList search $hfile] != -1)} {
- $this addOut $hfile
- }
-
- close $fd
- }
-
- # add remaining hex files to outList, ordered properly
- #
- if {$doAllhex || $hexOnly} {
- foreach hfile [$depTbl names] {
- if {$doAllhex || [$hfileList search $hfile] != -1} {
- $this addOutInclDeps $hfile $depTbl
- }
- }
- } else {
- $cfileList foreach cfile {
- if {[regsub "\.cex$" $cfile ".hex" hfile]} {
- $this addOutInclDeps $hfile $depTbl
- }
- }
- }
-
- # finally if needed, add cex files to outList (in same order as hex files)
- #
- if {!$hexOnly} {
- # we incrementally add to outList: not using List::foreach!!!
- foreach hfile [[$this outList] contents] {
- if {[regsub "\.hex$" $hfile ".cex" cfile]} {
- if {[$cfileList search $cfile] != -1} {
- $this addOut $cfile
- }
- }
- }
- }
-
- if {![[$this outList] empty]} {
- $this message "Packing: [[$this outList] contents]"
- }
-
- return 0
- }
-
- method PEXwriter::doIncludes {this fd line} {
- regexp {.*includes ([^;]*);} $line dummy include
- if {[[$this includesList] search -exact $include] == -1 && $include != [$this systemName]} {
- [$this includesList] append $include
- }
- return 0
- }
-
- method PEXwriter::doForward {this fd line {takeLine 0}} {
- # a forward may be a cursor forward
- #
- if {$takeLine} {
- set theList forwardList
- set forward $line
- } elseif {[regexp {.*forward cursor .*} $line]} {
- set theList forwardCursorList
- regexp {.*forward cursor (.*);} $line dummy forward
- } else {
- set theList forwardList
- regexp {.*forward (.*);} $line dummy forward
- }
- if {[[$this $theList] search -exact $forward] == -1} {
- [$this $theList] append $forward
- }
- return 0
- }
-
- method PEXwriter::doClass {this fd line type} {
- # if 'hex' file then copy class declaration
- #
- if {$type == "hex"} {
- set sect [[$this sections] getSection class]
- $sect append "$line\n"
-
- regexp {class (.*) inherits} $line dummy forward
- $this doForward $fd $forward 1
-
- while {![eof $fd]} {
- set line [gets $fd]
- if {[regexp "^end class;" $line]} {
- $sect append "$line\n\n"
- return 0
- }
- $sect append "$line\n"
- }
- $this warning "unexpected EOF; never did see 'end class;'"
- return -1
- }
-
- # this is a 'cex' file: skip class declaration
- #
- while {![eof $fd]} {
- set line [gets $fd]
- if {[regexp "^end class;" $line]} {
- break
- }
- }
- if {[eof $fd]} {
- $this warning "unexpected EOF; never did see 'end class;'"
- return -1
- }
-
- # collect methods and event handlers
- #
- while {![eof $fd]} {
- set line [gets $fd]
- if {$line == "/* OBSOLETE_CODE *"} {
- $this warning "file contains obsolete code section"
- return -1
- }
- if {[regexp "^method " $line] || [regexp "^event handler " $line]} {
- if {[regexp "^method " $line]} {
- set sect [[$this sections] getSection method]
- set kind method
- } else {
- set sect [[$this sections] getSection eventHandler]
- set kind event
- }
- $sect append "------------------------------------------------------------\n$line\n"
- while {![eof $fd]} {
- set line [gets $fd]
- if {[regexp "^end $kind;" $line]} {
- $sect append "$line\n\n"
- break
- }
- $sect append "$line\n"
- }
- if {[eof $fd]} {
- $this warning "unexpected EOF; never did see 'end $kind;'"
- return -1
- }
- }
- }
- return 0
- }
-
- method PEXwriter::doInterface {this fd line type} {
- # skip 'cex' file
- #
- if {$type == "cex"} {
- return 0
- }
-
- set sect [[$this sections] getSection class]
- $sect append "$line\n"
-
- regexp {interface ([^ ]*)} $line dummy forward
- $this doForward $fd "interface $forward" 1
-
- while {![eof $fd]} {
- set line [gets $fd]
- if {[regexp "^end interface;" $line]} {
- $sect append "$line\n\n"
- return 0
- }
- $sect append "$line\n"
- }
- $this warning "unexpected EOF; never did see 'end interface;'"
- return -1
- }
-
- method PEXwriter::doCursor {this fd line} {
- # forward this cursor
- #
- regexp {^cursor ([^(]*)} $line dummy cursor
- if {[[$this forwardCursorList] search -exact $cursor] == -1} {
- [$this forwardCursorList] append $cursor
- }
-
- # copy this cursor
- #
- set sect [[$this sections] getSection cursor]
- $sect append "$line\n"
- while {![eof $fd]} {
- set line [gets $fd]
- if {[regexp "^end;" $line]} {
- $sect append "$line\n\n"
- return 0
- }
- $sect append "$line\n"
- }
- $this warning "unexpected EOF; never did see 'end;'"
- return -1
- }
-
- method PEXwriter::doService {this fd line} {
- set WS "\[ \t]*"
- set sect [[$this sections] getSection service]
- $sect append "$line\n"
- while {![eof $fd]} {
- set line [gets $fd]
- if {[regexp "^${WS}$" $line]} {
- continue
- } elseif {[regexp "^${WS}--" $line]} {
- continue
- } else {
- $sect append "$line\n"
- }
- }
- return 0
- }
-
- method PEXwriter::doConstant {this fd line} {
- set sect [[$this sections] getSection constant]
- $sect append "$line\n"
- return 0
- }
-
- method PEXwriter::doTypedef {this fd line type} {
- if {$type == "hex"} {
- set sect [[$this sections] getSection typedef]
- $sect append "$line\n"
- }
- return 0
- }
-
- method PEXwriter::doCdatatype {this fd line kind type} {
- if {$type != "hex"} {
- return 0
- }
- set sect [[$this sections] getSection C_datatype]
- $sect append "$line\n"
- while {![eof $fd]} {
- set line [gets $fd]
- if {[regexp "^end $kind;" $line]} {
- $sect append "$line\n\n"
- return 0
- }
- $sect append "$line\n"
- }
- $this warning "unexpected EOF; never did see 'end $kind;'"
- return -1
- }
-
- method PEXwriter::parseFiles {this} {
- set WS "\[ \t]*"
- [$this outList] foreach file {
- switch -glob -- $file {
- *.hex {set type hex}
- default {set type cex}
- }
- if {[catch {set fd [fstorage::open $file r]} reason]} {
- puts stderr $reason
- $this warning "$file: file is skipped"
- continue
- }
-
- set status 0
- while {![eof $fd]} {
- set line [gets $fd]
- if {[regexp "^${WS}$" $line]} {
- continue
- } elseif {[regexp "^-- includes " $line]} {
- if {$type == "hex"} {
- $this doIncludes $fd $line
- }
- } elseif {[regexp "^${WS}--" $line]} {
- continue
- } elseif {[string match forward* $line]} {
- $this doForward $fd $line
- } elseif {[string match class* $line]} {
- set status [$this doClass $fd $line $type]
- break
- } elseif {[string match interface* $line]} {
- set status [$this doInterface $fd $line $type]
- break
- } elseif {[string match cursor* $line]} {
- set status [$this doCursor $fd $line]
- break
- } elseif {[string match service* $line]} {
- $this doService $fd $line
- break
- } elseif {[string match constant* $line]} {
- $this doConstant $fd $line
- break
- } elseif {[string match typedef* $line]} {
- $this doTypedef $fd $line $type
- break
- } elseif {[string match enum* $line]} {
- set status [$this doCdatatype $fd $line enum $type]
- break
- } elseif {[string match struct* $line]} {
- set status [$this doCdatatype $fd $line struct $type]
- break
- } elseif {[string match union* $line]} {
- set status [$this doCdatatype $fd $line union $type]
- break
- } else {
- if {[info exists debug]} {$this warning "$file: unrecognized line is ignored: '$line'"}
- }
- }
- if {$status} {
- $this warning "$file: parse warning"
- }
-
- fstorage::close $fd
- }
- }
-
- method PEXwriter::writeFiles {this {argv {}}} {
- if {[$this selectFiles $argv] == -1} {
- $this error "cannot generate pex file"
- return -1
- }
-
- $this parseFiles
-
- set fileName "[$this systemName].pex"
-
- # create header and trailer
- #
- set sect [[$this sections] getSection header]
- $sect append "begin TOOL [$this systemName];\n"
- $sect append "\n"
- expandHeaderIntoSection $fileName forte $sect
- set sect [[$this sections] getSection trailer]
- $sect append "\nend [$this systemName];\n"
-
- # process includes
- #
- set sect [[$this sections] getSection includes]
- [$this includesList] foreach include {
- if {$include != ""} {
- $sect append "includes $include;\n"
- }
- }
-
- # process forwards
- #
- set sect [[$this sections] getSection forward]
- [$this forwardList] foreach forward {
- if {$forward != ""} {
- $sect append "forward $forward;\n"
- }
- }
-
- # process cursor forwards
- #
- set sect [[$this sections] getSection forwardCursor]
- [$this forwardCursorList] foreach forward {
- if {$forward != ""} {
- $sect append "forward cursor $forward;\n"
- }
- }
-
- # write all to one section
- #
- set sect [TextSection new]
- [$this sectNameSet] foreach sectName {
- set genSect [[$this sections] getSection $sectName]
- set guardStr ""
- if {[info exists guard($sectName)]} {
- set guardStr $guard($sectName)
- $sect append "\n-- START $guardStr\n"
- }
- if {[$genSect contents] != ""} {
- $sect appendSect $genSect
- #$sect append "\n"
- }
- if {$guardStr != ""} {
- $sect append "-- END $guardStr\n"
- }
- }
-
- if {[info exists debug]} {puts -nonewline stderr [$sect contents]}
-
- if {[catch {set fd [fstorage::open $fileName w]} reason]} {
- puts stderr $reason
- $this error "cannot continue generating pex file"
- return -1
- }
- $sect write $fd
- fstorage::close $fd
- $this message "Wrote pex file '$fileName'"
- return 0
- }
-
- #------------------------------------------------------------------------------
-
- proc setProg {} {
- set name [string trim $SCCS_W "\n%"]
- if {$name != "W"} {
- regexp "@.#.(.*)\t" $name dummy name
- global progName
- set progName $name
- }
- }
-
- proc main {{argv {}}} {
- # usage: main {file1 file2 ...} , where list of files is optional
- #
- set cc [ClientContext::global]
- set phaseV [$cc currentPhase]
- if {[$phaseV isNil] || [[$phaseV phase] type] != "Implementation"} {
- puts stderr "ERROR\[$progName]: phase type must be 'Implementation'."
- return -1
- }
- if {[[$cc currentSystem] isNil]} {
- puts stderr "ERROR\[$progName]: client context must be at system level."
- return -1
- }
-
- set pexWriter [PEXwriter new]
- $pexWriter writeFiles $argv
- return [$pexWriter hasErrors]
- }
-
- #------------------------------------------------------------------------------
-
-
-
- setProg
-
- puts stderr "Generate pex File"
- puts stderr "=================\n"
-
- if {[catch {set status [main $argv]} reason]} {
- puts stderr $reason
- puts stderr "Failed to write pex file."
- } else {
- if {$status} {
- puts stderr "Failed to write pex file."
- }
- }
-
- puts stderr "\n`Generate pex File' finished"
-