ref: df03eca7e7cbfadf1cf8c8c5a94390eaa5013a8b
dir: /appl/alphabet/alphabet.b/
implement Alphabet, Copy; include "sys.m"; sys: Sys; include "draw.m"; include "readdir.m"; include "sh.m"; sh: Sh; n_BLOCK, n_SEQ, n_LIST, n_ADJ, n_WORD, n_VAR, n_BQ2, n_PIPE: import Sh; include "sets.m"; sets: Sets; Set: import sets; include "alphabet/reports.m"; reports: Reports; Report: import reports; Modulecmd, Typescmd: import Proxy; include "alphabet.m"; evalmod: Eval; Context: import evalmod; Mainsubtypes: module { proxy: fn(): chan of ref Proxy->Typescmd[ref Alphabet->Value]; }; # to do: # - sort out concurrent access to alphabet. # - if multiple options are given where only one is expected, # most modules ignore some values, where they should # discard them correctly. this could cause a malicious user # to hang up an alphabet expression (waiting for report to end) # - proper implementation of endpointsrv: # - resilience to failures # - security of endpoints # - no need for write(0)... (or maybe there is) # - proper implementation of rexecsrv: # - should be aware of user Debug: con 0; autodeclare := 0; Module: adt { modname: string; # used when loading on demand. typeset: ref Typeset; sig: string; c: chan of ref Modulecmd[ref Value]; m: Mainmodule; def: ref Sh->Cmd; defmods: ref Strhash[cyclic ref Module]; refcount: int; find: fn(ctxt: ref Evalctxt, s: string): (ref Module, string); typesig: fn(m: self ref Module): string; run: fn(m: self ref Module, ctxt: ref Evalctxt, errorc: chan of string, opts: list of (int, list of ref Value), args: list of ref Value): ref Value; typename2c: fn(s: string): int; mks: fn(ctxt: ref Evalctxt, s: string): ref Value; mkc: fn(ctxt: ref Evalctxt, c: ref Sh->Cmd): ref Value; ensureloaded: fn(m: self ref Module): string; cvt: fn(ctxt: ref Evalctxt, v: ref Value, tc: int, errorc: chan of string): ref Value; }; Evalctxt: adt { modules: ref Strhash[ref Module]; drawctxt: ref Draw->Context; report: ref Report; # stopc: chan of int; }; # used for rewriting expressions. Rvalue: adt { i: ref Sh->Cmd; tc: int; refcount: int; opts: list of (int, list of ref Rvalue); args: list of ref Rvalue; dup: fn(t: self ref Rvalue): ref Rvalue; free: fn(v: self ref Rvalue, used: int); isstring: fn(v: self ref Rvalue): int; gets: fn(t: self ref Rvalue): string; type2s: fn(tc: int): string; typec: fn(t: self ref Rvalue): int; }; Rmodule: adt { m: ref Module; cvt: fn(ctxt: ref Revalctxt, v: ref Rvalue, tc: int, errorc: chan of string): ref Rvalue; find: fn(nil: ref Revalctxt, s: string): (ref Rmodule, string); typesig: fn(m: self ref Rmodule): string; run: fn(m: self ref Rmodule, ctxt: ref Revalctxt, errorc: chan of string, opts: list of (int, list of ref Rvalue), args: list of ref Rvalue): ref Rvalue; mks: fn(ctxt: ref Revalctxt, s: string): ref Rvalue; mkc: fn(ctxt: ref Revalctxt, c: ref Sh->Cmd): ref Rvalue; typename2c: fn(s: string): int; }; Revalctxt: adt { modules: ref Strhash[ref Module]; used: ref Strhash[ref Module]; defs: int; vals: list of ref Rvalue; }; Renv: adt { items: list of ref Rvalue; n: int; }; Typeset: adt { name: string; c: chan of ref Typescmd[ref Value]; types: ref Table[cyclic ref Type]; # indexed by external type character parent: ref Typeset; gettype: fn(ts: self ref Typeset, tc: int): ref Type; }; Type: adt { id: int; tc: int; transform: list of ref Transform; typeset: ref Typeset; qname: string; name: string; }; Transform: adt { dst: int; # which type we're transforming into. all: Set; # set of all types this transformation can lead to. expr: ref Sh->Cmd; # transformation operation. }; Table: adt[T] { items: array of list of (int, T); nilval: T; new: fn(nslots: int, nilval: T): ref Table[T]; add: fn(t: self ref Table, id: int, x: T): int; del: fn(t: self ref Table, id: int): int; find: fn(t: self ref Table, id: int): T; }; Strhash: adt[T] { items: array of list of (string, T); nilval: T; new: fn(nslots: int, nilval: T): ref Strhash[T]; add: fn(t: self ref Strhash, id: string, x: T); del: fn(t: self ref Strhash, id: string); find: fn(t: self ref Strhash, id: string): T; }; Copy: module { initcopy: fn( typesets: list of ref Typeset, roottypeset: ref Typeset, modules: ref Strhash[ref Module], typebyname: ref Strhash[ref Type], typebyc: ref Table[ref Type], types: array of ref Type, currtypec: int ): Alphabet; }; typesets: list of ref Typeset; roottypeset: ref Typeset; modules: ref Strhash[ref Module]; typebyname: ref Strhash[ref Type]; typebyc: ref Table[ref Type]; # indexed by internal type character. types: array of ref Type; # indexed by id. currtypec := 16r25a0; # pretty graphics. checkload[T](m: T, path: string): T { if(m != nil) return m; sys->fprint(sys->fildes(2), "alphabet: cannot load %s: %r\n", path); raise "fail:bad module"; } init() { sys = load Sys Sys->PATH; sh = load Sh Sh->PATH; sets = checkload(load Sets Sets->PATH, Sets->PATH); evalmod = checkload(load Eval Eval->PATH, Eval->PATH); evalmod->init(); reports = checkload(load Reports Reports->PATH, Reports->PATH); roottypeset = ref Typeset("/", nil, Table[ref Type].new(5, nil), nil); typesets = roottypeset :: typesets; types = array[] of { ref Type(-1, 'c', nil, roottypeset, "/cmd", "cmd"), ref Type(-1, 's', nil, roottypeset, "/string", "string"), ref Type(-1, 'r', nil, roottypeset, "/status", "status"), ref Type(-1, 'f', nil, roottypeset, "/fd", "fd"), ref Type(-1, 'w', nil, roottypeset, "/wfd", "wfd"), ref Type(-1, 'd', nil, roottypeset, "/data", "data"), }; typebyname = typebyname.new(11, nil); typebyc = typebyc.new(11, nil); for(i := 0; i < len types; i++){ types[i].id = i; typebyc.add(types[i].tc, types[i]); typebyname.add(types[i].qname, types[i]); roottypeset.types.add(types[i].tc, types[i]); } # typebyc.add('a', ref Type(-1, 'a', nil, nil, "/any", "any")); # not sure about this anymore modules = modules.new(3, nil); } initcopy( xtypesets: list of ref Typeset, xroottypeset: ref Typeset, xmodules: ref Strhash[ref Module], xtypebyname: ref Strhash[ref Type], xtypebyc: ref Table[ref Type], xtypes: array of ref Type, xcurrtypec: int): Alphabet { # XXX must do copy-on-write, and refcounting on typesets. typesets = xtypesets; roottypeset = xroottypeset; modules = xmodules; typebyname = xtypebyname; typebyc = xtypebyc; types = xtypes; currtypec = xcurrtypec; return load Alphabet "$self"; } copy(): Alphabet { a := load Copy Alphabet->PATH; if(a == nil) return nil; return a->initcopy(typesets, roottypeset, modules, typebyname, typebyc, types, currtypec); } setautodeclare(x: int) { autodeclare = x; } quit() { for(ts := typesets; ts != nil; ts = tl ts) if((hd ts).c != nil) (hd ts).c <-= nil; delmods(modules); } delmods(mods: ref Strhash[ref Module]) { for(i := 0; i < len mods.items; i++){ for(l := mods.items[i]; l != nil; l = tl l){ m := (hd l).t1; if(--m.refcount == 0){ if(m.c != nil){ m.c <-= nil; m.c = nil; }else if(m.defmods != nil) delmods(m.defmods); else if(m.m != nil){ m.m->quit(); m.m = nil; } } } } } # XXX could do some more checking to see whether it looks vaguely like # a valid alphabet expression. parse(expr: string): (ref Sh->Cmd, string) { return sh->parse(expr); } eval(expr: ref Sh->Cmd, drawctxt: ref Draw->Context, args: list of ref Value): string { spawn reports->reportproc(reportc := chan of string, nil, reply := chan of ref Report); r := <-reply; reply = nil; stderr := sys->fildes(2); spawn eval0(expr, "/status", drawctxt, r, reports->r.start("eval"), args, vc := chan of ref Value); reports->r.enable(); v: ref Value; wait: for(;;)alt{ v = <-vc => if(v != nil) v.r().i <-= nil; msg := <-reportc => if(msg == nil) break wait; sys->fprint(stderr, "alphabet: %s\n", msg); } # we'll always get the value before the report ends. if(v == nil) return "no value"; return <-v.r().i; } eval0(expr: ref Sh->Cmd, dsttype: string, drawctxt: ref Draw->Context, r: ref Report, errorc: chan of string, args: list of ref Value, vc: chan of ref Value) { c: Eval->Context[ref Value, ref Module, ref Evalctxt]; ctxt := ref Evalctxt(modules, drawctxt, r); tc := -1; if(dsttype != nil && (tc = Module.typename2c(dsttype)) == -1){ report(errorc, "error: unknown type "+dsttype); vc <-= nil; reports->quit(errorc); } v := c.eval(expr, ctxt, errorc, args); if(tc != -1) v = Module.cvt(ctxt, v, tc, errorc); vc <-= v; reports->quit(errorc); } define(name: string, expr: ref Sh->Cmd, errorc: chan of string): string { if(name == nil || name[0] == '/') return "bad module name"; m := modules.find(name); if(m != nil) return "module already declared"; sig: string; used: ref Strhash[ref Module]; used = used.new(11, nil); (expr, sig) = rewrite0(expr, -1, errorc, used); if(sig == nil) return "cannot rewrite"; modules.add(name, ref Module(name, roottypeset, sig, nil, nil, expr, used, 1)); return nil; } typecompat(t0, t1: string): (int, string) { m: ref Module; (sig0, err) := evalmod->usage2sig(m, t0); if(err != nil) return (0, sys->sprint("bad usage %q: %s", t0, err)); sig1: string; (sig1, err) = evalmod->usage2sig(m, t1); if(err != nil) return (0, sys->sprint("bad usage %q: %s", t1, err)); return (evalmod->typecompat(sig0, sig1), nil); } rewrite(expr: ref Sh->Cmd, dsttype: string, errorc: chan of string): (ref Sh->Cmd, string) { v: ref Value; tc := -1; if(dsttype != nil){ tc = Module.typename2c(dsttype); if(tc == -1){ report(errorc, "error: unknown type "+dsttype); return (nil, nil); } } sig: string; (expr, sig) = rewrite0(expr, tc, errorc, nil); if(sig == nil) return (nil, nil); return (expr, evalmod->cmdusage(v, sig)); } # XXX different kinds of rewrite: # could rewrite forcing all names to qualified # or just leave names as they are. # return (expr, sig). # add all modules used by the expression to mods if non-nil. rewrite0(expr: ref Sh->Cmd, tc: int, errorc: chan of string, used: ref Strhash[ref Module]): (ref Sh->Cmd, string) { m: ref Rmodule; ctxt := ref Revalctxt(modules, used, 1, nil); (sig, err) := evalmod->blocksig(m, ctxt, expr); if(sig == nil){ report(errorc, "error: cannot get expr type: "+err); return (nil, nil); } args: list of ref Rvalue; for(i := len sig - 1; i >= 1; i--) args = ref Rvalue(mk(-1, nil, nil), sig[i], 1, nil, nil) :: args; # N.Vb. cmd node is never used. c: Eval->Context[ref Rvalue, ref Rmodule, ref Revalctxt]; v := c.eval(expr, ctxt, errorc, args); if(v != nil && tc != -1) v = Rmodule.cvt(ctxt, v, tc, errorc); if(v == nil) return (nil, nil); sig[0] = v.tc; v.refcount++; expr = gen(v, ref Renv(nil, 0)); if(len sig > 1){ t := mkw(Value.type2s(sig[1])); for(i = 2; i < len sig; i++) t = mk(n_ADJ, t, mkw(Value.type2s(sig[i]))); expr = mk(n_BLOCK, mk(n_SEQ, mk(n_LIST, t, nil), expr.left), nil); } return (expr, sig); } # generate the expression that gave rise to v. # it puts in parentenv any values referred to externally. gen(v: ref Rvalue, parentenv: ref Renv): ref Sh->Cmd { v.refcount--; if(v.refcount > 0) return mk(n_VAR, mkw(string addenv(parentenv, v)), nil); c := v.i; (opts, args) := (v.opts, v.args); if(opts == nil && args == nil) return c; env := parentenv; if(genblock := needblock(v)) env = ref Renv(nil, 0); for(; opts != nil; opts = tl opts){ c = mk(n_ADJ, c, mkw(sys->sprint("-%c", (hd opts).t0))); for(a := (hd opts).t1; a != nil; a = tl a) c = mk(n_ADJ, c, gen(hd a, env)); } if(args != nil && len (hd args).i.word > 1 && (hd args).i.word[0] == '-') c = mk(n_ADJ, c, mkw("--")); # XXX potentially dodgy; some sigs don't interpret "--"? # use pipe notation when possible arg0: ref Sh->Cmd; if(args != nil){ if((arg0 = gen(hd args, env)).ntype != n_BLOCK){ c = mk(n_ADJ, c, arg0); arg0 = nil; } args = tl args; } for(; args != nil; args = tl args) c = mk(n_ADJ, c, gen(hd args, env)); if(arg0 != nil) c = mk(n_PIPE, arg0.left, c); if(genblock){ args = rev(env.items); m := mkw(Value.type2s((hd args).tc)); for(a := tl args; a != nil; a = tl a) m = mk(n_ADJ, m, mkw(Value.type2s((hd a).tc))); c = mk(n_BLOCK, mk(n_SEQ, mk(n_LIST, m, nil), c), nil); return gen(ref Rvalue(c, v.tc, 1, nil, args), parentenv); } return mk(n_BLOCK, c, nil); } addenv(env: ref Renv, v: ref Rvalue): int { for(i := env.items; i != nil; i = tl i) if(hd i == v) return len i; env.items = v :: env.items; v.refcount++; return ++env.n; } # need a new block if we have any duplicated values we can resolve locally. # i.e. for a particular value, if we're the only thing pointing to that value # and its refcount is > 1 to start with. needblock(v: ref Rvalue): int { dups := getdups(v, nil); for(d := dups; d != nil; d = tl d) --(hd d).refcount; r := 0; for(d = dups; d != nil; d = tl d) if((hd d).refcount++ == 0) r = 1; return r; } # find all values which need $ referencing (but don't go any deeper) getdups(v: ref Rvalue, onto: list of ref Rvalue): list of ref Rvalue { if(v.refcount > 1) return v :: onto; for(o := v.opts; o != nil; o = tl o) for(a := (hd o).t1; a != nil; a = tl a) onto = getdups(hd a, onto); for(a = v.args; a != nil; a = tl a) onto = getdups(hd a, onto); return onto; } loadtypeset(qname: string, c: chan of ref Typescmd[ref Value], errorc: chan of string): string { tsname := canon(qname); if(gettypeset(tsname) != nil) return nil; (parent, name) := splitqname(tsname); if((pts := gettypeset(parent)) == nil) return "parent typeset not found"; if(pts.c != nil){ if(c != nil) return "typecmd channel may only be provided for top-level typesets"; reply := chan of (chan of ref Typescmd[ref Value], string); pts.c <-= ref Typescmd[ref Value].Loadtypes(name, reply); err: string; (c, err) = <-reply; if(c == nil) return err; }else if(c == nil){ tsmod := load Mainsubtypes "/dis/alphabet/"+name+"types.dis"; if(tsmod == nil) return sys->sprint("cannot load %q: %r", name+"types.dis"); c = tsmod->proxy(); } reply := chan of string; c <-= ref Typescmd[ref Value].Alphabet(reply); a := <-reply; ts := ref Typeset(tsname, c, Table[ref Type].new(7, nil), pts); typesets = ts :: typesets; newtypes: list of ref Type; for(i := 0; i < len a; i++){ tc := a[i]; if((t := ts.parent.gettype(tc)) == nil){ t = ref Type(-1, -1, nil, ts, nil, nil); sreply := chan of string; c <-= ref Typescmd[ref Value].Type2s(tc, sreply); t.name = <-sreply; # XXX check that type name is syntactically valid. t.qname = mkqname(tsname, t.name); if(typebyname.find(t.qname) != nil) report(errorc, sys->sprint("warning: oops: typename clash on %q", t.qname)); else typebyname.add(t.qname, t); newtypes = t :: newtypes; } ts.types.add(tc, t); } id := len types; types = (array[len types + len newtypes] of ref Type)[0:] = types; for(; newtypes != nil; newtypes = tl newtypes){ types[id] = hd newtypes; typebyc.add(currtypec, hd newtypes); types[id].tc = currtypec++; types[id].id = id; id++; } return nil; } autoconvert(src, dst: string, expr: ref Sh->Cmd, errorc: chan of string): string { tdst := typebyname.find(dst); if(tdst == nil) return "unknown type " + dst; tsrc := typebyname.find(src); if(tsrc == nil) return "unknown type " + src; if(tdst.typeset != tsrc.typeset && tdst.typeset != roottypeset && tsrc.typeset != roottypeset) return "conversion between incompatible typesets"; if(expr != nil && expr.ntype == n_WORD){ # mod -> {(srctype); mod $1} expr = mk(n_BLOCK, mk(n_SEQ, mk(n_LIST, mkw(src), nil), mk(n_ADJ, mkw(expr.word), mk(n_VAR, mkw("1"), nil) ) ), nil ); } (e, sig) := rewrite0(expr, tdst.tc, errorc, nil); if(sig == nil) return "cannot rewrite transformation "+sh->cmd2string(expr); if(!evalmod->typecompat(sys->sprint("%c%c", tdst.tc, tsrc.tc), sig)) return "incompatible module type"; err := addconversion(tsrc, tdst, e); if(err != nil) return sys->sprint("bad auto-conversion %s->%s via %s: %s", tsrc.qname, tdst.qname, sh->cmd2string(expr), err); return nil; } mk(ntype: int, left, right: ref Sh->Cmd): ref Sh->Cmd { return ref Sh->Cmd(ntype, left, right, nil, nil); } mkw(w: string): ref Sh->Cmd { return ref Sh->Cmd(n_WORD, nil, nil, w, nil); } declare(qname: string, usig: string, flags: int): string { return declare0(qname, usig, flags).t1; } # declare a module. # if (flags&ONDEMAND), then we don't need to actually load # the module (although we do if (flags&CHECK) or if sig==nil, # in order to check or find out the type signature) declare0(qname: string, usig: string, flags: int): (ref Module, string) { sig, err: string; m: ref Module; if(usig != nil){ (sig, err) = evalmod->usage2sig(m, usig); if(sig == nil) return (nil, "bad type sig: " + err); } # if not a qualified name, declare it virtually if(qname != nil && qname[0] != '/'){ if(sig == nil) return (nil, "virtual module declaration must include signature"); m = ref Module(qname, nil, sig, nil, nil, nil, nil, 0); }else{ qname = canon(qname); (typeset, mod) := splitqname(qname); if((ts := gettypeset(typeset)) == nil) return (nil, "unknown typeset"); if((m = modules.find(qname)) != nil){ if(m.typeset == ts) return (m, nil); return (nil, "already imported"); } m = ref Module(mod, ts, sig, nil, nil, nil, nil, 0); if(sig == nil || (flags&CHECK) || (flags&ONDEMAND)==0){ if((e := m.ensureloaded()) != nil) return (nil, e); if(flags&ONDEMAND){ if(m.c != nil){ m.c <-= nil; m.c = nil; } m.m = nil; } } } modules.add(qname, m); m.refcount++; return (m, nil); } undeclare(name: string): string { m := modules.find(name); if(m == nil) return "module not declared"; modules.del(name); if(--m.refcount == 0){ if(m.c != nil){ m.c <-= nil; m.c = nil; }else if(m.defmods != nil){ delmods(m.defmods); } } return nil; } # get info on a module. # return (qname, usage, def) getmodule(name: string): (string, string, ref Sh->Cmd) { (qname, sig, def) := getmodule0(name); if(sig == nil) return (qname, sig, def); v: ref Value; return (qname, evalmod->cmdusage(v, sig), def); } getmodule0(name: string): (string, string, ref Sh->Cmd) { m: ref Module; if(name != nil && name[0] != '/'){ if((m = modules.find(name)) == nil) return (nil, nil, nil); # XXX could add path searching here. }else{ name = canon(name); (typeset, mod) := splitqname(name); if((m = modules.find(name)) == nil){ if(autodeclare == 0) return (nil, nil, nil); ts := gettypeset(typeset); if(ts == nil) return (nil, nil, nil); m = ref Module(mod, ts, nil, nil, nil, nil, nil, 0); if((e := m.ensureloaded()) != nil) return (nil, nil, nil); if(m.c != nil) m.c <-= nil; } } qname := m.modname; if(m.def == nil && m.typeset != nil) qname = mkqname(m.typeset.name, qname); return (qname, m.sig, m.def); } getmodules(): list of string { r: list of string; for(i := 0; i < len modules.items; i++) for(ml := modules.items[i]; ml != nil; ml = tl ml) r = (hd ml).t0 :: r; return r; } #Cmpdeclts: adt { # gt: fn(nil: self ref Cmpdeclts, d1, d2: ref Decltypeset): int #}; #Cmpdeclts.gt(nil: self ref Cmpdeclts, d1, d2: ref Decltypeset) #{ # return d1.name > d2.name; #} #Cmpstring: adt { # gt: fn(nil: self ref Cmpdeclts, d1, d2: string): int #}; #Cmpstring.gt(nil: self ref Cmpstring, d1, d2: string): int #{ # return d1 > d2; #} #Cmptype: adt { # gt: fn(nil: self ref Cmptype, d1, d2: ref Type): int #}; #Cmptype.gt(nil: self ref Cmptype, d1, d2: ref Type): int #{ # return d1.name > d2.name; #} # #getdecls(): ref Declarations #{ # cmptype: ref Cmptype; # d := ref Declarations(array[len typesets] of ref Decltypeset); # i := 0; # ta := array[len types] of ref Type; # for(tsl := typesets; tsl != nil; tsl = tl tsl){ # t := hd tsl; # ts := ref Decltypeset; # ts.name = t.name; # # # all types in the typeset, in alphabetical order. # j := 0; # for(k := 0; k < len t.types.items; k++) # for(tt := t.types.items[k]; tt != nil; tt = tl tt) # ta[j++] = hd tt; # sort(cmptype, ta[0:j]); # ts.types = array[j] of string; # for(k = 0; k < j; k++){ # ts.types[k] = ta[k].name; # ts.alphabet[k] = ta[k].tc; # } # # # all modules in the typeset # c := gettypesetmodules(ts.name); # while((m := <-c) != nil){ # # # d.types = array[len types] of string; # for(i := 0; i < len types; i++){ # d.alphabet[i] = types[i].tc; # d.types[i] = types[i].qname; # } # gettypesetmodules(tsname: string): chan of string { ts := gettypeset(tsname); if(ts == nil) return nil; r := chan of string; if(ts.c == nil) spawn mainmodules(r); else ts.c <-= ref Typescmd[ref Value].Modules(r); return r; } mainmodules(r: chan of string) { if((readdir := load Readdir Readdir->PATH) != nil){ (a, nil) := readdir->init("/dis/alphabet/main", Readdir->NAME|Readdir->COMPACT); for(i := 0; i < len a; i++){ m := a[i].name; if((a[i].mode & Sys->DMDIR) == 0 && len m > 4 && m[len m - 4:] == ".dis") r <-= m[0:len m - 4]; } } r <-= nil; } gettypes(ts: string): list of string { r: list of string; for(i := 0; i < len types; i++){ if(ts == nil) r = Value.type2s(types[i].tc) :: r; else if (types[i].typeset.name == ts) r = types[i].name :: r; } return r; } gettypesets(): list of string { r: list of string; for(t := typesets; t != nil; t = tl t) r = (hd t).name :: r; return r; } getautoconversions(): list of (string, string, ref Sh->Cmd) { cl: list of (string, string, ref Sh->Cmd); for(i := 0; i < len types; i++){ if(types[i] == nil) continue; srct := Value.type2s(types[i].tc); for(l := types[i].transform; l != nil; l = tl l) cl = (srct, Value.type2s(types[(hd l).dst].tc), (hd l).expr) :: cl; } return cl; } importmodule(qname: string): string { qname = canon(qname); (typeset, mod) := splitqname(qname); if(typeset == nil) return "unknown typeset"; if((m := modules.find(mod)) != nil){ if(m.typeset == nil) return "already defined"; if(m.typeset.name == typeset) return nil; return "already imported from "+m.typeset.name; } if((m = modules.find(qname)) == nil){ if(autodeclare == 0) return "module not declared"; err: string; (m, err) = Module.find(nil, qname); if(m == nil) return "cannot import: "+ err; modules.add(qname, m); m.refcount++; } modules.add(mod, m); return nil; } gettypeset(name: string): ref Typeset { name = canon(name); for(l := typesets; l != nil; l = tl l) if((hd l).name == name) break; if(l == nil) return nil; return hd l; } importtype(qname: string): string { qname = canon(qname); (typeset, tname) := splitqname(qname); if((ts := gettypeset(typeset)) == nil) return "unknown typeset"; t := typebyname.find(tname); if(t != nil){ if(t.typeset == ts) return nil; return "type already imported from " + t.typeset.name; } t = typebyname.find(qname); if(t == nil) return sys->sprint("%s does not hold type %s", typeset, tname); typebyname.add(tname, t); return nil; } importvalue(v: ref Value, tname: string): (ref Value, string) { if(v == nil || tagof v != tagof Value.Vz) return (v, nil); if(tname == nil || tname[0] == '/') tname = canon(tname); t := typebyname.find(tname); if(t == nil) return (nil, "no such type"); pick xv := v { Vz => if(t.typeset.types.find(xv.i.typec) != t) return (nil, "value appears to be of different type"); xv.i.typec = t.tc; } return (v, nil); } gettype(tc: int): ref Type { return typebyc.find(tc); } Typeset.gettype(ts: self ref Typeset, tc: int): ref Type { return ts.types.find(tc); } Module.find(ctxt: ref Evalctxt, name: string): (ref Module, string) { mods := modules; if(ctxt != nil) mods = ctxt.modules; m := mods.find(name); if(m == nil){ if(autodeclare == 0 || name == nil || name[0] != '/') return (nil, "module not declared"); err: string; (m, err) = declare0(name, nil, 0); if(m == nil) return (nil, err); }else if((err := m.ensureloaded()) != nil) return (nil, err); return (m, nil); } Module.ensureloaded(m: self ref Module): string { if(m.c != nil || m.m != nil || m.def != nil || m.typeset == nil) return nil; sig: string; if(m.typeset.c == nil){ p := "/dis/alphabet/main/" + m.modname + ".dis"; mod := load Mainmodule p; if(mod == nil) return sys->sprint("cannot load %q: %r", p); { mod->init(); } exception e { "fail:*" => return sys->sprint("init %q failed: %s", m.modname, e[5:]); } m.m = mod; sig = mod->typesig(); }else{ reply := chan of (chan of ref Modulecmd[ref Value], string); m.typeset.c <-= ref Typescmd[ref Value].Load(m.modname, reply); (mc, err) := <-reply; if(mc == nil) return sys->sprint("cannot load: %s", err); m.c = mc; sig = gettypesig(m); } if(m.sig == nil) m.sig = sig; else if(!evalmod->typecompat(m.sig, sig)){ v: ref Value; if(m.c != nil){ m.c <-= nil; m.c = nil; } m.m = nil; return sys->sprint("%q not compatible with %q (%q vs %q, %d)", m.modname+" "+evalmod->cmdusage(v, sig), evalmod->cmdusage(v, m.sig), m.sig, sig, m.sig==sig); } return nil; } Module.typesig(m: self ref Module): string { return m.sig; } # get the type signature of a module in its native typeset. # it's not valid to call this on defined or virtually declared modules. gettypesig(m: ref Module): string { reply := chan of string; m.c <-= ref Modulecmd[ref Value].Typesig(reply); sig := <-reply; origsig := sig; for(i := 0; i < len sig; i++){ tc := sig[i]; if(tc == '-'){ i++; continue; } if(tc != '*'){ t := m.typeset.gettype(sig[i]); if(t == nil){ sys->print("no type found for '%c' in sig %q\n", sig[i], origsig); return nil; # XXX is it alright to break here? } sig[i] = t.tc; } } return sig; } Module.run(m: self ref Module, ctxt: ref Evalctxt, errorc: chan of string, opts: list of (int, list of ref Value), args: list of ref Value): ref Value { if(m.c != nil){ reply := chan of ref Value; m.c <-= ref Modulecmd[ref Value].Run(ctxt.drawctxt, ctxt.report, errorc, opts, args, reply); if((v := <-reply) != nil){ pick xv := v { Vz => xv.i.typec = m.typeset.types.find(xv.i.typec).tc; } } return v; }else if(m.def != nil){ c: Eval->Context[ref Value, ref Module, ref Evalctxt]; return c.eval(m.def, ref Evalctxt(m.defmods, ctxt.drawctxt, ctxt.report), errorc, args); }else if(m.typeset != nil){ v := m.m->run(ctxt.drawctxt, ctxt.report, errorc, opts, args); free(opts, args, v != nil); return v; } report(errorc, "error: cannot run a virtually declared module"); return nil; } free[V](opts: list of (int, list of V), args: list of V, used: int) for{ V => free: fn(v: self V, used: int); } { for(; args != nil; args = tl args) (hd args).free(used); for(; opts != nil; opts = tl opts) for(args = (hd opts).t1; args != nil; args = tl args) (hd args).free(used); } Module.typename2c(s: string): int { if((t := typebyname.find(s)) == nil) return -1; return t.tc; } Module.cvt(ctxt: ref Evalctxt, v: ref Value, tc: int, errorc: chan of string): ref Value { if(v == nil) return nil; srctc := v.typec(); dstid := gettype(tc).id; while((vtc := v.typec()) != tc){ # XXX assumes v always returns a valid typec: might that be dangerous? for(l := gettype(vtc).transform; l != nil; l = tl l) if((hd l).all.holds(dstid)) break; if(l == nil){ report(errorc, sys->sprint("error: no way to get from %s to %s", gettype(v.typec()).qname, types[dstid].qname)); v.free(0); return nil; # should only happen the first time. } t := hd l; c: Eval->Context[ref Value, ref Module, ref Evalctxt]; nv := c.eval(t.expr, ctxt, errorc, v::nil); if(nv == nil){ report(errorc, sys->sprint("error: autoconvert %q failed", sh->cmd2string(t.expr))); return nil; } v = nv; } return v; } Module.mks(nil: ref Evalctxt, s: string): ref Value { return ref Value.Vs(s); } Module.mkc(nil: ref Evalctxt, c: ref Sh->Cmd): ref Value { return ref Value.Vc(c); } show() { for(i := 0; i < len types; i++){ if(types[i] == nil) continue; sys->print("%s =>\n", types[i].qname); for(l := types[i].transform; l != nil; l = tl l) sys->print("\t%s -> %s {%s}\n", set2s((hd l).all), types[(hd l).dst].qname, sh->cmd2string((hd l).expr)); } } set2s(set: Set): string { s := "{"; for(i := 0; i < len types; i++){ if(set.holds(i)){ if(len s > 1) s[len s] = ' '; s += types[i].qname; } } return s + "}"; } Value.dup(v: self ref Value): ref Value { if(v == nil) return nil; pick xv := v { Vr => return nil; Vd => return nil; Vf or Vw => return nil; Vz => rc := chan of ref Value; gettype(xv.i.typec).typeset.c <-= ref Typescmd[ref Value].Dup(xv, rc); nv := <-rc; if(nv == nil) return nil; if(nv == v) return v; pick nxv := nv { Vz => if(nxv.i.typec == xv.i.typec) return nxv; } sys->print("oh dear, invalid duplicated value from typeset %s\n", gettype(xv.i.typec).typeset.name); return nil; } return v; } Value.typec(v: self ref Value): int { pick xv := v { Vc => return 'c'; Vs => return 's'; Vr => return 'r'; Vf => return 'f'; Vw => return 'w'; Vd => return 'd'; Vz => return xv.i.typec; } } Value.typename(v: self ref Value): string { return Value.type2s(v.typec()); } Value.free(v: self ref Value, used: int) { if(v == nil) return; pick xv := v { Vr => if(!used) xv.i <-= "stop"; Vf or Vw=> if(!used){ <-xv.i; xv.i <-= nil; } Vd => if(!used){ alt{ xv.i.stop <-= 1 => ; * => ; } } Vz => gettype(xv.i.typec).typeset.c <-= ref Typescmd[ref Value].Free(xv, used, reply := chan of int); <-reply; } } Value.isstring(v: self ref Value): int { return tagof v == tagof Value.Vs; } Value.gets(v: self ref Value): string { return v.s().i; } Value.c(v: self ref Value): ref Value.Vc { pick xv :=v {Vc => return xv;} raise "type error"; } Value.s(v: self ref Value): ref Value.Vs { pick xv :=v {Vs => return xv;} raise "type error"; } Value.r(v: self ref Value): ref Value.Vr { pick xv :=v {Vr => return xv;} raise "type error"; } Value.f(v: self ref Value): ref Value.Vf { pick xv :=v {Vf => return xv;} raise "type error"; } Value.w(v: self ref Value): ref Value.Vw { pick xv :=v {Vw => return xv;} raise "type error"; } Value.d(v: self ref Value): ref Value.Vd { pick xv :=v {Vd => return xv;} raise "type error"; } Value.z(v: self ref Value): ref Value.Vz { pick xv :=v {Vz => return xv;} raise "type error"; } Value.type2s(tc: int): string { t := gettype(tc); if(t == nil) return "unknown"; if(typebyname.find(t.name) == t) return t.name; return t.qname; } Rmodule.find(ctxt: ref Revalctxt, s: string): (ref Rmodule, string) { m := ctxt.modules.find(s); if(m == nil){ if(autodeclare == 0 || s == nil || s[0] != '/') return (nil, "module not declared"); if(ctxt.modules != modules) return (nil, "shouldn't happen: module not found in defined block"); err: string; (m, err) = declare0(s, nil, ONDEMAND); if(m == nil) return (nil, err); } return (ref Rmodule(m), nil); } Rmodule.cvt(ctxt: ref Revalctxt, v: ref Rvalue, tc: int, errorc: chan of string): ref Rvalue { if(v == nil) return nil; srctc := v.typec(); dstid := gettype(tc).id; while((vtc := v.typec()) != tc){ # XXX assumes v always returns a valid typec: might that be dangerous? for(l := gettype(vtc).transform; l != nil; l = tl l) if((hd l).all.holds(dstid)) break; if(l == nil){ report(errorc, sys->sprint("error: no way to get from %s to %s", gettype(v.typec()).qname, types[dstid].qname)); return nil; # should only happen the first time. } t := hd l; c: Eval->Context[ref Rvalue, ref Rmodule, ref Revalctxt]; v = c.eval(t.expr, ctxt, errorc, v::nil); } return v; } Rmodule.typesig(m: self ref Rmodule): string { return m.m.sig; } Rmodule.typename2c(name: string): int { return Module.typename2c(name); } Rmodule.mks(ctxt: ref Revalctxt, s: string): ref Rvalue { v := ref Rvalue(mkw(s), 's', 0, nil, nil); ctxt.vals = v :: ctxt.vals; return v; } Rmodule.mkc(ctxt: ref Revalctxt, c: ref Sh->Cmd): ref Rvalue { v := ref Rvalue(mk(n_BQ2, c, nil), 'c', 0, nil, nil); ctxt.vals = v :: ctxt.vals; return v; } Rmodule.run(m: self ref Rmodule, ctxt: ref Revalctxt, errorc: chan of string, opts: list of (int, list of ref Rvalue), args: list of ref Rvalue): ref Rvalue { if(ctxt.defs && m.m.def != nil){ c: Eval->Context[ref Rvalue, ref Rmodule, ref Revalctxt]; nctxt := ref Revalctxt(m.m.defmods, ctxt.used, ctxt.defs, ctxt.vals); v := c.eval(m.m.def, nctxt, errorc, args); ctxt.vals = nctxt.vals; return v; } name := mkqname(m.m.typeset.name, m.m.modname); if(ctxt.used != nil){ ctxt.used.add(name, m.m); m.m.refcount++; } v := ref Rvalue(mkw(name), m.m.sig[0], 0, opts, args); if(args == nil && opts == nil) v.i = mk(n_BLOCK, v.i, nil); for(; args != nil; args = tl args) (hd args).refcount++; for(; opts != nil; opts = tl opts) for(args = (hd opts).t1; args != nil; args = tl args) (hd args).refcount++; ctxt.vals = v :: ctxt.vals; return v; } Rvalue.dup(v: self ref Rvalue): ref Rvalue { return v; } Rvalue.free(nil: self ref Rvalue, nil: int) { # XXX perhaps there should be some way of finding out whether a particular # type will allow duplication of values or not. } Rvalue.isstring(v: self ref Rvalue): int { return v.tc == 's'; } Rvalue.gets(t: self ref Rvalue): string { return t.i.word; } Rvalue.type2s(tc: int): string { return Value.type2s(tc); } Rvalue.typec(t: self ref Rvalue): int { return t.tc; } addconversion(src, dst: ref Type, expr: ref Sh->Cmd): string { # allow the same transform to be added again for(l := src.transform; l != nil; l = tl l) if((hd l).all.holds(dst.id)){ if((hd l).dst == dst.id && sh->cmd2string((hd l).expr) == sh->cmd2string(expr)) return nil; } reached := array[len types/8+1] of {* => byte 0}; if((at := ambiguous(dst, reached)) != nil) return sys->sprint("ambiguity: %s", at); src.transform = ref Transform(dst.id, sets->bytes2set(reached), expr) :: src.transform; # check we haven't created ambiguity in nodes that point to src. for(i := 0; i < len types; i++){ for(l = types[i].transform; l != nil; l = tl l){ if((hd l).all.holds(src.id) && (at = ambiguous(types[i], array[len types/8+1] of {* => byte 0})) != nil){ src.transform = tl src.transform; return sys->sprint("ambiguity: %s", at); } } } all := (Sets->None).add(dst.id); for(l = types[dst.id].transform; l != nil; l = tl l) all = all.X(Sets->A|Sets->B, (hd l).all); # add everything pointed to by dst to the all sets of those types # that had previously pointed (indirectly) to src for(i = 0; i < len types; i++) for(l = types[i].transform; l != nil; l = tl l) if((hd l).all.holds(src.id)) (hd l).all = (hd l).all.X(Sets->A|Sets->B, all); return nil; } ambiguous(t: ref Type, reached: array of byte): string { if((dt := ambiguous1(t, reached)) == nil) return nil; (nil, at) := findambiguous(t, dt, array[len reached] of {* =>byte 0}, "self "+types[t.id].qname); s := hd at; for(at = tl at; at != nil; at = tl at) s += ", " + hd at; return s; } # a conversion is ambiguous if there's more than one # way of reaching the same type. # return the type at which the ambiguity is found. ambiguous1(t: ref Type, reached: array of byte): ref Type { if(bsetholds(reached, t.id)) return t; bsetadd(reached, t.id); for(l := t.transform; l != nil; l = tl l) if((at := ambiguous1(types[(hd l).dst], reached)) != nil) return at; return nil; } findambiguous(t: ref Type, dt: ref Type, reached: array of byte, s: string): (int, list of string) { a: list of string; if(t == dt) a = s :: nil; if(bsetholds(reached, t.id)) return (1, a); bsetadd(reached, t.id); for(l := t.transform; l != nil; l = tl l){ (found, at) := findambiguous(types[(hd l).dst], dt, reached, sys->sprint("%s|%s", s, sh->cmd2string((hd l).expr))); # XXX rewite correctly for(; at != nil; at = tl at) a = hd at :: a; if(found) return (1, a); } return (0, a); } bsetholds(x: array of byte, n: int): int { return int x[n >> 3] & (1 << (n & 7)); } bsetadd(x: array of byte, n: int) { x[n >> 3] |= byte (1 << (n & 7)); } mkqname(parent, child: string): string { if(parent == "/") return parent+child; return parent+"/"+child; } # splits a canonical qname into typeset and name components. splitqname(name: string): (string, string) { if(name == nil) return (nil, nil); for(i := len name - 1; i >= 0; i--) if(name[i] == '/') break; if(i == 0) return ("/", name[1:]); return (name[0:i], name[i+1:]); } # compress multiple slashes into single; remove trailing slashes. canon(name: string): string { if(name == nil || name[0] != '/') return nil; slash := nonslash := 0; s := ""; for(i := 0; i < len name; i++){ c := name[i]; if(c == '/') slash = 1; else{ if(slash){ s[len s] = '/'; nonslash++; slash = 0; } s[len s] = c; } } if(slash && !nonslash) s[len s] = '/'; return s; } report(errorc: chan of string, s: string) { if(Debug || errorc == nil) sys->fprint(sys->fildes(2), "%s\n", s); if(errorc != nil) errorc <-= s; } Table[T].new(nslots: int, nilval: T): ref Table[T] { if(nslots == 0) nslots = 13; return ref Table[T](array[nslots] of list of (int, T), nilval); } Table[T].add(t: self ref Table[T], id: int, x: T): int { slot := id % len t.items; for(q := t.items[slot]; q != nil; q = tl q) if((hd q).t0 == id) return 0; t.items[slot] = (id, x) :: t.items[slot]; return 1; } Table[T].del(t: self ref Table[T], id: int): int { slot := id % len t.items; p: list of (int, T); r := 0; for(q := t.items[slot]; q != nil; q = tl q){ if((hd q).t0 == id){ p = joinip(p, tl q); r = 1; break; } p = hd q :: p; } t.items[slot] = p; return r; } Table[T].find(t: self ref Table[T], id: int): T { for(p := t.items[id % len t.items]; p != nil; p = tl p) if((hd p).t0 == id) return (hd p).t1; return t.nilval; } hashfn(s: string, n: int): int { h := 0; m := len s; for(i:=0; i<m; i++){ h = 65599*h+s[i]; } return (h & 16r7fffffff) % n; } Strhash[T].new(nslots: int, nilval: T): ref Strhash[T] { if(nslots == 0) nslots = 13; return ref Strhash[T](array[nslots] of list of (string, T), nilval); } Strhash[T].add(t: self ref Strhash, id: string, x: T) { slot := hashfn(id, len t.items); t.items[slot] = (id, x) :: t.items[slot]; } Strhash[T].del(t: self ref Strhash, id: string) { slot := hashfn(id, len t.items); p: list of (string, T); for(q := t.items[slot]; q != nil; q = tl q) if((hd q).t0 != id) p = hd q :: p; t.items[slot] = p; } Strhash[T].find(t: self ref Strhash, id: string): T { for(p := t.items[hashfn(id, len t.items)]; p != nil; p = tl p) if((hd p).t0 == id) return (hd p).t1; return t.nilval; } rev[T](x: list of T): list of T { l: list of T; for(; x != nil; x = tl x) l = hd x :: l; return l; } # join x to y, leaving result in arbitrary order. join[T](x, y: list of T): list of T { if(len x > len y) (x, y) = (y, x); for(; x != nil; x = tl x) y = hd x :: y; return y; } # join x to y, leaving result in arbitrary order. joinip[T](x, y: list of (int, T)): list of (int, T) { if(len x > len y) (x, y) = (y, x); for(; x != nil; x = tl x) y = hd x :: y; return y; } sort[S, T](s: S, a: array of T) for{ S => gt: fn(s: self S, x, y: T): int; } { mergesort(s, a, array[len a] of T); } mergesort[S, T](s: S, a, b: array of T) for{ S => gt: fn(s: self S, x, y: T): int; } { r := len a; if (r > 1) { m := (r-1)/2 + 1; mergesort(s, a[0:m], b[0:m]); mergesort(s, a[m:], b[m:]); b[0:] = a; for ((i, j, k) := (0, m, 0); i < m && j < r; k++) { if(s.gt(b[i], b[j])) a[k] = b[j++]; else a[k] = b[i++]; } if (i < m) a[k:] = b[i:m]; else if (j < r) a[k:] = b[j:r]; } }