![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to perv.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / boot|
Return to perv.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / boot |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: structure Initial = ! 3: struct ! 4: ! 5: structure Inside : sig structure System : SYSTEM ! 6: structure List : LIST ! 7: structure ByteArray : BYTEARRAY ! 8: structure IO : IO ! 9: structure Bool : BOOL ! 10: structure String : STRING ! 11: end = ! 12: struct ! 13: ! 14: open Core ! 15: ! 16: (* create a type-safe version of the InLine structure while preserving ! 17: the inline property of the functions. *) ! 18: structure InLine = ! 19: struct ! 20: infix 7 * div ! 21: infix 6 + - ! 22: infix 4 < > <= >= ! 23: infix 3 := ! 24: val callcc : ('a cont -> 'a) -> 'a = InLine.callcc ! 25: val throw : 'a cont -> 'a -> 'b = InLine.throw ! 26: val ! : 'a ref -> 'a = InLine.! ! 27: val op * : int * int -> int = InLine.* ! 28: val op + : int * int -> int = InLine.+ ! 29: val op - : int * int -> int = InLine.- ! 30: val op := : 'a ref * 'a -> unit = InLine.:= ! 31: val op < : int * int -> bool = InLine.< ! 32: val op <= : int * int -> bool = InLine.<= ! 33: val op > : int * int -> bool = InLine.> ! 34: val op >= : int * int -> bool = InLine.>= ! 35: val alength : 'a array -> int = InLine.alength ! 36: val boxed : 'a -> bool = InLine.boxed ! 37: val cast : 'a -> 'b = InLine.cast ! 38: val op div : int * int -> int = InLine.div ! 39: val fadd : real * real -> real = InLine.fadd ! 40: val fdiv : real * real -> real = InLine.fdiv ! 41: val feql : real * real -> bool = InLine.feql ! 42: val fge : real * real -> bool = InLine.fge ! 43: val fgt : real * real -> bool = InLine.fgt ! 44: val fle : real * real -> bool = InLine.fle ! 45: val flt : real * real -> bool = InLine.flt ! 46: val fmul : real * real -> real = InLine.fmul ! 47: val fneg : real -> real = InLine.fneg ! 48: val fneq : real * real -> bool = InLine.fneq ! 49: val fsub : real * real -> real = InLine.fsub ! 50: val ieql : int * int -> bool = InLine.ieql ! 51: val ineq : int * int -> bool = InLine.ineq ! 52: val makeref : 'a -> 'a ref = InLine.makeref ! 53: val ordof : string * int -> int = InLine.ordof ! 54: val slength : string -> int = InLine.slength ! 55: val store : string * int * int -> unit = InLine.store ! 56: val subscript : 'a array * int -> 'a = InLine.subscript ! 57: val update : 'a array * int * 'a -> unit = InLine.update ! 58: val ~ : int -> int = InLine.~ ! 59: val reql : 'a ref * 'a ref -> bool = InLine.ieql ! 60: val aeql : 'a array * 'a array -> bool = InLine.ieql ! 61: val andb : int * int -> int = InLine.andb ! 62: val orb : int * int -> int = InLine.orb ! 63: val xorb : int * int -> int = InLine.xorb ! 64: val rshift : int * int -> int = InLine.rshift ! 65: val lshift : int * int -> int = InLine.lshift ! 66: val notb : int -> int = InLine.notb ! 67: end (* structure InLine *) ! 68: ! 69: fun c_function s = ! 70: let exception C_function_not_found of string ! 71: fun f (Assembly.FUNC(p,t,rest)) = ! 72: if stringequal(s,t) then p ! 73: else if stringequal(t,"xxxx") then raise (C_function_not_found s) ! 74: else f rest ! 75: val cfun = f Assembly.external ! 76: in fn x => Assembly.A.callc(cfun,x) ! 77: end ! 78: ! 79: val isV9 = InLine.ieql(Assembly.opsys,3) ! 80: ! 81: val bigEndian = ! 82: case InLine.!(InLine.cast "\001\003\005\007") ! 83: of 8487555 => true ! 84: | 58884480 => false ! 85: ! 86: ! 87: (* The datatype ref is defined in the built-in structure PrimTypes. ! 88: It is not mention here because it has a unique representation; an ! 89: explicit datatype declaration would destroy this representation. ! 90: Similarly, there is no datatype specification in the REF signature ! 91: itself. *) ! 92: structure Ref = ! 93: struct ! 94: infix 3 := ! 95: val ! = InLine.! ! 96: val op := = InLine.:= ! 97: fun inc r = r := InLine.+(!r,1) ! 98: fun dec r = r := InLine.-(!r,1) ! 99: end (* structure Ref *) ! 100: ! 101: structure List : LIST = ! 102: struct ! 103: infixr 5 :: @ ! 104: open PrimTypes InLine ! 105: exception Hd ! 106: exception Tl ! 107: exception Nth ! 108: exception NthTail ! 109: fun hd (a::r) = a | hd nil = raise Hd ! 110: fun tl (a::r) = r | tl nil = raise Tl ! 111: fun null nil = true | null _ = false ! 112: fun length l = ! 113: let fun j(k,nil) = k ! 114: | j(k, a::x) = j(k+1,x) ! 115: in j(0,l) ! 116: end ! 117: fun op @ (nil,l) = l ! 118: | op @ (a::r, l) = a :: (r@l) ! 119: fun rev l = ! 120: let fun f (nil, h) = h ! 121: | f (a::r, h) = f(r, a::h) ! 122: in f(l,nil) ! 123: end ! 124: fun map f = ! 125: let fun m nil = nil ! 126: | m (a::r) = f a :: m r ! 127: in m ! 128: end ! 129: fun fold f [] = (fn b => b) ! 130: | fold f (a::r) = (fn b => let fun f2(e,[]) = f(e,b) ! 131: | f2(e,a::r) = f(e,f2(a,r)) ! 132: in f2(a,r) ! 133: end) ! 134: fun revfold f [] = (fn b => b) ! 135: | revfold f (a::r) = (fn b => let fun f2(e,[],b) = f(e,b) ! 136: | f2(e,a::r,b) = f2(a,r,f(e,b)) ! 137: in f2(a,r,b) ! 138: end) ! 139: fun app f = let fun a2 (e::r) = (f e; a2 r) | a2 nil = () in a2 end ! 140: fun revapp f = let fun a2 (e::r) = (a2 r; f e; ()) | a2 nil = () in a2 end ! 141: fun nthtail(e,0) = e ! 142: | nthtail(e::r,n) = nthtail(r,n-1) ! 143: | nthtail _ = raise NthTail ! 144: fun nth x = hd(nthtail x) handle NthTail => raise Nth | Hd => raise Nth ! 145: fun exists pred = ! 146: let fun f nil = false ! 147: | f (hd::tl) = pred hd orelse f tl ! 148: in f ! 149: end ! 150: end (* structure List *) ! 151: ! 152: structure PreString : sig exception Substring ! 153: infix 6 ^ ! 154: val substring : string * int * int -> string ! 155: val ^ : string * string -> string ! 156: val imakestring : int -> string ! 157: end = ! 158: struct ! 159: open InLine ! 160: exception Substring ! 161: fun substring("",0,0) = "" (* never call create_s with 0 *) ! 162: | substring("",_,_) = raise Substring ! 163: | substring(s,i,0) = if i>=0 ! 164: then if boxed s then if i <= slength s ! 165: then "" else raise Substring ! 166: else if i<=1 ! 167: then "" else raise Substring ! 168: else raise Substring ! 169: | substring(s,0,1) = if boxed s then cast(ordof(s,0)) else s ! 170: | substring(s,i,1) = ! 171: if boxed s then if i>=0 andalso i < slength s ! 172: then cast(ordof(s,i)) ! 173: else raise Substring ! 174: else if ieql(i,0) then s else raise Substring ! 175: | substring(s,i,len) = ! 176: if boxed s andalso i>=0 andalso i+len <= slength s ! 177: andalso len >= 0 ! 178: then let val a = Assembly.A.create_s(len) ! 179: fun copy j = if ieql(j,len) then () ! 180: else (store(a,j,ordof(s,i+j)); copy(j+1)) ! 181: in copy 0; a ! 182: end ! 183: else raise Substring ! 184: ! 185: infix 6 ^ ! 186: fun op ^ ("",s) = s ! 187: | op ^ (s,"") = s ! 188: | op ^ (x,y) = ! 189: if boxed x ! 190: then if boxed y ! 191: then let val xl = slength x and yl = slength y ! 192: val a = Assembly.A.create_s(xl+yl) ! 193: fun copyx n = if ieql(n,xl) then () ! 194: else (store(a,n,ordof(x,n)); copyx(n+1)) ! 195: fun copyy n = if ieql(n,yl) then () ! 196: else (store(a,xl+n,ordof(y,n)); copyy(n+1)) ! 197: in copyx 0; copyy 0; a ! 198: end ! 199: else let val xl = slength x ! 200: val a = Assembly.A.create_s(xl+1) ! 201: fun copyx n = if ieql(n,xl) then () ! 202: else (store(a,n,ordof(x,n)); copyx(n+1)) ! 203: in copyx 0; store(a,xl,cast y); a ! 204: end ! 205: else if boxed y ! 206: then let val yl = slength y ! 207: val a = Assembly.A.create_s(1+yl) ! 208: fun copyy n = if ieql(n,yl) then () ! 209: else (store(a,1+n,ordof(y,n)); copyy(n+1)) ! 210: in store(a,0,cast x); copyy 0; a ! 211: end ! 212: else let val a = Assembly.A.create_s 2 ! 213: in store(a,0,cast x); store(a,1,cast y); a ! 214: end ! 215: fun imakestring i = ! 216: if i<0 then "~" ^ imakestring(~i) ! 217: else if i<10 then InLine.cast(InLine.cast "0" + i) ! 218: else let val j = i div 10 ! 219: in imakestring j ^ imakestring(i-j*10) ! 220: end ! 221: ! 222: end (* structure PreString *) ! 223: ! 224: abstraction ByteArray : BYTEARRAY = ! 225: struct ! 226: open InLine PreString ! 227: infix 3 sub ! 228: type bytearray = string ! 229: exception Subscript ! 230: exception Range ! 231: fun array(len,v) = ! 232: if len<0 then raise Subscript ! 233: else if v<0 orelse v>=256 then raise Range ! 234: else if ieql(len,0) then Assembly.bytearray0 ! 235: else let val a = Assembly.A.create_b len ! 236: fun init i = if ieql(i,len) then () ! 237: else (store(a,i,v); init(i+1)) ! 238: in init 0; a ! 239: end ! 240: val length = cast slength ! 241: fun update(arg as (s,i,c)) = ! 242: if i<0 orelse i >= slength s then raise Subscript ! 243: else if c<0 orelse c>255 then raise Range ! 244: else store arg ! 245: val op sub = fn (s,i) => if i<0 orelse i>= slength s then raise Subscript ! 246: else ordof(s,i) ! 247: fun extract(ba,i,1) = if i<0 orelse i >= slength ba then raise Subscript ! 248: else cast(ordof(ba,i)) ! 249: | extract(s,i,len) = ! 250: if i<0 orelse i+len > slength s orelse len<0 then raise Subscript ! 251: else if ieql(len,0) then "" ! 252: else let val a = Assembly.A.create_s len ! 253: fun copy j = if ieql(j,len) then () ! 254: else (store(a,j,ordof(s,i+j)); copy(j+1)) ! 255: in copy 0; a ! 256: end ! 257: fun app f ba = ! 258: let val len = slength ba ! 259: fun app' i = if i >= len then () ! 260: else (f(ba sub i); app'(i+1)) ! 261: in app' 0 ! 262: end ! 263: fun revapp f ba = ! 264: let fun revapp' i = if i < 0 then () ! 265: else (f(ba sub i); revapp'(i-1)) ! 266: in revapp'(slength ba - 1) ! 267: end ! 268: fun fold f ba x = ! 269: let fun fold'(i,x) = if i < 0 then x else fold'(i-1, f(ordof(ba,i),x)) ! 270: in fold'(slength ba - 1, x) ! 271: end ! 272: fun revfold f ba x = ! 273: let val len = slength ba ! 274: fun revfold'(i,x) = if i >= len then x ! 275: else revfold'(i+1,f(ordof(ba,i),x)) ! 276: in revfold'(0,x) ! 277: end ! 278: end (* abstraction ByteArray *) ! 279: ! 280: structure PreLim = ! 281: struct ! 282: val exn_name : exn -> string = InLine.cast(fn(_,ref s) => s) ! 283: val interactive = Core.Refs.interactive ! 284: val prLambda = Core.Refs.prLambda ! 285: fun getargs s = ! 286: let val f : int -> string = c_function s ! 287: fun strlen(s,i) = ! 288: if InLine.ieql(InLine.ordof(s,i),0) then i ! 289: else strlen(s,InLine.+(i,1)) ! 290: fun mlstr x = ! 291: let val len = strlen(x,0) ! 292: val ba = Assembly.A.create_s len ! 293: fun copy ~1 = () ! 294: | copy i = (InLine.store(ba,i,InLine.ordof(x,i)); ! 295: copy(InLine.-(i,1))) ! 296: in copy (InLine.-(len,1)); ! 297: ba ! 298: end ! 299: fun g i = ! 300: let val x = f i ! 301: in if InLine.ineq(InLine.cast x,0) ! 302: then mlstr x :: g (InLine.+(i,1)) ! 303: else nil ! 304: end ! 305: in fn () => g 0 ! 306: end ! 307: val argv : unit -> string list = getargs "argv" ! 308: val environ : unit -> string list = getargs "envi" ! 309: end (* structure PreLim *) ! 310: ! 311: structure PreStats = ! 312: struct ! 313: datatype time = TIME of {sec : int, usec : int} ! 314: local open Assembly.A Ref ! 315: in ! 316: val zerotime = TIME{sec=0,usec=0} ! 317: val lines = Core.Refs.lines ! 318: val parse = InLine.cast Core.Refs.parse ! 319: val translate = InLine.cast Core.Refs.translate ! 320: val codeopt = InLine.cast Core.Refs.codeopt ! 321: val convert = InLine.cast Core.Refs.convert ! 322: val hoist = InLine.cast Core.Refs.hoistx ! 323: val cpsopt = InLine.cast Core.Refs.cpsopt ! 324: val closure = InLine.cast Core.Refs.closure ! 325: val globalfix = InLine.cast Core.Refs.globalfix ! 326: val spill = InLine.cast Core.Refs.spill ! 327: val codegen = InLine.cast Core.Refs.codegen ! 328: val freemap = InLine.cast Core.Refs.freemap ! 329: val execution = InLine.cast Core.Refs.execution ! 330: fun reset() = ! 331: (lines := 0; ! 332: parse := zerotime; ! 333: translate := zerotime; ! 334: codeopt := zerotime; ! 335: convert := zerotime; ! 336: cpsopt := zerotime; ! 337: closure := zerotime; ! 338: globalfix := zerotime; ! 339: spill := zerotime; ! 340: codegen := zerotime; ! 341: freemap := zerotime; ! 342: execution := zerotime) ! 343: end ! 344: end ! 345: ! 346: val errn = c_function "errn" ! 347: ! 348: fun syserror s = ! 349: let val n = errn() ! 350: open PreString ! 351: val m = InLine.alength Assembly.errorstrings ! 352: val w = if InLine.>=(n,m) orelse InLine.<(n,0) ! 353: then "Error " ^ imakestring n ! 354: else InLine.subscript(Assembly.errorstrings,n) ! 355: in raise Assembly.SystemCall (s ^ " failed, " ^ w) ! 356: end ! 357: ! 358: structure IOx = ! 359: struct ! 360: local open InLine Ref PreString PrimTypes in ! 361: type bytearray = string ! 362: exception Io of string ! 363: type instream = {filid : int, pos : int ref, len : int ref, name : string, ! 364: closed : bool ref, buf : bytearray, tty : bool ref} ! 365: type outstream = {filid : int, pos : int ref, name : string, ! 366: closed : bool ref, buf : bytearray, tty : bool ref} ! 367: ! 368: val isatty = c_function "isat" ! 369: ! 370: val bufsize = Core.bufsize ! 371: ! 372: val std_in = Core.std_in ! 373: val std_out = Core.std_out ! 374: val _ = (#tty std_in := isatty 0; #tty std_out := isatty 1) ! 375: ! 376: (* should be flushed on exportML, flushed and closed on exportFn *) ! 377: val outstreams = Core.Refs.outstreams ! 378: (* should be closed on exportFn *) ! 379: val instreams = Core.Refs.instreams ! 380: fun add_in s = instreams := s :: !instreams ! 381: fun add_out s = outstreams := s :: !outstreams ! 382: fun init_streams() = ! 383: let val {pos=pos_in,tty=tty_in,closed=closed_in,len,...} = std_in ! 384: val {pos=pos_out,tty=tty_out,closed=closed_out,...} = std_out ! 385: in pos_in := 0; tty_in := isatty 0; closed_in := false; len := 0; ! 386: pos_out := 0; tty_out := isatty 1; closed_out := false; ! 387: PreLim.interactive := !tty_in; ! 388: instreams := [std_in]; ! 389: outstreams := [std_out] ! 390: end ! 391: ! 392: (* the filename passed to Assembly.A.openf must be zero-padded; ! 393: you need 2 zeros in case padding a null string. *) ! 394: val c00 = "\000\000" ! 395: ! 396: fun close filid = case Assembly.A.syscall(6,[cast filid],1) ! 397: of ~1 => syserror "close" ! 398: | _ => () ! 399: ! 400: datatype mode = READ | WRITE | APPEND ! 401: ! 402: val openf = ! 403: if isV9 ! 404: then fn(name,mode) => ! 405: let open Assembly.A ! 406: in case mode ! 407: of READ => ! 408: (case syscall(5,[name,cast 0],2) ! 409: of ~1 => syserror "open" ! 410: | n => n) ! 411: | WRITE => ! 412: (case syscall(8,[name, cast 438],2) ! 413: of ~1 => syserror "creat" ! 414: | n => n) ! 415: | APPEND => ! 416: (case syscall(5,[name,cast 1],2) ! 417: of ~1 => (case syscall(8,[name, cast 438],2) ! 418: of ~1 => syserror "creat" ! 419: | n => n) ! 420: | n => (case syscall(19,[cast n,cast 0,cast 2],3) ! 421: of ~1 => (close n; syserror "lseek") ! 422: | _ => n)) ! 423: end ! 424: else fn (name,mode) => ! 425: let open Assembly.A ! 426: val flag = case mode of READ => 0 | WRITE => 1537 | APPEND => 521 ! 427: in case syscall(5,[name, cast flag, cast 438],3) ! 428: of ~1 => syserror "open" ! 429: | n => n ! 430: end ! 431: ! 432: fun open_in s = ! 433: let val f = openf(s ^ c00,READ) ! 434: handle Assembly.SystemCall message => ! 435: raise Io("open_in \"" ^ s ^ "\": " ^ message) ! 436: val s = {filid = f, pos = ref 0, closed = ref false, ! 437: len = ref 0, name = s, ! 438: buf = Assembly.A.create_b bufsize, tty = ref(isatty f)} ! 439: in add_in s; s ! 440: end ! 441: fun open_o mode = fn s => ! 442: let val f = openf(s ^ c00,mode) ! 443: val s = {filid = f, pos = ref 0, closed = ref false, name=s, ! 444: buf = Assembly.A.create_b bufsize, tty = ref(isatty f)} ! 445: in add_out s; s ! 446: end ! 447: ! 448: fun open_out name = open_o WRITE name ! 449: handle Assembly.SystemCall message => ! 450: raise Io("open_out \"" ^ name ^ "\": " ^ message) ! 451: ! 452: fun open_append name = open_o APPEND name ! 453: handle Assembly.SystemCall message => ! 454: raise Io("open_append \"" ^ name ^ "\": " ^ message) ! 455: ! 456: ! 457: fun open_string s = ! 458: if boxed s ! 459: then {filid = ~1, pos = ref 0, len = ref (slength s), ! 460: closed = ref false, tty = ref false, name="<string>", ! 461: buf = s} ! 462: else {filid = ~1, pos = ref 0, len = ref 1, ! 463: closed = ref false, tty = ref false, name="<string>", ! 464: buf =let val a = Assembly.A.create_s 1 ! 465: in store(a,0,cast s); a ! 466: end} ! 467: ! 468: fun read(filid, buf) = ! 469: case Assembly.A.syscall(3,[cast filid, buf, cast(slength buf)],3) ! 470: of ~1 => syserror "read" ! 471: | n => n ! 472: ! 473: fun filbuf ({closed = ref true,...} : instream) = ! 474: raise Assembly.SystemCall "closed instream" ! 475: | filbuf {filid = ~1,pos,len,...} = (len := 0; pos := 0) ! 476: | filbuf {filid,pos,buf,len,...} = ! 477: (pos := 0; len := read(filid,buf)) ! 478: ! 479: fun write(filid,s,l) = ! 480: case Assembly.A.syscall(4,[cast filid, s, cast l],3) ! 481: of ~1 => syserror "write" ! 482: | n => n ! 483: ! 484: fun write_sure(filid,s,l) = ! 485: let val k = write(filid,s,l) ! 486: in if ieql(k,l) then () ! 487: else let val subs = PreString.substring ! 488: fun f i = if i+k<l ! 489: then (write_sure(filid,subs(s,i,k),k); f(i+k)) ! 490: else write_sure(filid,subs(s,i,l-i),l-i) ! 491: in f k ! 492: end ! 493: end ! 494: ! 495: fun flush_out ({closed = ref true,name,...} : outstream) = ! 496: raise Io ("flush_out \"" ^ name ^ "\": closed stream") ! 497: | flush_out {pos = ref 0,...} = () ! 498: | flush_out {filid,pos,buf,name,...} = ! 499: (write_sure(filid,buf,!pos); ! 500: pos := 0) ! 501: handle Assembly.SystemCall s => ! 502: raise Io("flush_out \"" ^ name ^ "\": " ^ s) ! 503: ! 504: val flsbuf = flush_out ! 505: ! 506: fun close_in ({closed = ref true,name,...} : instream) = ! 507: raise Io("close_in \"" ^ name ^ "\": closed stream") ! 508: | close_in {filid = ~1,closed,len,pos,...} = ! 509: (closed := true; len := 0; pos := 1) ! 510: | close_in {filid,pos,len,closed,name,...} = ! 511: (closed := true; len := 0; pos := 1; ! 512: instreams := List.fold ! 513: (fn(s as {pos=p,...}:instream, tl) => ! 514: if ieql(cast pos, cast p) then tl else s::tl) ! 515: (!instreams) ! 516: nil; ! 517: close filid handle Assembly.SystemCall s => ! 518: raise Io("close_in \"" ^ name ^ "\": " ^ s)) ! 519: ! 520: fun close_out ({closed = ref true,name,...} : outstream) = ! 521: raise(Io("close_out \"" ^ name ^ "\": closed stream")) ! 522: | close_out (f as {filid,pos,closed,name,...}) = ! 523: (flsbuf f; pos := 0; closed := true; ! 524: outstreams := List.fold ! 525: (fn(s as {filid=f,...}:outstream,tl) => ! 526: if ieql(filid,f) then tl else s::tl) ! 527: (!outstreams) ! 528: nil; ! 529: close filid) ! 530: handle Assembly.SystemCall s => ! 531: raise Io("close_out \"" ^ name ^ "\": " ^ s) ! 532: ! 533: fun look ({closed = ref true,...} : instream) = ! 534: raise Assembly.SystemCall "closed stream" ! 535: | look (f as {len,pos,buf,...}) = ! 536: if !len > !pos ! 537: then cast(ordof(buf,!pos)) ! 538: else (filbuf f; if ieql(!len,0) then "" else look f) ! 539: ! 540: fun lookahead f = look f handle Assembly.SystemCall s => ! 541: raise Io("lookahead \"" ^ #name f ^ "\": " ^ s) ! 542: ! 543: fun end_of_stream ({closed = ref true,name,...} : instream) = ! 544: raise Io("end_of_stream \"" ^ name ^ "\": closed stream") ! 545: | end_of_stream f = case look f of "" => true | _ => false ! 546: handle Assembly.SystemCall s => ! 547: raise Io("end_of_stream \"" ^ #name f ^ "\": " ^ s) ! 548: ! 549: fun biginput(filid,k) = (* k must be larger than 1 *) ! 550: let val a = Assembly.A.create_s k ! 551: val len = read(filid,a) ! 552: in if ieql(len,k) then a ! 553: else PreString.substring(a,0,len) ! 554: end ! 555: ! 556: local ! 557: val mtim: int -> int = c_function "mtim" (* "mtim" gives ~1 on error *) ! 558: in ! 559: fun mtime({filid, closed,name, ...}: instream): int = ! 560: if !closed then ! 561: raise Io("mtime \"" ^ name ^ "\": closed stream") ! 562: else ! 563: let val tim = mtim filid ! 564: in if InLine.ieql(tim, ~1) then raise Io("mtime \"" ^ name ^ "\"") ! 565: else tim ! 566: end ! 567: end ! 568: ! 569: val fionread : int -> int = c_function "fion" ! 570: ! 571: fun input(f as {filid,pos,len,buf,closed,name,...} : instream) = ! 572: let val filbuf = fn f => (filbuf f ! 573: handle Assembly.SystemCall s => ! 574: raise Io("input \"" ^ name ^ "\": " ^ s)) ! 575: fun get i = ! 576: if (!len - !pos) >= i then ! 577: if ieql(i,1) then ! 578: let val p = !pos ! 579: in pos := p+1; cast(ordof(buf,p)) ! 580: end ! 581: else if i < 0 then ! 582: raise Io("input \"" ^ name ^ "\": negative character count") ! 583: else let val s = substring(buf,!pos,i) ! 584: in pos := !pos+i; s ! 585: end ! 586: else if !closed then raise Io("input \"" ^ name ^ "\": closed stream") ! 587: else let val remaining = !len - !pos ! 588: val s = substring(buf,!pos, remaining) ! 589: val j = i - remaining ! 590: val avail = if filid < 0 then 0 ! 591: else if j<=bufsize then j ! 592: else let val c = fionread filid ! 593: in if j<c then j else c ! 594: end ! 595: in if avail >= bufsize ! 596: then let val s' = biginput(filid,avail) ! 597: handle Assembly.SystemCall s => ! 598: raise Io("input \"" ^ name ^ "\": " ^ s) ! 599: in if boxed s' ! 600: then if ieql(slength s',0) ! 601: then s ! 602: else s ^ s' ^ get(j-slength s') ! 603: else s ^ s' ^ get(j-1) ! 604: end ! 605: else (filbuf f; ! 606: if ieql(!len,0) then s ! 607: else s ^ get j) ! 608: end ! 609: in get ! 610: end ! 611: ! 612: fun input_line({closed = ref true,name,...} : instream) = ! 613: raise Io ("input_line \"" ^ name ^ "\": closed stream") ! 614: | input_line(f as {pos,len,buf,name,...}) = ! 615: let val l = !len ! 616: val filbuf = fn f => (filbuf f ! 617: handle Assembly.SystemCall s => ! 618: raise Io("input_line \"" ^ name ^ "\": " ^ s)) ! 619: fun next j = if ieql(j,l) then ! 620: let val s = substring(buf, !pos, l - !pos) ! 621: in filbuf f; ! 622: if ieql(!len,0) then s ! 623: else s ^ input_line f ! 624: end ! 625: else if ieql(ordof(buf,j),10) then input f (j+1 - !pos) ! 626: else next(j+1) ! 627: in next (!pos) ! 628: end ! 629: ! 630: fun output(f as {filid,buf,pos,tty,closed,name,...} : outstream) = ! 631: let fun put s = ! 632: if !closed then raise Assembly.SystemCall "closed outstream" ! 633: else if boxed s then ! 634: let val l = slength s ! 635: in if l > 4 * bufsize ! 636: then (flsbuf f; write_sure(filid,s,l)) ! 637: handle Assembly.SystemCall s => ! 638: raise Io("output \"" ^ name ^ "\": " ^ s) ! 639: else let val i = ref 0 ! 640: in while !i < l ! 641: do let val c = ordof(s,!i) ! 642: in store(buf,!pos,c); ! 643: pos := !pos + 1; i := !i + 1; ! 644: if ieql(!pos,bufsize) ! 645: orelse (!tty andalso ieql(c,10)) ! 646: then flsbuf f ! 647: handle Assembly.SystemCall s => ! 648: raise Io("output \"" ^ name ^ "\": " ^ s) ! 649: else () ! 650: end ! 651: end ! 652: end ! 653: else (store(buf,!pos,cast s); ! 654: pos := !pos + 1; ! 655: if ieql(!pos,bufsize) ! 656: orelse (!tty andalso ieql(cast s,10)) ! 657: then flsbuf f ! 658: handle Assembly.SystemCall s => ! 659: raise Io("output \"" ^ name ^ "\": " ^ s) ! 660: else ()) ! 661: in put ! 662: end ! 663: ! 664: fun can_input ({closed = ref true,name,...} : instream) = ! 665: raise Io("can_input \"" ^ name ^ "\": closed stream") ! 666: | can_input {filid = ~1,pos,len,...} = !len - !pos ! 667: | can_input {filid,pos,len,name,...} = ! 668: !len - !pos + fionread filid ! 669: handle Assembly.SystemCall s => raise Io("can_input \"" ^ name ^ "\": " ^ s) ! 670: ! 671: local val buf = Assembly.A.create_b 8 ! 672: in fun pipe() = (* won't work for more than 256 file descriptors! *) ! 673: (case Assembly.A.syscall(42,[buf],1) ! 674: of ~1 => syserror "pipe" ! 675: | _ => if bigEndian then (InLine.ordof(buf,3),InLine.ordof(buf,7)) ! 676: else (InLine.ordof(buf,0),InLine.ordof(buf,4))) ! 677: end ! 678: ! 679: val exec : (string * int ref * int ref) -> int = c_function "exec" ! 680: ! 681: fun execute s = ! 682: let val fdin=ref 0 and fdout = ref 0 ! 683: in case exec(s^c00,fdin,fdout) ! 684: of ~1 => raise Io("Cannot execute "^s) ! 685: | _ => ! 686: let val r = {filid = !fdin, pos = ref 0, len = ref 0, ! 687: closed = ref false, name="<pipe_in>", ! 688: buf = Assembly.A.create_b bufsize, ! 689: tty = ref false} ! 690: val w = {filid = !fdout, pos = ref 0, ! 691: closed = ref false, name="<pipe_out>", ! 692: buf = Assembly.A.create_b bufsize, ! 693: tty = ref false} ! 694: in add_in r; ! 695: add_out w; ! 696: (r,w) ! 697: end ! 698: end ! 699: ! 700: fun is_term_in ({closed = ref true,name,...} : instream) = ! 701: raise Io("is_term_in \"" ^ name ^ "\": closed stream") ! 702: | is_term_in {tty=ref x,...} = x ! 703: ! 704: fun is_term_out ({closed = ref true,name,...} : outstream) = ! 705: raise Io("is_term_out \"" ^ name ^ "\": closed stream") ! 706: | is_term_out {tty=ref x,...} = x ! 707: ! 708: fun set_term_in ({closed = ref true,name,...} : instream,_) = ! 709: raise Io("set_term_in \"" ^ name ^ "\": closed stream") ! 710: | set_term_in ({tty,...},t) = tty := t ! 711: ! 712: fun set_term_out ({closed = ref true,name,...} : outstream,_) = ! 713: raise Io("set_term_out \"" ^ name ^ "\": closed stream") ! 714: | set_term_out ({tty,...},t) = tty := t ! 715: ! 716: val expo = c_function "expo" ! 717: fun exportML filename = ! 718: let val filid = openf(filename ^ c00,WRITE) ! 719: handle Assembly.SystemCall s => raise Io("exportML \"" ^ filename ^ "\": " ^ s) ! 720: in List.app flush_out (!outstreams); ! 721: if expo filid ! 722: then ((* mark previously opened streams as closed ! 723: without flushing them *) ! 724: List.app (fn {closed,...} : outstream => closed := true) ! 725: (!outstreams); ! 726: List.app (fn {closed,...} : instream => closed := true) ! 727: (!instreams); ! 728: (* restore std_in and std_out *) ! 729: init_streams(); ! 730: (* reset timing statistics *) ! 731: PreStats.reset(); ! 732: true) ! 733: else (close filid; false) ! 734: end ! 735: ! 736: val use_f = Core.Refs.use_f ! 737: val use_s : (instream -> unit) ref = cast Core.Refs.use_s ! 738: fun use f = !use_f f ! 739: fun use_stream s = !use_s s ! 740: val reduce_r = Core.Refs.reduce_r ! 741: val reduce : ('a -> 'b) -> ('a -> 'b) = fn x => cast(!reduce_r) x ! 742: ! 743: (* close/flush all streams; watch out, some may be damaged. *) ! 744: fun cleanup () = ! 745: let fun c_out s = close_out s handle _ => () ! 746: fun c_in s = close_in s handle _ => () ! 747: in List.app c_out (!outstreams); ! 748: List.app c_in (!instreams) ! 749: end ! 750: ! 751: fun quit _ = (Assembly.A.syscall(1,[cast 0],1); ()) ! 752: ! 753: fun exportFn (filename,func) = ! 754: let val filid=openf(filename ^ c00,WRITE) ! 755: handle Assembly.SystemCall s => raise Io("exportFn \"" ^ filename ^ "\": " ^ s) ! 756: val pr = output std_out ! 757: in cleanup(); ! 758: use_f := (fn (_ : string) => ()); ! 759: use_s := (fn (_ : instream) => ()); ! 760: reduce_r := (fn (x:unit->unit) => x); ! 761: Core.Refs.lookup_r := cast(fn ()=>()); ! 762: Core.Refs.compreturn := ! 763: [cast(quit, fn e => (pr "uncaught exception "; ! 764: pr (PreLim.exn_name e); ! 765: pr "\n"; cleanup(); quit()))]; ! 766: PreLim.prLambda := (fn () => ()); ! 767: if expo filid ! 768: then (init_streams(); ! 769: func(PreLim.argv(),PreLim.environ()); ! 770: cleanup(); ! 771: quit()) ! 772: handle exn => ! 773: (pr "uncaught exception "; ! 774: pr (PreLim.exn_name exn); ! 775: pr "\n"; ! 776: cleanup()) ! 777: else () ! 778: end ! 779: ! 780: val blas : int * 'a -> 'a = c_function "blas" ! 781: val salb : string -> 'a = c_function "salb" ! 782: fun blast_write((s as {filid,...}) : outstream, obj) = ! 783: (flush_out s; blas(filid,obj); ()) ! 784: fun blast_read f = salb (input f (can_input f)) ! 785: ! 786: end (* local open ... *) ! 787: end (* structure IOx *) ! 788: ! 789: abstraction IO : IO = IOx; ! 790: ! 791: ! 792: structure Bool : BOOL = ! 793: struct ! 794: open PrimTypes (* for datatype bool *) ! 795: fun not true = false ! 796: | not false = true ! 797: fun makestring true = "true" ! 798: | makestring false = "false" ! 799: local val pr = IO.output IO.std_out in ! 800: fun print b = pr(makestring b) ! 801: end ! 802: end (* structure Bool *) ! 803: ! 804: ! 805: structure String : STRING = ! 806: struct ! 807: open PrimTypes InLine ! 808: infix 4 > < >= <= ! 809: infix 6 ^ ! 810: type string = string ! 811: fun length s = if boxed s then slength s else 1 ! 812: val size = length ! 813: exception Substring = PreString.Substring ! 814: val substring = PreString.substring ! 815: fun explode s = ! 816: if boxed s ! 817: then let fun f(l,~1) = l ! 818: | f(l, i) = f(cast(ordof(s,i)) :: l, i-1) ! 819: in f(nil, slength s - 1) ! 820: end ! 821: else [s] ! 822: val op ^ = PreString.^ ! 823: exception Chr ! 824: fun chr i = if i<0 orelse i>255 then raise Chr else cast i ! 825: exception Ord ! 826: fun ord "" = raise Ord ! 827: | ord s = if boxed s then ordof(s,0) else cast s ! 828: val ordof = fn (s,i) => ! 829: if boxed s ! 830: then if i<0 orelse i>= slength s then raise Ord else ordof(s,i) ! 831: else if ieql(i,0) then cast s else raise Ord ! 832: val print = IO.output IO.std_out ! 833: fun implode (sl:string list) = ! 834: let val len = List.fold(fn(s,l) => length s + l) sl 0 ! 835: in case len ! 836: of 0 => "" ! 837: | 1 => let fun find (""::tl) = find tl ! 838: | find (hd::_) = cast hd ! 839: | find nil = "" (* impossible *) ! 840: in find sl ! 841: end ! 842: | _ => let val new = Assembly.A.create_s len ! 843: fun copy (nil,_) = () ! 844: | copy (s::tl,base) = ! 845: let val len = length s ! 846: fun copy0 0 = () ! 847: | copy0 i = ! 848: let val next = i-1 ! 849: in store(new,base+next,ordof(s,next)); ! 850: copy0 next ! 851: end ! 852: in copy0 len; ! 853: copy(tl,base+len) ! 854: end ! 855: in copy(sl,0); ! 856: new ! 857: end ! 858: end ! 859: fun sgtr("","") = false ! 860: | sgtr(_,"") = true ! 861: | sgtr("",_) = false ! 862: | sgtr(a,b) = ! 863: if boxed a ! 864: then if boxed b ! 865: then let val al = slength a and bl = slength b ! 866: val n = if al<bl then al else bl ! 867: fun f i = ! 868: if ieql(i,n) then al > bl ! 869: else if ieql(InLine.ordof(a,i),InLine.ordof(b,i)) then f(i+1) ! 870: else InLine.ordof(a,i) > InLine.ordof(b,i) ! 871: in f 0 ! 872: end ! 873: else InLine.ordof(a,0) >= cast(b) ! 874: else if boxed b ! 875: then cast(a) > InLine.ordof(b,0) ! 876: else cast(a) > cast(b) ! 877: fun op <= (a,b) = Bool.not(sgtr(a,b)) ! 878: fun op < (a,b) = sgtr(b,a) ! 879: fun op >= (a,b) = Bool.not(sgtr(b,a)) ! 880: val op > = sgtr ! 881: end (* structure String *) ! 882: ! 883: structure System : SYSTEM = ! 884: struct ! 885: structure ByteArray : BYTEARRAY = ByteArray ! 886: structure Control : CONTROL = ! 887: struct ! 888: structure Runtime : RUNTIMECONTROL = Assembly ! 889: structure MC : MCCONTROL = ! 890: struct ! 891: val printArgs = Core.Refs.printArgs ! 892: val printRet = Core.Refs.printRet ! 893: val bindContainsVar = Core.Refs.bindContainsVar ! 894: val bindExhaustive = Core.Refs.bindExhaustive ! 895: val matchExhaustive = Core.Refs.matchExhaustive ! 896: val matchRedundant = Core.Refs.matchRedundant ! 897: val expandResult = Core.Refs.expandResult ! 898: end ! 899: structure CG : CGCONTROL = ! 900: struct ! 901: structure M68 = ! 902: struct ! 903: val trapv = Core.Refs.trapv ! 904: end ! 905: val tailrecur = Core.Refs.tailrecur ! 906: val recordopt = Core.Refs.recordopt ! 907: val tail = Core.Refs.tail ! 908: val profile = Core.Refs.profile ! 909: val closureprint = Core.Refs.closureprint ! 910: val closureStrategy = Core.Refs.closureStrategy ! 911: val rounds = Core.Refs.rounds ! 912: val path = Core.Refs.path ! 913: val hoist = Core.Refs.hoist ! 914: val reduce = Core.Refs.reduce ! 915: val bodysize = Core.Refs.bodysize ! 916: val reducemore = Core.Refs.reducemore ! 917: val alphac = Core.Refs.alphac ! 918: val comment = Core.Refs.comment ! 919: val knowngen = Core.Refs.knowngen ! 920: val stdgen = Core.Refs.stdgen ! 921: val knowncl = Core.Refs.knowncl ! 922: val foldconst = Core.Refs.foldconst ! 923: val etasplit = Core.Refs.etasplit ! 924: val printit = Core.Refs.printit ! 925: val printsize = Core.Refs.printsize ! 926: val scheduling = Core.Refs.scheduling ! 927: end ! 928: structure Print : PRINTCONTROL = ! 929: struct ! 930: val printDepth = Core.Refs.printDepth ! 931: val stringDepth = Core.Refs.stringDepth ! 932: val signatures = Core.Refs.signatures ! 933: end ! 934: structure ProfileInternals : PROFILEINTERNALS = ! 935: struct ! 936: structure ByteArray = ByteArray ! 937: open InLine ! 938: val other : ByteArray.bytearray = cast(Core.other) ! 939: val toplevel : ByteArray.bytearray = cast(Core.toplevel) ! 940: val gc : ByteArray.bytearray = cast(Core.gc) ! 941: val globalProfile : ByteArray.bytearray list ref ! 942: = InLine.cast Core.Refs.globalProfile ! 943: ! 944: fun setToplevel () = ! 945: cast(Assembly.current) := toplevel ! 946: ! 947: fun setOther () = ! 948: cast(Assembly.current) := other ! 949: ! 950: fun listofarray a = ! 951: let fun loop(~1,x) = x ! 952: | loop(i,x) = loop(i-1, InLine.subscript(a,i) :: x) ! 953: in loop(InLine.alength a - 1, nil) ! 954: end ! 955: ! 956: fun zeroCount e = (InLine.update(cast e,0,0); ! 957: InLine.update(cast e,1,0)) ! 958: ! 959: val timerval = if bigEndian then "\000\000\000\000\ ! 960: \\000\000\039\016\ ! 961: \\000\000\000\000\ ! 962: \\000\000\039\016" ! 963: else "\000\000\000\000\ ! 964: \\016\039\000\000\ ! 965: \\000\000\000\000\ ! 966: \\016\039\000\000" ! 967: val timerval0 = "\000\000\000\000\000\000\000\000\ ! 968: \\000\000\000\000\000\000\000\000" ! 969: ! 970: fun setitimer t = ! 971: case Assembly.A.syscall(83,[cast 1,t,cast 0],3) ! 972: of ~1 => syserror "setitimer" ! 973: | x => x ! 974: ! 975: fun copy(ba,str) = ! 976: let val len = slength str ! 977: fun loop i = ! 978: if ieql(i,len) ! 979: then () ! 980: else (ByteArray.update(ba,i,ordof(str,i)); loop(i+1)) ! 981: in loop 0 ! 982: end ! 983: ! 984: val _ = copy(other, "aaaaaaaa(unprofiled)") ! 985: val _ = copy(toplevel,"aaaaaaaa(toplevel)") ! 986: val _ = copy(gc, "aaaaaaaa(gc)") ! 987: ! 988: fun add profile = ! 989: if boxed profile ! 990: then let val entries = listofarray profile ! 991: in List.app zeroCount entries; ! 992: globalProfile := List.@(entries,!globalProfile) ! 993: end ! 994: else () ! 995: ! 996: fun extractInt(ba,start,len) = ! 997: !(cast(ByteArray.extract(ba,start,len)):int ref) ! 998: ! 999: fun trans ba = ! 1000: (extractInt(ba,0,4), extractInt(ba,4,4), ! 1001: ByteArray.extract(ba,8,ByteArray.length ba - 8)) ! 1002: ! 1003: local fun insert (a,nil) = [a] ! 1004: | insert (a0 as (a',a,_),l as (x0 as (x',x,_))::y) = ! 1005: if a<x orelse ieql(a,x) andalso a'<x' ! 1006: then x0::insert(a0,y) else a0::l ! 1007: in fun sort nil = nil ! 1008: | sort (a::b) = insert(a,sort b) ! 1009: end ! 1010: ! 1011: ! 1012: fun field (st,w) = ! 1013: let val s = PreString.^(" ", st) ! 1014: in PreString.substring(s,String.length s - w, w) ! 1015: end ! 1016: ! 1017: fun decimal(st,w) = ! 1018: PreString.^(PreString.^( ! 1019: (PreString.substring(st,0,String.length st - w) ! 1020: handle PreString.Substring => "") ! 1021: ,"."), ! 1022: let val st' = PreString.^("0000000000",st) ! 1023: in PreString.substring(st',String.length st' - w,w) ! 1024: end) ! 1025: ! 1026: fun muldiv(i,j,k) = ! 1027: (i*j div k) ! 1028: handle Assembly.Overflow => muldiv(i,j div 2, k div 2) ! 1029: ! 1030: fun decfield(n,j,k,w1,w2) = ! 1031: field(decimal(PreString.imakestring (muldiv(n,j,k)),w1) ! 1032: handle Assembly.Div => "",w2) ! 1033: ! 1034: fun printReport f l = ! 1035: let val l' as (_,_,_,ticks)::_ ! 1036: = List.fold (fn((n,m,s),l as (_,_,_,cum)::_)=>(n,m,s,m+cum)::l ! 1037: |((n,m,s),nil)=>[(n,m,s,m)]) (sort l) nil ! 1038: val pr = IO.output f ! 1039: in pr(field("%time",6)); ! 1040: pr(field("cumsecs",9)); ! 1041: pr(field("#call",10)); ! 1042: pr(field("ms/call",10)); ! 1043: pr(" name\n"); ! 1044: List.app (fn (n,m,s,cumm) => ! 1045: (pr(decfield(m,10000,ticks,2,6)); ! 1046: pr(decfield((ticks-cumm+m),2,1,2,9)); ! 1047: pr(field(PreString.imakestring n,10)); ! 1048: pr(decfield(m,50000,n,4,10)); ! 1049: pr " "; pr s; pr "\n")) ! 1050: l'; ! 1051: () ! 1052: end ! 1053: ! 1054: structure P = ! 1055: struct ! 1056: structure IO = IO ! 1057: val profiling = Core.Refs.profiling ! 1058: fun profileOn () = (setitimer timerval; ()) ! 1059: fun profileOff () = (setitimer timerval0; ()) ! 1060: fun reset () = List.app zeroCount (!globalProfile) ! 1061: fun clear () = (globalProfile := [toplevel,gc,other]; reset()) ! 1062: fun report f = ! 1063: printReport f (List.map trans (!globalProfile)) ! 1064: val _ = clear() ! 1065: end ! 1066: val add = InLine.cast add ! 1067: end (* structure ProfileInternals *) ! 1068: structure Profile = ProfileInternals.P ! 1069: structure Debug : DEBUG = ! 1070: struct ! 1071: val debugging = Core.Refs.debug1 ! 1072: val getDebugf = InLine.cast Core.Refs.getDebugf ! 1073: val interface = InLine.cast Core.Refs.debugInterface ! 1074: end ! 1075: val prLambda = PreLim.prLambda ! 1076: val debugging = Core.Refs.debugging ! 1077: val primaryPrompt = Core.Refs.primaryPrompt ! 1078: val secondaryPrompt = Core.Refs.secondaryPrompt ! 1079: val internals = Core.Refs.internals ! 1080: val weakUnderscore = Core.Refs.weakUnderscore ! 1081: val interp = Core.Refs.interp ! 1082: val debugLook = Core.Refs.debugLook ! 1083: val debugCollect = Core.Refs.debugCollect ! 1084: val debugBind = Core.Refs.debugBind ! 1085: val saveLambda = Core.Refs.saveLambda ! 1086: val saveLvarNames = Core.Refs.saveLvarNames ! 1087: val timings = Core.Refs.timings ! 1088: val reopen = Core.Refs.reopen ! 1089: end (* structure Control *) ! 1090: structure Tags : TAGS = (* taken from runtime/tags.h *) ! 1091: struct ! 1092: val width_tags = 4 ! 1093: val power_tags = 16 ! 1094: val tag_record = 1 ! 1095: val tag_array = 9 ! 1096: val tag_bytearray = 11 ! 1097: val tag_string = 15 ! 1098: val tag_embedded = 7 ! 1099: val tag_suspension = 13 ! 1100: val tag_backptr = 5 ! 1101: val tag_forwarded = 3 ! 1102: end (* structure Tags *) ! 1103: structure Timer : TIMER = ! 1104: struct ! 1105: structure P : sig datatype time = TIME of {sec : int, usec : int} end ! 1106: = PreStats ! 1107: open P ! 1108: open InLine PreString ! 1109: type timer = time * time ! 1110: val gettime : int ref * int ref * int ref * int ref -> unit ! 1111: = c_function "time" ! 1112: fun timer() = ! 1113: let val gu = ref 0 and gs = ref 0 and tu = ref 0 and ts = ref 0 ! 1114: in gettime(gu,gs,tu,ts); ! 1115: (TIME{sec= !ts, usec = !tu},TIME{sec= !gs, usec = !gu}) ! 1116: end ! 1117: ! 1118: val start_timer = timer ! 1119: fun delta(s2,u2,s1,u1) = ! 1120: let val (sec,usec) = (s2-s1,u2-u1) ! 1121: val (sec,usec) = if usec < 0 ! 1122: then (sec-1,usec+1000000) ! 1123: else (sec,usec) ! 1124: in (sec,usec) ! 1125: end ! 1126: fun check_timer (TIME{sec=start_s,usec=start_u}, ! 1127: TIME{sec=gstart_s,usec=gstart_u}) = ! 1128: let val (TIME{sec=curr_s,usec=curr_u}, ! 1129: TIME{sec=gcurr_s,usec=gcurr_u}) = timer() ! 1130: val (sec,usec) = delta(curr_s,curr_u,start_s,start_u) ! 1131: val (g_sec,g_usec) = delta(gcurr_s,gcurr_u,gstart_s,gstart_u) ! 1132: val (sec,usec) = delta(sec,usec,g_sec,g_usec) ! 1133: in TIME{sec=sec,usec=usec} ! 1134: end ! 1135: fun check_timer_gc (TIME{sec=start_s,usec=start_u}, ! 1136: TIME{sec=gstart_s,usec=gstart_u}) = ! 1137: let val (TIME{sec=curr_s,usec=curr_u}, ! 1138: TIME{sec=gcurr_s,usec=gcurr_u}) = timer() ! 1139: val (g_sec,g_usec) = delta(gcurr_s,gcurr_u,gstart_s,gstart_u) ! 1140: in TIME{sec=g_sec,usec=g_usec} ! 1141: end ! 1142: fun makestring(TIME{sec,usec}) = ! 1143: let val filler = if usec <= 0 then "" ! 1144: else if usec < 10 then "00000" ! 1145: else if usec < 100 then "0000" ! 1146: else if usec < 1000 then "000" ! 1147: else if usec < 10000 then "00" ! 1148: else if usec < 100000 then "0" ! 1149: else "" ! 1150: in imakestring sec ^ "." ^ filler ^ imakestring usec ! 1151: end ! 1152: fun add_time(TIME{sec=s0,usec=u0},TIME{sec=s1,usec=u1}) = ! 1153: let val (s,u) = (s0+s1,u0+u1) ! 1154: val (s,u) = if u > 1000000 then (s+1,u-1000000) ! 1155: else (s,u) ! 1156: in TIME{sec=s,usec=u} ! 1157: end ! 1158: end (* structure Timer *) ! 1159: structure Stats : STATS = ! 1160: struct ! 1161: open Timer Ref PreStats Control.Runtime PreString ! 1162: fun update(a,b) = a := add_time(!a,b) ! 1163: fun summary() = ! 1164: let val pr = IO.output IO.std_out ! 1165: val (total,garbagetime) = start_timer() ! 1166: in pr (imakestring(!lines)); ! 1167: pr " lines\n"; ! 1168: pr "parse, "; pr(makestring(!parse)); pr "s\n"; ! 1169: pr "translate, "; pr(makestring(!translate)); pr "s\n"; ! 1170: pr "codeopt, "; pr(makestring(!codeopt)); pr "s\n"; ! 1171: pr "convert, "; pr(makestring(!convert)); pr "s\n"; ! 1172: pr "cpsopt, "; pr(makestring(!cpsopt)); pr "s\n"; ! 1173: pr "closure, "; pr(makestring(!closure)); pr "s\n"; ! 1174: pr "globalfix, "; pr(makestring(!globalfix)); pr "s\n"; ! 1175: pr "spill, "; pr(makestring(!spill)); pr "s\n"; ! 1176: pr "codegen, "; pr(makestring(!codegen)); pr "s\n"; ! 1177: pr "freemap, "; pr(makestring(!freemap)); pr "s\n"; ! 1178: pr "execution, "; pr(makestring(!execution)); pr "s\n"; ! 1179: pr "garbagetime, "; pr(makestring garbagetime); pr "s\n"; ! 1180: pr "total "; pr(makestring total); pr "s\n"; ! 1181: pr "collections: "; pr(imakestring(!minorcollections)); ! 1182: pr " minor, "; pr(imakestring(!majorcollections)); ! 1183: pr " major\n"; pr(imakestring(!collected)); ! 1184: pr " collected from "; pr(imakestring(!collectedfrom)); ! 1185: pr " possible ("; ! 1186: case !collectedfrom of ! 1187: 0 => () ! 1188: | _ => pr(imakestring(InLine.div(InLine.*(!collected,100), ! 1189: !collectedfrom))); ! 1190: pr "%)\n"; ! 1191: () ! 1192: end ! 1193: abstraction Timer : TIMER = Timer ! 1194: end (* structure Stats *) ! 1195: abstraction Timer : TIMER = Timer (* to hide timer datatype *) ! 1196: ! 1197: structure Unsafe : UNSAFE = ! 1198: struct ! 1199: structure Assembly : ASSEMBLY = Assembly ! 1200: type object = Assembly.object ! 1201: val boxed=InLine.cast() ! 1202: val ordof=InLine.cast() ! 1203: val slength=InLine.cast() ! 1204: val store=InLine.cast() ! 1205: val subscript=InLine.cast() ! 1206: val update=InLine.cast() ! 1207: val delay= InLine.cast() ! 1208: val force = InLine.cast() ! 1209: fun boot (x: string) : 'a -> 'b = ! 1210: InLine.cast(InLine.+(InLine.cast x, 4),0) ! 1211: val cast = InLine.cast ! 1212: val syscall = Assembly.A.syscall ! 1213: val blast_write = cast IOx.blast_write ! 1214: val blast_read = cast IOx.blast_read ! 1215: val create_s = Assembly.A.create_s ! 1216: val store_s : string * int * int -> unit ! 1217: = InLine.cast ByteArray.update ! 1218: val lookup_r : (int->object) ref= cast Core.Refs.lookup_r ! 1219: val lookup = fn i => case lookup_r of ref f => f i ! 1220: ! 1221: val do_it = ! 1222: InLine.callcc(fn c0 => ! 1223: let val v = ! 1224: InLine.callcc(fn c => InLine.throw c0 (InLine.throw c)) () ! 1225: handle e => ! 1226: let val ref(op ::((k,h),r)) = cast Core.Refs.compreturn ! 1227: in InLine.:=(Core.Refs.compreturn, cast r); h e ! 1228: end ! 1229: val ref(op ::((k,h),r)) = cast Core.Refs.compreturn ! 1230: in InLine.:=(Core.Refs.compreturn, cast r); k v ! 1231: end) ! 1232: ! 1233: fun isolate f = InLine.callcc(fn c => ! 1234: raise(InLine.callcc(fn c' => ! 1235: (InLine.:=(cast Core.Refs.compreturn, ! 1236: op ::( (InLine.throw c, InLine.throw c'), ! 1237: cast(InLine.! Core.Refs.compreturn))); do_it f)))) ! 1238: ! 1239: val pstruct = cast Core.Refs.pstruct ! 1240: local ! 1241: datatype A = unboxed | boxed of object ! 1242: val cast = InLine.cast ! 1243: in exception Boxity ! 1244: val tuple : object -> object array ! 1245: = cast(fn unboxed => raise Boxity ! 1246: | x as boxed _ => x) ! 1247: val string : object -> string = cast (fn x=>x) ! 1248: val real : object -> real = cast (fn x=>x) ! 1249: val int : object -> int ! 1250: = cast(fn x as unboxed => x ! 1251: | boxed _ => raise Boxity) ! 1252: end (* local datatype A ... *) ! 1253: structure AA : sig ! 1254: datatype datalist = DATANIL | DATACONS of (string * string * datalist) ! 1255: val datalist : datalist ! 1256: end = Assembly ! 1257: open AA ! 1258: end (* Unsafe *) ! 1259: ! 1260: open PreLim ! 1261: val version = "Standard ML of New Jersey, Version 0.44, 4 December 1989" ! 1262: val cleanup = IO.cleanup ! 1263: val c00 = "\000\000" ! 1264: val syst = c_function "syst" ! 1265: fun system x = ! 1266: case syst(PreString.^(x,c00)) ! 1267: of 0 => () ! 1268: | _ => raise Assembly.SystemCall "system" ! 1269: fun cd s = ! 1270: case Unsafe.syscall(12,[PreString.^(s,c00)],1) ! 1271: of ~1 => syserror "chdir" ! 1272: | _ => () ! 1273: ! 1274: end (* structure System *) ! 1275: ! 1276: end (* structure Inside *) ! 1277: ! 1278: open Inside PrimTypes ! 1279: ! 1280: (* The following structures must be without signatures so that inlining ! 1281: can take place *) ! 1282: ! 1283: structure General = ! 1284: struct ! 1285: infix 3 o ! 1286: infix before ! 1287: exception Bind = Core.Bind ! 1288: exception Match = Core.Match ! 1289: exception Interrupt = Core.Assembly.Interrupt ! 1290: exception SystemCall = Core.Assembly.SystemCall ! 1291: ! 1292: val callcc : ('a cont -> 'a) -> 'a = InLine.callcc ! 1293: val throw : 'a cont -> 'a -> 'b = InLine.throw ! 1294: fun f o g = fn x => f(g x) ! 1295: fun a before b = a ! 1296: datatype 'a option = NONE | SOME of 'a ! 1297: type 'a cont = 'a cont ! 1298: type exn = exn ! 1299: type unit = unit ! 1300: infix 4 = <> ! 1301: val op = : ''a * ''a -> bool = InLine.= ! 1302: val op <> : ''a * ''a -> bool = InLine.<> ! 1303: end (* structure General *) ! 1304: ! 1305: structure Bits = ! 1306: struct ! 1307: val andb : int * int -> int = InLine.andb ! 1308: val orb : int * int -> int = InLine.orb ! 1309: val lshift : int * int -> int = InLine.lshift ! 1310: val rshift : int * int -> int = InLine.rshift ! 1311: val notb : int -> int = InLine.notb ! 1312: val xorb : int * int -> int = InLine.xorb ! 1313: end ! 1314: ! 1315: structure Ref = ! 1316: struct ! 1317: infix 3 := ! 1318: val ! : 'a ref -> 'a = InLine.! ! 1319: val op := : 'a ref * 'a -> unit = InLine.:= ! 1320: fun inc r = r := (InLine.+ : int * int -> int) (!r,1) ! 1321: fun dec r = r := (InLine.- : int * int -> int) (!r,1) ! 1322: end ! 1323: ! 1324: structure Array = ! 1325: struct ! 1326: local open InLine in ! 1327: infix 3 sub ! 1328: type 'a array = 'a array ! 1329: exception Subscript ! 1330: val array : int * '1a -> '1a array = ! 1331: fn arg as (n,v) => ! 1332: if <=(n,0) then if <(n,0) then raise Subscript ! 1333: else Core.Assembly.array0 ! 1334: else Core.Assembly.A.array arg ! 1335: val op sub : 'a array * int -> 'a = ! 1336: fn (a,i) => ! 1337: if <(i,0) orelse >=(i,alength a) then raise Subscript ! 1338: else subscript(a,i) ! 1339: val length : 'a array -> int = alength ! 1340: fun arrayoflist nil = Core.Assembly.array0 ! 1341: | arrayoflist (l as (e::r)) = ! 1342: let val a = array(List.length l, e) ! 1343: fun init ((e::r),n) = (update(a,n,e); init(r,+(n,1))) ! 1344: | init (nil,_) = () ! 1345: in init(r,1); a ! 1346: end ! 1347: val update : 'a array * int * 'a -> unit = ! 1348: fn (a,i,v) => ! 1349: if <(i,0) orelse >=(i,alength a) then raise Subscript ! 1350: else update(a,i,v) ! 1351: end (* local open ... *) ! 1352: end (* structure Array *) ! 1353: ! 1354: structure Integer = ! 1355: struct ! 1356: infix 7 * div mod ! 1357: infix 6 + - ! 1358: infix 4 > < >= <= ! 1359: exception Div = Core.Assembly.Div ! 1360: exception Overflow = Core.Assembly.Overflow ! 1361: type int = int ! 1362: val ~ : int -> int = InLine.~ ! 1363: val op * : int * int -> int = InLine.* ! 1364: val op div : int * int -> int = InLine.div ! 1365: fun op mod(a:int,b:int):int = InLine.-(a,InLine.*(InLine.div(a,b),b)) ! 1366: val op + : int * int -> int = InLine.+ ! 1367: val op - : int * int -> int = InLine.- ! 1368: val op > : int * int -> bool = InLine.> ! 1369: val op >= : int * int -> bool = InLine.>= ! 1370: val op < : int * int -> bool = InLine.< ! 1371: val op <= : int * int -> bool = InLine.<= ! 1372: fun min(a,b) = if a<b then a else b ! 1373: fun max(a,b) = if a>b then a else b ! 1374: fun abs a = if a<0 then ~a else a ! 1375: fun makestring i = ! 1376: if i<0 then String.^("~", makestring(~i)) ! 1377: else if i<10 then InLine.cast(InLine.cast "0" + i) ! 1378: else let val j = i div 10 ! 1379: in String.^(makestring j, makestring(i-j*10)) ! 1380: end ! 1381: local val pr = IO.output IO.std_out in ! 1382: fun print i = pr(makestring i) ! 1383: end ! 1384: end (* structure Integer *) ! 1385: ! 1386: structure Real = ! 1387: struct ! 1388: local ! 1389: open Math String ! 1390: val negone = ~1.0 ! 1391: val zero = 0.0 ! 1392: val half = 0.5 ! 1393: val one = 1.0 ! 1394: val two = 2.0 ! 1395: val five = 5.0 ! 1396: val ten = 10.0 ! 1397: in ! 1398: infix 7 * / ! 1399: infix 6 + - ! 1400: infix 4 > < >= <= ! 1401: type real = real ! 1402: exception Real = Core.Assembly.Real ! 1403: exception Float = Real ! 1404: val ~ : real -> real = InLine.fneg ! 1405: val op + : real * real -> real = InLine.fadd ! 1406: val op - : real * real -> real = InLine.fsub ! 1407: val op * : real * real -> real = InLine.fmul ! 1408: val op / : real * real -> real = InLine.fdiv ! 1409: val op > : real * real -> bool = InLine.fgt ! 1410: val op < : real * real -> bool = InLine.flt ! 1411: val op >= : real * real -> bool = InLine.fge ! 1412: val op <= : real * real -> bool = InLine.fle ! 1413: val sin = sin and cos = cos and sqrt = sqrt and arctan = arctan ! 1414: and exp = exp and ln = ln ! 1415: exception Sqrt = Sqrt and Exp = Exp and Ln = Ln ! 1416: exception Floor ! 1417: local ! 1418: fun rtoi (pred,init) = ! 1419: let fun loop n = ! 1420: if pred n ! 1421: then init ! 1422: else let val (i,r) = loop(n * half) ! 1423: val i' = InLine.lshift(i,1) ! 1424: val r' = r+r ! 1425: in if n-r' < one then (i',r') else (InLine.+(i',1),r'+one) ! 1426: end ! 1427: in loop ! 1428: end ! 1429: val pton = rtoi(fn x => x < one, (0,zero)) ! 1430: val nton = rtoi(fn x => x >= negone, (~1,negone)) ! 1431: fun fl n = if n < zero then nton n else pton n ! 1432: fun tr n = #1(pton n) ! 1433: in ! 1434: fun truncate n = if n < zero then InLine.~(tr(~n)) else tr n ! 1435: fun realfloor n = #2(fl n) ! 1436: fun floor n = Core.Assembly.A.floor n handle Integer.Overflow => raise Floor ! 1437: fun ceiling n : int = InLine.~(floor(~n)) ! 1438: end ! 1439: fun abs x = if x < zero then ~x else x ! 1440: local ! 1441: fun loop 0 = zero ! 1442: | loop n = let val x = two * loop(InLine.rshift(n,1)) ! 1443: in case InLine.andb(n,1) of 0 => x | 1 => x + one ! 1444: end ! 1445: in ! 1446: fun real n = if InLine.<(n,0) then ~(loop(InLine.~ n)) else loop n ! 1447: end ! 1448: fun makestring r = ! 1449: let val itoa = Integer.makestring ! 1450: fun scistr(a::b::tl,e) = ! 1451: let fun trail nil = "" ! 1452: | trail (0::tl) = ! 1453: let val rest = trail tl ! 1454: in case rest of "" => "" ! 1455: | _ => "0"^rest ! 1456: end ! 1457: | trail (hd::tl) = itoa hd ^ trail tl ! 1458: val rest = trail tl ! 1459: in itoa a ^ "." ^ itoa b ^ rest ^ "E" ^ itoa e ! 1460: end ! 1461: | scistr _ = "" (* prevents non-exhaustive match *) ! 1462: fun normstr(digits,e) = ! 1463: let fun n(nil,_) = "" ! 1464: | n(hd::nil,0) = itoa hd ^ ".0" ! 1465: | n(hd::tl,0) = itoa hd ^ "." ^ n(tl,~1) ! 1466: | n(0::tl,d) = ! 1467: let val rest = n(tl,InLine.-(d,1)) ! 1468: in case (InLine.<(d,~1),rest) of ! 1469: (true,"") => rest ! 1470: | _ => "0" ^ rest ! 1471: end ! 1472: | n(hd::tl,d) = itoa hd ^ n(tl,InLine.-(d,1)) ! 1473: fun header n = ! 1474: let fun zeros 1 = "" ! 1475: | zeros n = "0" ^ zeros(InLine.-(n,1)) ! 1476: in "0." ^ zeros n ! 1477: end ! 1478: in if InLine.<(e,0) ! 1479: then header(InLine.~ e) ^ n(digits,e) ! 1480: else n(digits,e) ! 1481: end ! 1482: fun mkdigits(f,0) = (nil,if f < five then 0 else 1) ! 1483: | mkdigits(f,i) = ! 1484: let val digit = floor f ! 1485: val new = ten * (f - real digit) ! 1486: val (digits,carry) = mkdigits(new,InLine.-(i,1)) ! 1487: val (digit,carry) = case (digit,carry) of ! 1488: (9,1) => (0,1) ! 1489: | _ => (InLine.+(digit,carry),0) ! 1490: in (digit::digits,carry) ! 1491: end ! 1492: (* should eventually speed this up by using log10 *) ! 1493: fun mkstr(f,e) = ! 1494: if f >= ten then mkstr(f/ten,InLine.+(e,1)) ! 1495: else if f < one then mkstr(f*ten,InLine.-(e,1)) ! 1496: else let val (digits,carry) = mkdigits(f,15) ! 1497: val (digits,e) = case carry of ! 1498: 0 => (digits,e) ! 1499: | _ => (1::digits,InLine.+(e,1)) ! 1500: in if InLine.>(e,~5) andalso InLine.<(e,15) ! 1501: then normstr(digits,e) ! 1502: else scistr(digits,e) ! 1503: end ! 1504: in if r < zero then "~" ^ mkstr(~r,0) ! 1505: else if InLine.feql(r,zero) then "0.0" ! 1506: else mkstr(r,0) ! 1507: end (* fun makestring *) ! 1508: local ! 1509: val pr = IO.output IO.std_out ! 1510: in ! 1511: fun print r = pr(makestring r) ! 1512: end ! 1513: end (* local *) ! 1514: end (* structure Real *) ! 1515: ! 1516: structure System = ! 1517: struct open System ! 1518: structure Unsafe = ! 1519: struct open Unsafe ! 1520: val cast : 'a -> 'b = InLine.cast ! 1521: val boxed : 'a -> bool = InLine.boxed ! 1522: val ordof : string * int -> int = InLine.ordof ! 1523: val slength : string -> int = InLine.slength ! 1524: val store : string * int * int -> unit = InLine.store ! 1525: val subscript : 'a array * int -> 'a = InLine.subscript ! 1526: val update : 'a array * int * 'a -> unit = InLine.update ! 1527: val delay : int * 'a -> 'a = InLine.delay ! 1528: val force : 'a -> 'a = InLine.force ! 1529: end ! 1530: end ! 1531: ! 1532: open Array Ref String IO Bool List Integer Real General ! 1533: ! 1534: val _ = IO.output IO.std_out "Initial done\n" ! 1535: ! 1536: end (* structure Initial *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.