Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/BIPL.ZIP/IDOL.ZIP/IDOL.IOL

Text File | 1991-12-30 | 22.7 KB | 864 lines

#
# global variables
#
global fin,fout,fName,fLine,alpha,alphadot,white,nonwhite,nonalpha
global classes,comp,exec,strict,links,imports,loud,compiles,compatible,ct
#
# gencode first generates specifications for all defined classes
# It then imports those classes' specifications which it needs to
# compute inheritance.  Finally, it writes out all classes' .icn files.
#
procedure gencode()
  if \loud then write("Class import/export:")
  #
  # export specifications for each class
  #
  every cl := classes$foreach_t() do cl$writespec()
  #
  # import class specifications, transitively
  #
  repeat {
    added := 0
    every super:= ((classes$foreach_t())$foreachsuper() | !imports) do{
      if /classes$lookup(super) then {
    added := 1
    fname := filename(super)
    readinput(envpath(fname),2)
    if /classes$lookup(super) then halt("can't import class '",super,"'")
    writesublink(fname)
      }
    }
    if added = 0 then break
  }
  #
  # compute the transitive closure of the superclass graph
  #
  every (classes$foreach_t())$transitive_closure()
  #
  # generate output
  #
  if \loud then write("Generating code:")
  writesublink("i_object")
  every s := !links do writelink(s)
  write(fout)
  every out := $!classes do {
    name := filename(out$name())
    out$write()
    put(compiles,name)
    writesublink(name)
  }
  if *compiles>0 then return cdicont(compiles)
  else return
end

#
# a class defining objects resulting from parsing lines of the form
# tag name ( field1 , field2, ... )
# If the constructor is given an argument, it is passed to self$read
#
class declaration(public name,fields,tag)
  #
  # parse a declaration string into its components
  #
  method read(decl)
    decl ? (
      (tab(many(white)) | "") ,
      # get my tag
      (self.tag := =("procedure"|"class"|"method"|"record")) ,
      (tab(many(white)) | "") ,
      # get my name
      (self.name := tab(many(alpha))) ,
      # get my fields
      (tab(find("(")+1)),
      (tab(many(white)) | "") ,
      ((self.fields := classFields())$parse(tab(find(")"))))
    ) | halt("declaration/read can't parse decl ",decl)
  end

  #
  # write a declaration; at the moment, only used by records
  #
  method write(f)
     write(f,self$String())
  end
  #
  # convert self to a string
  #
  method String()
    return self.tag || " " || self.name || "(" || self.fields$String() || ")"
  end
initially
  if \self.name then self$read(self.name)
end

#
# A class for ordinary Icon global declarations
#
class vardecl(s)
  method write(f)
    write(f,self.s)
  end
end

#
# A class defining the constants for a given scope
#
class constant(t)
  method expand(s)
    i := 1
    #
    # conditions for expanding a constant:
    # must not be within a larger identifier nor within a quote
    #
    while ((i <- find(k <- $!self,s,i)) & ((i=1) | any(nonalpha,s[i-1])) &
      ((*s = i+*k-1) | any(nonalpha,s[i+*k])) &
          notquote(s[1:i])) do {
    val := \ (self.t[k]) | stop("internal error in expand")
    s[i +: *k] := val
#    i +:= *val
    }
    return s
  end
  method foreach() # in this case, we mean the keys, not the values
    suspend key(self.t)
  end
  method eval(s)
    if s2 := \ self.t[s] then return s2
  end
  method parse(s)
    s ? {
    k := trim(tab(find(":="))) | fail
    move(2)
    tab(many(white))
    val := tab(0) | fail
    (*val > 0) | fail
    self.t [ k ] := val
    }
    return
  end
  method append(cd)
    every s := cd$parse do self$parse(s)
  end
initially
  self.t := table()
end

#
# A class defining a single constant declaration
#
class constdcl : vardecl()
  # suspend the individual constant := value strings
  method parse()
    self.s ? {
    tab(find("const")+6)
    tab(many(white))
    while s2 := trim(tab(find(","))) do {
        suspend s2
        move(1)
        tab(many(white))
    }
    suspend trim(tab(0))
    }
  end
end

#
# class body manages a list of strings holding the code for
# procedures/methods/classes
#
class body(fn,ln,vars,text)
  method read()
    self.fn    := fName
    self.ln    := fLine
    self.text  := []
    while line := readln() do {
      put(self.text, line)
      line ? {
      tab(many(white))
      if ="end" & &pos > *line then return
      else if =("local"|"static"|"initial") & any(nonalpha) then {
          self.ln +:= 1
          pull(self.text)
          / (self.vars) := []
          put(self.vars, line)
      }
      }
    }
    halt("body/read: eof inside a procedure/method definition")
  end
  method write(f)
    if \self.vars then every write(f,!self.vars)
    if \compatible then write(f,"  \\self := self.__state")
    if \self.ln then
    write(f,"#line ",self.ln + ((*\self.vars)|0)," \"",self.fn,"\"")
    every write(f,$!self)
  end
  method delete()
    return pull(self.text)
  end
  method size()
    return (*\ (self.text)) | 0
  end
  method foreach()
    if t := \self.text then suspend !self.text
  end
end

#
# a class defining operations on classes
#
class class : declaration (supers,methods,text,imethods,ifields,glob)
  # imethods and ifields are all lists of these:
  record classident(class,ident)

  method read(line,phase)
    self$declaration.read(line)
    self.supers := idTaque(":")
    self.supers$parse(line[find(":",line)+1:find("(",line)] | "")
    self.methods:= taque()
    self.text   := body()
    while line  := readln("wrap") do {
      line ? {
    tab(many(white))
    if ="initially" then {
        self.text$read()
        if phase=2 then return
        self.text$delete()    # "end" appended manually during writing after
                # generation of the appropriate return value
        return
    } else if ="method" then {
        decl := method(self.name)
        decl$read(line,phase)
        self.methods$insert(decl,decl$name())
    } else if ="end" then {
        # "end" is tossed here. see "initially" above
        return
    } else if ="procedure" then {
        decl := method("")
        decl$read(line,phase)
        /self.glob := []
        put(self.glob,decl)
    } else if ="global" then {
        /self.glob := []
        put(self.glob,vardecl(line))
    } else if ="record" then {
        /self.glob := []
        put(self.glob,declaration(line))
    } else if upto(nonwhite) then {
        halt("class/read expected declaration on: ",line)
    }
      }
    }
    halt("class/read syntax error: eof inside a class definition")
  end

  #
  # Miscellaneous methods on classes
  #
  method has_initially()
    return $*self.text > 0
  end
  method ispublic(fieldname)
    if self.fields$ispublic(fieldname) then return fieldname
  end
  method foreachmethod()
    suspend $!self.methods
  end
  method foreachsuper()
    suspend $!self.supers
  end
  method foreachfield()
    suspend $!self.fields
  end
  method isvarg(s)
    if self.fields$isvarg(s) then return s
  end
  method transitive_closure()
    count := $*self.supers
    while count > 0 do {
    added := taque()
    every sc := $!self.supers do {
      if /(super := classes$lookup(sc)) then
        halt("class/transitive_closure: couldn't find superclass ",sc)
      every supersuper := super$foreachsuper() do {
        if / self.supers$lookup(supersuper) &
         /added$lookup(supersuper) then {
          added$insert(supersuper)
        }
      }
    }
    count := $*added
    every self.supers$insert($!added)
    }
  end
  #
  # write the class declaration: if s is "class" write as a spec
  # otherwise, write as a constructor
  #
  method writedecl(f,s)
    writes(f, s," ",self.name)
    if s=="class" & ( *(supers := self.supers$String()) > 0 ) then
        writes(f," : ",supers)
    writes(f,"(")
    rv := self.fields$String(s)
    if *rv > 0 then rv ||:= ","
    if s~=="class" & *(\self.ifields)>0 then    {    # inherited fields
      every l := !self.ifields do rv ||:= l.ident || ","
      if /(superclass := classes$lookup(l.class)) then
      halt("class/resolve: couldn't find superclass ",sc)
      if superclass$isvarg(l.ident) then rv := rv[1:-1]||"[],"
    }
    writes(f,rv[1:-1])
    write(f,,")")
  end
  method writespec(f) # write the specification of a class
    f := envopen(filename(self.name),"w")
    self$writedecl(f,"class")
    every ($!self.methods)$writedecl(f,"method")
    if self$has_initially() then write(f,"initially")
    write(f,"end")
    close(f)
  end

  #
  # write out the Icon code for this class' explicit methods
  # and its "nested global" declarations (procedures, records, etc.)
  #
  method writemethods()
    f:= envopen(filename(self.name,".icn"),"w")
    every ($!self.methods)$write(f,self.name)

    if \self.glob & *self.glob>0 then {
    write(f,"#\n# globals declared within the class\n#")
    every i := 1 to *self.glob do (self.glob[i])$write(f,"")
    }
    close(f)
  end

  #
  # write - write an Icon implementation of a class to file f
  #
  method write()
    f:= envopen(filename(self.name,".icn"),"a")
    #
    # must have done inheritance computation to write things out
    #
    if /self.ifields then self$resolve()

    #
    # write a record containing the state variables
    #
    writes(f,"record ",self.name,"__state(__state,__methods") # reserved fields
    rv := ","
    rv ||:= self.fields$idTaque.String()             # my fields
    if rv[-1] ~== "," then rv ||:= ","
    every s := (!self.ifields).ident do rv ||:= s || "," # inherited fields
    write(f,rv[1:-1],")")

    #
    # write a record containing the methods
    #
    writes(f,"record ",self.name,"__methods(")
    rv := ""

    every s := ((($!self.methods)$name())    |    # my explicit methods
        self.fields$foreachpublic()    |    # my implicit methods
        (!self.imethods).ident        |    # my inherited methods
        $!self.supers)                # super.method fields
    do rv ||:= s || ","

    if *rv>0 then rv[-1] := ""            # trim trailling ,
    write(f,rv,")")

    #
    # write a global containing this classes' operation record
    # along with declarations for all superclasses op records
    #
    writes(f,"global ",self.name,"__oprec")
    every writes(f,", ", $!self.supers,"__oprec")
    write(f)

    #
    # write the constructor procedure.
    # This is a long involved process starting with writing the declaration.
    #
    self$writedecl(f,"procedure")
    write(f,"local self,clone")

    #
    # initialize operation records for this and superclasses
    #
    write(f,"initial {\n",
        "  if /",self.name,"__oprec then ",self.name,"initialize()")
    if $*self.supers > 0 then
    every (super <- $!self.supers) ~== self.name do
        write(f,"  if /",super,"__oprec then ",super,"initialize()\n",
            "  ",self.name,"__oprec.",super," := ", super,"__oprec")
    write(f,"  }")

    #
    # create self, initialize from constructor parameters
    #
    writes(f,"  self := ",self.name,"__state(&null,",self.name,"__oprec")
    every writes(f,",",$!self.fields)
    if \self.ifields then every writes(f,",",(!self.ifields).ident)
    write(f,")\n  self.__state := self")

    #
    # call my own initially section, if any
    #
    if $*self.text > 0 then write(f,"  ",self.name,"initially(self)")

    #
    # call superclasses' initially sections
    #
    if $*self.supers > 0 then {
    every (super <- $!self.supers) ~== self.name do {
        if (classes$lookup(super))$has_initially() then {
        if /madeclone := 1 then {
            write(f,"  clone := ",self.name,"__state()\n",
            "  clone.__state := clone\n",
            "  clone.__methods := ",self.name,"__oprec")
        }
        write(f,"  # inherited initialization from class ",super)
        write(f,"    every i := 2 to *self do clone[i] := self[i]\n",
            "    ",super,"initially(clone)")
        every l := !self.ifields do {
            if l.class == super then
            write(f,"    self.",l.ident," := clone.",l.ident)
        }
        }
    }
    }

    #
    # return the pair that comprises the object:
    # a pointer to the instance (__mystate), and
    # a pointer to the class operation record
    #
    write(f,"  return idol_object(self,",self.name,"__oprec)\n",
        "end\n")

    #
    # write out class initializer procedure to initialize my operation record
    #
    write(f,"procedure ",self.name,"initialize()")
    writes(f,"  initial ",self.name,"__oprec := ",self.name,"__methods")
    rv := "("
    every s := ($!self.methods)$name() do {        # explicit methods
      if *rv>1 then rv ||:= ","
      rv ||:= self.name||"_"||s
    }
    every me := self.fields$foreachpublic() do {    # implicit methods
      if *rv>1 then rv ||:= ","            # (for public fields)
      rv ||:= self.name||"_"||me
    }
    every l := !self.imethods do {            # inherited methods
      if *rv>1 then rv ||:= ","
      rv ||:= l.class||"_"||l.ident
    }
    write(f,rv,")\n","end")
    #
    # write out initially procedure, if any
    #
    if self$has_initially() then {
    write(f,"procedure ",self.name,"initially(self)")
    self.text$write(f)
    write(f,"end")
    }

    #
    # write out implicit methods for public fields
    #
    every me := self.fields$foreachpublic() do {
      write(f,"procedure ",self.name,"_",me,"(self)")
      if \strict then {
    write(f,"  if type(self.",me,") == ",
        "(\"list\"|\"table\"|\"set\"|\"record\") then\n",
        "    runerr(501,\"idol: scalar type expected\")")
    }
      write(f,"  return .(self.",me,")")
      write(f,"end")
      write(f)
    }

    close(f)

  end

  #
  # resolve -- primary inheritance resolution utility
  #
  method resolve()
    #
    # these are lists of [class , ident] records
    #
    self.imethods := []
    self.ifields := []
    ipublics := []
    addedfields := table()
    addedmethods := table()
    every sc := $!self.supers do {
    if /(superclass := classes$lookup(sc)) then
        halt("class/resolve: couldn't find superclass ",sc)
    every superclassfield := superclass$foreachfield() do {
        if /self.fields$lookup(superclassfield) &
           /addedfields[superclassfield] then {
        addedfields[superclassfield] := superclassfield
        put ( self.ifields , classident(sc,superclassfield) )
        if superclass$ispublic(superclassfield) then
            put( ipublics, classident(sc,superclassfield) )
        } else if \strict then {
        warn("class/resolve: '",sc,"' field '",superclassfield,
             "' is redeclared in subclass ",self.name)
        }
    }
    every superclassmethod := (superclass$foreachmethod())$name() do {
        if /self.methods$lookup(superclassmethod) &
           /addedmethods[superclassmethod] then {
        addedmethods[superclassmethod] := superclassmethod
        put ( self.imethods, classident(sc,superclassmethod) )
        }
    }
    every public := (!ipublics) do {
        if public.class == sc then
        put (self.imethods, classident(sc,public.ident))
    }
    }
  end
end

#
# a class defining operations on methods and procedures
#
class method : declaration (class,text)
  method read(line,phase)
    self$declaration.read(line)
    self.text := body()
    if phase = 1 then
      self.text$read()
  end
  method writedecl(f,s)
    decl := self$String()
    if s == "method" then decl[1:upto(white,decl)] := "method"
    else {
    decl[1:upto(white,decl)] := "procedure"
    if *(self.class)>0 then {
        decl[upto(white,decl)] ||:= self.class||"_"
        i := find("(",decl)
        decl[i] ||:= "self" || (((decl[i+1] ~== ")"), ",") | "")
    }
    }
    write(f,decl)
  end
  method write(f)
    if self.name ~== "initially" then
    self$writedecl(f,"procedure")
    self.text$write(f)
    self.text := &null            # after writing out text, forget it!
  end
end

#
# a class corresponding to an Icon table, with special treatment of empties
#
class Table(t)
  method size()
    return (* \ self.t) | 0
  end
  method insert(x,key)
    /self.t := table()
    /key := x
    if / (self.t[key]) := x then return
  end
  method lookup(key)
    if t := \self.t then return t[key]
    return
  end
  method foreach()
    if t := \self.t then every suspend !self.t
  end
end

#
# tabular queues (taques):
# a class defining objects which maintain synchronized list and table reps
# Well, what is really provided are loosely-coordinated list/tables
#
class taque : Table (l)
  method insert(x,key)
    /self.l := []
    if self$Table.insert(x,key) then put(self.l,x)
  end
  method foreach()
    if l := \self.l then every suspend !self.l
  end
  method insert_t(x,key)
    self$Table.insert(x,key)
  end
  method foreach_t()
    suspend self$Table.foreach()
  end
end

#
# support for taques found as lists of ids separated by punctuation
# constructor called with (separation char, source string)
#
class idTaque : taque(punc)
  method parse(s)
    s ? {
      tab(many(white))
      while name := tab(find(self.punc)) do {
    self$insert(trim(name))
    move(1)
    tab(many(white))
      }
      if any(nonwhite) then self$insert(trim(tab(0)))
    }
    return
  end
  method String()
    if /self.l then return ""
    out := ""
    every id := !self.l do out ||:= id||self.punc
    return out[1:-1]
  end
end

#
# parameter lists in which the final argument may have a trailing []
#
class argList : idTaque(public varg)
  method insert(s)
    if \self.varg then halt("variable arg must be final")
    if i := find("[",s) then {
      if not (j := find("]",s)) then halt("variable arg expected ]")
      s[i : j+1] := ""
      self.varg := s := trim(s)
    }
    self$idTaque.insert(s)
  end
  method isvarg(s)
    if s == \self.varg then return s
  end
  method String()
    return self$idTaque.String() || ((\self.varg & "[]") | "")
  end
initially
  self.punc := ","
end

#
# Idol class field lists in which fields may be preceded by a "public" keyword
#
class classFields : argList(publics)
  method String(s)
    if *(rv := self$argList.String()) = 0 then return ""
    if /s | (s ~== "class") then return rv
    if self$ispublic(self.l[1]) then rv := "public "||rv
    every field:=self$foreachpublic() do rv[find(","||field,rv)] ||:= "public "
    return rv
  end
  method foreachpublic()
    if \self.publics then every suspend !self.publics
  end
  method ispublic(s)
    if \self.publics then every suspend !self.publics == s
  end
  method insert(s)
    s ? {
      if ="public" & tab(many(white)) then {
    s := tab(0)
    /self.publics := []
    put(self.publics,s)
      }
    }
    self$argList.insert(s)
  end
initially
  self.punc := ","
end

#
# procedure to read a single Idol source file
#
procedure readinput(name,phase,ct2)
    if \loud then write("\t",name)
    fName := name
    fLine := 0
    fin   := sysopen(name,"r")
    ct    := \ct2 | constant()
    while line := readln("wrap") do {
    line ? {
        tab(many(white))
        if ="class" then {
        decl := class()
        decl$read(line,phase)
        if phase=1 then {
            decl$writemethods()
            classes$insert(decl,decl$name())
        } else classes$insert_t(decl,decl$name())
        }
        else if ="procedure" then {
        if comp = 0 then comp := 1
        decl := method("")
        decl$read(line,phase)
        decl$write(fout,"")
        }
        else if ="record" then {
        if comp = 0 then comp := 1
        decl := declaration(line)
        decl$write(fout,"")
        }
        else if ="global" then {
        if comp = 0 then comp := 1
        decl := vardecl(line)
        decl$write(fout,"")
        }
        else if ="const" then {
        ct$append ( constdcl(line) )
            }
        else if ="method" then {
        halt("readinput: method outside class")
            }
        else if ="#include" then {
        savedFName := fName
        savedFLine := fLine
        savedFIn   := fin
        tab(many(white))
        readinput(tab(if ="\"" then find("\"") else many(nonwhite)),
              phase,ct)
        fName := savedFName
        fLine := savedFLine
        fin   := savedFIn
            }
    }
    }
    close(fin)
end

#
# filter the input translating $ references
# (also eats comments and trims lines)
#
procedure readln(wrap)
  count := 0
  prefix := ""
  while /finished do {

    if not (line := read(fin)) then fail
    fLine +:= 1
    if match("#include",line) then return line
    line[ 1(x<-find("#",line),notquote(line[1:x])) : 0] := ""
    line := trim(line,white)
#    line := selfdot(line)
    x := 1
    while ((x := find("$",line,x)) & notquote(line[1:x])) do {
      z := line[x+1:0] ||" "         # " " is for bal()
      case line[x+1] of {
        #
        # IBM 370 digraphs
        #
        "(": line[x+:2] := "{"
        ")": line[x+:2] := "}"
        "<": line[x+:2] := "["
        ">": line[x+:2] := "]"
        #
        # Invocation operators $! $* $@ $? (for $$ see below)
        #
        "!"|"*"|"@"|"?": {
          z ? {
        move(1)
        tab(many(white))
        if not (id := tab(many(alphadot))) then {
          if not match("(") then halt("readln can't parse ",line)
          if not (id := tab(&pos<bal())) then
          halt("readln: cant bal ",&subject)
        }
        Op := case line[x+1] of {
        "@": "activate"
        "*": "size"
        "!": "foreach"
        "?": "random"
        }
        count +:= 1
        line[x:0] :=
        "(__self"||count||" := "||id||").__methods."||
        Op||"(__self"||count||".__state)"||tab(0)
      }
        }
    #
    # x $[ y ] shorthand for x$index(y)
    #
    "[": {
        z ? {
        if not (middle := tab((&pos<bal(&cset,'[',']'))-1)[2:0]) then
            halt("readln: can't bal([) ",&subject)
        tail := tab(0)|""
        line := line[1:x]||"$index("||middle||")"||(tab(0)|"")
        }
    }
        default: {
        #
        # get the invoking object.
        #
        reverse(line[1:x])||" " ? {
        tab(many(white))
        if not (id := reverse(tab(many(alphadot)))) then {
            if not match(")") then halt("readln: can't parse")
            if not (id := reverse(tab(&pos<bal(&cset,')','('))))
            then halt("readln: can't bal ",&subject)
        }
        objlen := &pos-1
        }
        count +:= 1
        front := "(__self"||count||" := "||id||").__methods."
        back := "__self"||count||".__state"

        #
        # get the method name
        #
        z ? {
        ="$"
        tab(many(white))
        if not (methodname := tab(many(alphadot))) then
            halt("readln: expected a method name after $")
        tab(many(white))
        methodname ||:= "("
        if ="(" then {
            tab(many(white))
            afterlp := &subject[&pos]
        }
        else {
            afterlp := ")"
            back ||:= ")"
        }
        methlen := &pos-1
        }
        if line[x+1] == "$" then {
        c := if afterlp[1] ~== ")" then "" else "[]"
        methodname[-1] := "!("
        back := "["||back||"]|||"
        } else {
        c := if (\afterlp)[1] == ")" then "" else ","
        }
        line[x-objlen : (((*line>=(x+methlen+1))|0)\1)] :=
        front || methodname || back || c
    }
      } # case
    } # while there's a $ to process
    if /wrap | (prefix==line=="") then finished := line
    else {
    prefix ||:= line || " "            # " " is for bal()
    prefix ? {
        # we are done if the line is balanced wrt parens and
        # doesn't end in a continuation character (currently just ,)
        if ((*prefix = bal()) & (not find(",",prefix[-2]))) then
        finished := prefix[1:-1]
    }
    }
  } # while / finished
  return ct$expand(finished)
end