path: root/ipl/packs/idol/idol.iol

#
# 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