![[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.