(* Aufgabe 14.1 *) datatype 'a state = Nil | N of 'a * 'a state ref type 'a ilist = 'a state ref fun ilist () = ref Nil fun cons x xr = ref(N(x, xr)) fun circle' n xs = if n<1 then xs else circle' (n-1) (cons n xs) fun circle n = let val xs = ilist() in xs := !(circle' n xs) ; xs end fun empty (ref(Nil)) = true | empty _ = false fun tail (ref(N(_, xr))) = xr | tail _ = raise Empty fun sizeR' rs r = if empty r then 1 + length rs else if List.exists (fn r' => r'=r) rs then length rs else sizeR' (r::rs) (tail r) fun sizeR xs = sizeR' nil xs fun sizeN' ns r = if empty r then length ns else if List.exists (fn n' => n'=(!r)) ns then length ns else sizeN' ((!r)::ns) (tail r) fun sizeN xs = sizeN' nil xs (* Aufgabe 14.2 *) type index = int type noi = int (* number of instructions *) type noa = int (* number of arguments *) type ca = int (* code address *) datatype instruction = con of int | add (* addition *) | sub (* substraction *) | mul (* multiplication *) | leq (* less or equal test *) | branch of noi (* unconditional branch *) | cbranch of noi (* conditional branch *) | getS of index (* push value from stack *) | putS of index (* update value in stack *) | halt (* halt machine *) | proc of noa * noi (* begin of procedure code *) | getF of index (* push value from frame *) | call of ca (* call procedure *) | return (* return from procedure call *) | callR of ca (* call procedure and return *) type code = instruction list fun gcdi (x0, y0) = let val x = ref x0 val y = ref y0 in while !x <> !y do if !x <= !y then y:= !y - !x else x:= !x - !y ; !x end val vm_gcd = [getS 1, getS 0, sub, cbranch 15, getS 1, getS 0, leq, cbranch 6, getS 0, getS 1, sub, putS 1, branch ~12, getS 1, getS 0, sub, putS 0, branch ~17] (* Aufgabe 14.3 *) exception Error datatype exp = Con of int (* constant *) | Add of exp * exp (* addition *) | Sub of exp * exp (* subtraction *) | Mul of exp * exp (* multiplication *) fun compile'(Con i) = [con i] | compile'(Add(e1,e2)) = compile' e2 @ compile' e1 @ [add] | compile'(Sub(e1,e2)) = compile' e2 @ compile' e1 @ [sub] | compile'(Mul(e1,e2)) = compile' e2 @ compile' e1 @ [mul] fun compile e = compile' e @ [halt] fun decompile' (con n::is, es) = decompile'(is, Con n::es) | decompile' (add::is, e::e'::es) = decompile'(is, Add(e,e')::es) | decompile' (sub::is, e::e'::es) = decompile'(is, Sub(e,e')::es) | decompile' (mul::is, e::e'::es) = decompile'(is, Mul(e,e')::es) | decompile' ([halt], [e]) = e | decompile' _ = raise Error fun decompile code = decompile'(code,nil) (* Aufgabe 14.5 *) val vm_fibi' = [proc(1,17), con 1, getF ~1, leq, cbranch 3, getF ~1, return, con 1, getF ~1, sub, call 0, con 2, getF ~1, sub, call 0, add, return] val vm_fibi = [proc(3,15), con 0, getF ~1, leq, cbranch 3, getF ~2, return, getF ~3, getF ~2, add, getF ~3, con 1, getF ~1, sub, callR 0, proc(1,5), con 1, con 0, getF ~1, callR 0] (* Aufgabe 14.6 *) val vm_oddeven = [proc(1,9), getF ~1, cbranch 5, con 1, getF ~1, sub, callR 9, con 1, return, proc(1,9), getF ~1, cbranch 5, con 1, getF ~1, sub, callR 0, con 0, return] (* Aufgabe 14.7 *) (* (* Expressions *) exp = asexp ["<=" asexp] asexp = mulexp asexp' asexp' = [("+" | "-") mulexp asexp'] mulexp = atexp mulexp' mulexp' = ["*" atexp mulexp'] atexp = identifier | integer | "(" exp ")" (* Statements *) stmt = identifier ":=" exp | "if" exp "then" stmt else stmt | "while" exp "do" stmts "end" stmts = stmt stmts' stmts' = [";" stmt stmts'] (* Declarations *) decl = "var" identifier ":=" exp decls = [decl decls] (* Program *) prog = decls stmt "return" exp *) datatype token = LEQ | ASSIGN | ADD | SUB | MUL | COLON | SEMICOLON | LPAR | RPAR | ICON of int | VAR | IF | THEN | ELSE | WHILE | DO | END | RETURN | ID of string val ord0 = ord #"0" fun lex ts nil = rev ts | lex ts (#" " ::cr) = lex ts cr | lex ts (#"\n"::cr) = lex ts cr | lex ts (#"\t"::cr) = lex ts cr | lex ts (#"<" :: #"=" ::cr) = lex (LEQ::ts) cr | lex ts (#":" :: #"=" ::cr) = lex (ASSIGN::ts) cr | lex ts (#"+" ::cr) = lex (ADD::ts) cr | lex ts (#"-" ::cr) = lex (SUB::ts) cr | lex ts (#"*" ::cr) = lex (MUL::ts) cr | lex ts (#":" ::cr) = lex (COLON::ts) cr | lex ts (#";" ::cr) = lex (SEMICOLON::ts) cr | lex ts (#"(" ::cr) = lex (LPAR::ts) cr | lex ts (#")" ::cr) = lex (RPAR::ts) cr | lex ts (#"~" ::c::cr) = if Char.isDigit c then lexN ts ~1 0 (c::cr) else raise Error | lex ts (c::cr) = if Char.isDigit c then lexN ts 1 0 (c::cr) else if Char.isAlpha c then lexA ts [c] cr else raise Error and lexN ts s n cs = if not(null cs) andalso Char.isDigit(hd cs) then lexN ts s (10*n + (ord(hd cs) - ord0)) (tl cs) else lex (ICON(s*n)::ts) cs and lexA ts xs cs = if not(null cs) andalso Char.isAlphaNum(hd cs) then lexA ts (hd cs::xs) (tl cs) else lex (lexA'(implode(rev xs))::ts) cs and lexA' "if" = IF | lexA' "then" = THEN | lexA' "else" = ELSE | lexA' "while" = WHILE | lexA' "do" = DO | lexA' "end" = END | lexA' "var" = VAR | lexA' "return" = RETURN | lexA' x = ID x type id = string datatype exp = Con of int | Var of id | Add of exp * exp | Sub of exp * exp | Mul of exp * exp | Leq of exp * exp datatype sta = Assign of id * exp | If of exp * sta * sta | While of exp * sta | Seq of sta list type declaration = id * exp type program = declaration list * sta * exp fun match (a,ts) t = if null ts orelse hd ts <> t then raise Error else (a, tl ts) fun combine a ts p f = let val (a',tr) = p ts in (f(a,a'), tr) end fun exp ts = case asexp ts of (a, LEQ::tr) => combine a tr asexp Leq | ats => ats and asexp ts = asexp' (mulexp ts) and asexp'(a, ADD::ts) = asexp'(combine a ts mulexp Add) | asexp'(a, SUB::ts) = asexp'(combine a ts mulexp Sub) | asexp' ats = ats and mulexp ts = mulexp'(atexp ts) and mulexp'(a, MUL::ts) = mulexp'(combine a ts atexp Mul) | mulexp' ats = ats and atexp ((ICON n)::ts) = (Con n, ts) | atexp (ID s ::ts) = (Var s, ts) | atexp (LPAR ::ts) = match (exp ts) RPAR | atexp ts = raise Error and stmt ((ID s)::ASSIGN::ts) = (case exp ts of (e, tr) => (Assign(s, e), tr)) | stmt (IF ::ts) = let val (e1, ts1) = match (exp ts) THEN val (e2, ts2) = match (stmt ts1) ELSE val (e3, ts3) = stmt ts2 in (If(e1, e2, e3), ts3) end | stmt (WHILE ::ts) = let val (e1, ts1) = match (exp ts) DO val (e2, ts2) = match (stmts ts1) END in (While(e1, e2), ts2) end | stmt ts = raise Error and stmts ts = (case stmt ts of (s, SEMICOLON::tr) => combine s tr stmts' (fn (s, ts) => Seq (s::ts)) | sts => sts) and stmts' ts = (case stmt ts of (s, SEMICOLON::tr) => combine s tr stmts' (fn (s, ts) => s::ts) | (s,tr) => ([s], tr)) and decls ds (VAR::(ID s)::ASSIGN::tr) = let val (e, ts) = exp tr in decls ((s, e)::ds) ts end | decls ds ts = (rev ds, ts) and parse ts = let val (ds, tr) = decls nil ts val (s, tr) = match (stmt tr) RETURN val (e, tr) = exp tr in (case tr of nil => (ds, s, e) | _ => raise Error) end