(****************************************************************************** * SNU 4190.310 Programming Languages (Fall 2006) * * HW 3: K- interpreter II, K- programming, gift ******************************************************************************) (****************************************************************************** * Exercise 1. * K- Interpreter II ******************************************************************************) (* * Location *) signature LOC = sig (* * Base Address *) structure Base : sig (* type of bass address *) type t (* NULL *) val null : t (* successor *) val succ : t -> t (* equal b1 b2 tests equality of b1 and b2 *) val equal : t -> t -> bool end (* type of location *) type t = Base.t * tyoffset and tyoffset = int exception Not_allowed (* loc_of_base b returns the first (offset 0) location of b *) val loc_of_base : Base.t -> t (* base l returns the base address of l. *) val base : t -> Base.t (* offset l return the offset of l. *) val offset : t -> int (* addi l i adds i to the offset of l. *) val addi : t -> int -> t (* subi l i subtracts i from the offset of l. *) val subi : t -> int -> t (* sub x y returns (offset x) - (offset y), or raises Not_allowed if they have different base addresses. *) val sub : t -> t -> tyoffset (* equal l r tests equality of l and r, or raises Not_allowed if they have different base addresses. *) val equal : t -> t -> bool (* less l r returns (offset l) < (offset r), or raises Not_allowed if they have different base addresses. *) val less : t -> t -> bool end structure Loc : LOC = struct structure Base = struct type t = int val null = 0 fun succ b = if b < max_int then b + 1 else invalid_arg "out_of_bases" fun equal l r = (l = r) end type t = Base.t * tyoffset and tyoffset = int exception Not_allowed fun loc_of_base base = (base, 0) fun base (base, _) = base fun offset (_, offset) = offset fun addi (base, offset) n = (base, offset + n) fun subi (base, offset) n = (base, offset - n) fun sub (base, offset) (base', offset') = if Base.equal base base' then offset - offset' else raise Not_allowed fun equal (base, offset) (base', offset') = (Base.equal base base') && (offset = offset') fun less (base, offset) (base', offset') = if Base.equal base base' then offset < offset' else raise Not_allowed end (* * Memory *) signature MEM = sig (* type of memory from Loc.t to 'a *) type 'a t exception Not_allocated (* empty memory *) val empty : 'a t (* allocate s m returns an Loc.t to a fresh (uninitialized) buffer of size s and a memory containing the same bindings as m, plus a binding of the Loc.t to the first location of allocated buffer. *) val allocate : int -> 'a t -> Loc.t * 'a t (* deallocate l s m returns a memory containing the same bindings as m, except for l, ..., l + (s - 1) are deallocated in the returned memory, or raises Not_allocated if m doesn't contain a binding for some of l, ..., l + (s - 1). *) val deallocate : Loc.t -> int -> 'a t -> 'a t (* store l v m returns a memory containing the same bindings as m, with l bound to v, or raises Not_allocated if m doesn't contain a binding for l. *) val store : Loc.t -> 'a -> 'a t -> 'a t (* fetch l m returns the current binding of l in m, or raises Not_found if no such binding exists. *) val fetch : Loc.t -> 'a t -> 'a option (* is_allocated l m returns true if m contains a binding for l, and false otherwise. *) val is_allocated : Loc.t -> 'a t -> bool (* return the size (number of locations) of the given memory. *) val size : 'a t -> int end structure Mem : MEM = struct fun range f t = if f < t then f :: (range (f + 1) t) else [] type 'a t = Loc.Base.t * int * (Loc.t, 'a option) Map.t exception Not_allocated val empty = (Loc.Base.null, 0, Map.empty) fun allocate s (base, size, mem) = let val base' = Loc.Base.succ base val l = Loc.loc_of_base base' in (l, (base', size + s, List.fold_left (fn m o => Map.add (Loc.addi l o) None m) mem (range 0 s))) end fun is_allocated l (_, _, mem) = Map.mem l mem fun deallocate l s (base, size, mem) = (base, size - s, List.fold_left (fn m o => let val l' = Loc.addi l o in if is_allocated l' (base, size - o, m) then Map.remove l' m else raise Not_allocated end) mem (range 0 s)) fun store l v (m as (base, size, mem)) = if is_allocated l m then (base, size, Map.add l (Some v) mem) else raise Not_allocated fun fetch l (_, _, mem) = (Map.find l mem) handle Not_found => raise Not_allocated fun size (_, s, _) = s end (* * Environment *) signature ENV = sig (* type of environment from 'a to 'b *) type ('a, 'b) t exception Not_bound (* empty environment *) val empty : ('a, 'b) t (* bind x l e returns an environment containing the same bindings as e, plus a binding of x to l. If x was already bound in e, its previous binding disappears. *) val bind : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t (* lookup x e returns the current binding of x in e, or raises Not_bound if no such binding exists. *) val lookup : 'a -> ('a, 'b) t -> 'b (* is_bound x e returns true if e contains a binding for x, and false otherwise. *) val is_bound : 'a -> ('a, 'b) t -> bool (* fold f e a computes (f xN lN ... (f x1 lN a) ...), where x1 ... xN are the keys of all bindings in m, and l1 ... lN are the associated data. The order in which the bindings are presented to f is unspecified. *) val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c end structure Env : ENV = struct type ('a, 'b) t = ('a, 'b) Map.t exception Not_bound val empty = Map.empty fun bind x a e = Map.add x a e fun lookup x e = (Map.find x e) handle Not_found => raise Not_bound fun is_bound x e = Map.mem x e fun fold f e a = Map.fold f e a end (* * K- Interpreter *) signature KMINUS = sig exception Error of string type id = string type exp = NUM of int | TRUE | FALSE | UNIT | VAR of id | ADD of exp * exp | SUB of exp * exp | MUL of exp * exp | DIV of exp * exp | EQUAL of exp * exp | LESS of exp * exp | NOT of exp | ASSIGNV of id * exp (* assgin to variable *) | ASSIGNF of exp * id * exp (* assign to record field *) | ASSIGNG of exp * exp (* generic assign *) | SEQ of exp * exp (* sequence *) | IF2 of exp * exp * exp (* if-then-else *) | IF1 of exp * exp (* if-then *) | WHILE of exp * exp (* while loop *) | FOR of id * exp * exp * exp (* for loop *) | LETV of id * exp * exp (* variable binding *) | LETF of id * id * exp * exp (* procedure binding *) | CALLV of id * exp (* call by value *) | CALLR of id * id (* call by referenece *) | RECORD of (id * exp) list (* record construction *) | FIELD of exp * id (* record field selection *) | MALLOC of exp (* malloc *) | AMPER of id (* &x *) | STAR of exp (* *E *) | READ of id | WRITE of exp type program = exp type memory type env type value val emptyMemory : memory val emptyEnv : env val run : memory * env * program -> value end structure K : KMINUS = struct exception Error of string type id = string type exp = NUM of int | TRUE | FALSE | UNIT | VAR of id | ADD of exp * exp | SUB of exp * exp | MUL of exp * exp | DIV of exp * exp | EQUAL of exp * exp | LESS of exp * exp | NOT of exp | ASSIGNV of id * exp | ASSIGNF of exp * id * exp | ASSIGNG of exp * exp | SEQ of exp * exp | IF2 of exp * exp * exp | IF1 of exp * exp | WHILE of exp * exp | FOR of id * exp * exp * exp | LETV of id * exp * exp | LETF of id * id * exp * exp | CALLV of id * exp | CALLR of id * id | RECORD of (id * exp) list | FIELD of exp * id | MALLOC of exp | AMPER of id | STAR of exp | READ of id | WRITE of exp type program = exp (* * Record *) structure Rec : sig type t val create : (id * Loc.t) list -> t val get : id -> t -> Loc.t val set : id -> Loc.t -> t -> t val equal : t -> t -> bool end = struct type t = (id * Loc.t) list fun create r = List.sort (fn (id, _) (id', _) => compare id id') r fun get id r = (List.assoc id r) handle Not_found => raise (Error "Not_found") fun set id l r = ((id, l) :: (List.remove_assoc id r)) handle Not_found => raise (Error "Not_found") fun equal r r' = List.for_all2 (fn (id, l) (id', l') => (id = id') && (Loc.equal l l')) r r' end type value = Num of int | Bool of bool | Record of Rec.t | Location of Loc.t | Unit | Bot fun value_int Num n = n | value_int Bool _ = raise (Error "Bool type is used as Num type") | value_int Location _ = raise (Error "Location type is used as Num type") | value_int Record _ = raise (Error "Record type is used as Num type") | value_int Unit = raise (Error "Unit type is used as Num type") | value_int Bot = raise (Error "not initialized") fun value_bool Bool b = b | value_bool Num _ = raise (Error "Num type is used as Bool type") | value_bool Location _ = raise (Error "Location type is used as Bool type") | value_bool Record _ = raise (Error "Record type is used as Bool type") | value_bool Unit = raise (Error "Unit type is used as Bool type") | value_bool Bot = raise (Error "not initialized") fun value_loc Location l = l | value_loc Num _ = raise (Error "Num type is used as Location type") | value_loc Bool _ = raise (Error "Bool type is used as Location type") | value_loc Record _ = raise (Error "Record type is used as Location type") | value_loc Unit = raise (Error "Unit type is used as Location type") | value_loc Bot = raise (Error "not initialized") fun value_rec Record r = r | value_rec Num _ = raise (Error "Num type is used as Record type") | value_rec Bool _ = raise (Error "Bool type is used as Record type") | value_rec Location _ = raise (Error "Location type is used as Record type") | value_rec Unit = raise (Error "Unit type is used as Record type") | value_rec Bot = raise (Error "not initialized") fun value_unit Unit = () | value_unit Num _ = raise (Error "Num type is used as Unit type") | value_unit Bool _ = raise (Error "Bool type is used as Unit type") | value_unit Location _ = raise (Error "Location type is used as Unit type") | value_unit Record _ = raise (Error "Record type is used as Unit type") | value_unit Bot = raise (Error "not initialized") (* memory *) type memory = value Mem.t val emptyMemory = Mem.empty (* environment *) type env = (id, env_entry) Env.t and env_entry = Addr of Loc.t | Proc of id * exp * env val emptyEnv = Env.empty fun env_loc x e = (case Env.lookup x e of Addr l => l | Proc _ => raise (Error "not allowed")) handle Env.Not_bound => raise (Error "not bound") fun env_proc f e = (case Env.lookup f e of Addr _ => raise (Error "not allowed") | Proc p => p) handle Env.Not_bound => raise (Error "not bound") fun run (mem, environ, pgm) = let fun arithmetic env m op e1 e2 = let val (n1, m1) = eval env m e1 val l = value_int n1 val (n2, m2) = eval env m1 e2 val r = value_int n2 in (Num (op l r), m2) end (* NUM *) and eval env m (NUM n) = (Num n, m) (* TRUE *) | eval env m TRUE = (Bool True, m) (* FALSE *) | eval env m FALSE = (Bool False, m) (* UNIT *) | eval env m UNIT = (Unit, m) (* VAR *) | eval env m (VAR x) = (case Mem.fetch (env_loc x env) m of Some v => v | None => Bot, m) (* ADD *) | eval env m (ADD (e1, e2)) = let val (l, m1) = eval env m e1 in case l of Num lv => let val (r, m2) = eval env m1 e2 in case r of Num rv => (Num (lv + rv), m2) (* n + n *) | Location rv => (Location (Loc.addi rv lv), m2) (* n + l *) | Bot => raise (Error "not initialized") | _ => raise (Error "not allowed") end | Location lv => let val (r, m2) = eval env m1 e2 in (Location (Loc.addi lv (value_int r)), m2) (* l + n *) end | Bot => raise (Error "not initialized") | _ => raise (Error "not allowed") end (* SUB *) | eval env m (SUB (e1, e2)) = let val (l, m1) = eval env m e1 in case l of Num lv => let val (r, m2) = eval env m1 e2 in (Num (lv - (value_int r)), m2) (* n - n *) end | Location lv => let val (r, m2) = eval env m1 e2 in case r of Num rv => (Location (Loc.subi lv rv), m2) (* l - n *) | Location rv => (Num (Loc.sub lv rv), m2) (* l - l *) | Bot => raise (Error "not initialized") | _ => raise (Error "not allowed") end | Bot => raise (Error "not initialized") | _ => raise (Error "not allowed") end (* MUL *) | eval env m (MUL (e1, e2)) = arithmetic env m ( * ) e1 e2 (* DIV *) | eval env m (DIV (e1, e2)) = ( (arithmetic env m ( / ) e1 e2) handle Division_by_zero => raise (Error "Division_by_zero") ) (* EQUAL *) | eval env m (EQUAL (e1, e2)) = let val (l, m1) = eval env m e1 in case l of Num lv => let val (r, m2) = eval env m1 e2 in (Bool (lv = (value_int r)), m2) (* n = n *) end | Bool lv => let val (r, m2) = eval env m1 e2 in (Bool (lv = (value_bool r)), m2) (* b = b *) end | Location lv => let val (r, m2) = eval env m1 e2 in (Bool (Loc.equal lv (value_loc r)), m2) (* l = l *) end | Record lv => let val (r, m2) = eval env m1 e2 in (Bool (Rec.equal lv (value_rec r)), m2) (* r = r *) end | Unit => let val (r, m2) = eval env m1 e2 in (Bool (() = (value_unit r)), m2) (* () = () *) end | Bot => raise (Error "not initialized") end (* LESS *) | eval env m (LESS (e1, e2)) = let val (l, m1) = eval env m e1 in case l of Num lv => let val (r, m2) = eval env m1 e2 in (Bool (lv < (value_int r)), m2) (* n < n *) end | Location lv => let val (r, m2) = eval env m1 e2 in (Bool (Loc.less lv (value_loc r)), m2) (* l < l *) end | Unit => let val (r, m2) = eval env m1 e2 in (Bool (() < (value_unit r)), m2) (* () < () *) end | Bot => raise (Error "not initialized") | _ => raise (Error "not allowed") end (* NOT *) | eval env m (NOT e) = let val (b, m1) = eval env m e in (Bool (not (value_bool b)), m1) end (* ASSIGNV *) | eval env m (ASSIGNV (x, e)) = let val l = env_loc x env val (v, m1) = eval env m e in (Unit, Mem.store l v m1) end (* ASSIGNF *) | eval env m (ASSIGNF (e1, x, e2)) = let val (r, m1) = eval env m e1 val l = Rec.get x (value_rec r) val (v, m2) = eval env m1 e2 in (Unit, Mem.store l v m2) end (* ASSIGNG *) | eval env m (ASSIGNG (e1, e2)) = let val (l, m1) = eval env m e1 val lv = value_loc l val _ = Mem.fetch lv m val (v, m2) = eval env m1 e2 in (Unit, Mem.store lv v m2) end (* SEQ *) | eval env m (SEQ (e1, e2)) = eval env (snd (eval env m e1)) e2 (* IF2 *) | eval env m (IF2 (e1, e2, e3)) = let val (b, m1) = eval env m e1 in (Unit, if value_bool b then snd (eval env m1 e2) else snd (eval env m1 e3)) end (* IF1 *) | eval env m (IF1 (e1, e2)) = let val (b, m1) = eval env m e1 in (Unit, if value_bool b then snd (eval env m1 e2) else m1) end (* WHILE *) | eval env m (w as (WHILE (e1, e2))) = let val (b, m1) = eval env m e1 in if value_bool b then eval env m1 (SEQ (e2, w)) else (Unit, m1) end (* FOR *) | eval env m (FOR (x, e1, e2, e3)) = let val l = env_loc x env val (v1, m1) = eval env m e1 val n1 = value_int v1 val (v2, m2) = eval env m1 e2 val n2 = value_int v2 in if n1 <= n2 then eval env (snd (eval env (Mem.store l v1 m2) e3)) (FOR (x, NUM (n1 + 1), e2, e3)) else (Unit, (Mem.store l v1 m2)) end (* LETV *) | eval env m (LETV (x, e1, e2)) = let val (v1, m1) = eval env m e1 val (l, m1') = Mem.allocate 1 m1 in eval (Env.bind x (Addr l) env) (Mem.store l v1 m1') e2 end (* LETF *) | eval env m (LETF (f, x, e1, e2)) = eval (Env.bind f (Proc (x, e1, env)) env) m e2 (* CALLV *) | eval env m (CALLV (f, e)) = let val (x, e1, env1) = env_proc f env val (v1, m1) = eval env m e val (l, m1') = Mem.allocate 1 m1 in eval (Env.bind f (Proc (x, e1, env1)) (Env.bind x (Addr l) env1)) (Mem.store l v1 m1') e1 end (* CALLR *) | eval env m (CALLR (f, x)) = let val (y, e1, env1) = env_proc f env in eval (Env.bind f (Proc (y, e1, env1)) (Env.bind y (Env.lookup x env) env1)) m e1 end (* RECORD *) | eval env m (RECORD [(x, e1), (y, e2)]) = let val (v1, m1) = eval env m e1 val (v2, m2) = eval env m1 e2 val (l1, m2') = Mem.allocate 2 m2 val l2 = Loc.addi l1 1 in (Record (Rec.create [(x, l1), (y, l2)]), Mem.store l2 v2 (Mem.store l1 v1 m2')) end | eval env m (RECORD _) = invalid_arg "eval RECORD" (* FIELD *) | eval env m (FIELD (e, x)) = let val (r, m1) = eval env m e val rv = value_rec r in (case Mem.fetch (Rec.get x rv) m1 of Some v => v | None => Bot, m1) end (* MALLOC *) | eval env m (MALLOC e) = let val (n, m1) = eval env m e val nv = value_int n val (l, m1') = Mem.allocate nv m1 in (Location l, m1') end (* AMPER *) | eval env m (AMPER x) = (Location (env_loc x env), m) (* STAR *) | eval env m (STAR e) = let val (l, m1) = eval env m e val lv = value_loc l in (case Mem.fetch lv m1 of Some v => v | None => Bot, m1) end (* READ *) | eval env m (READ x) = ( (Unit, Mem.store (env_loc x env) (Num (read_int ())) m) handle Failure "int_of_string" => raise (Error "int_of_string") ) (* WRITE *) | eval env m (WRITE e) = let val (n, m1) = eval env m e val () = print_int (value_int n) ; print_newline () in (Unit, m1) end in fst (eval environ mem pgm) end end /****************************************************************************** * Exercise 2. * K- programming ******************************************************************************/ /* * <변수 설명> * emptyStack : 빈 스택으로 레코드 타입이다. * top으로 push 및 pop이 된다. * Q : 큐 타입 정의. 두 개의 emptyStack을 갖는 레코드로써 레코드 필드는 L과 R이다. * emptyQ : Q 타입의 빈 큐 * * * ltor(que): 인자로 큐 que를 넣으면 que의 L 스택을 뒤집어서 R 스택으로 옮긴다. * 결과값(리턴값)은 바뀐 L과 R을 필드로 갖는 레코드 타입의 큐이다. * * enQ(pair): 큐와 정수를 필드값으로 하는 레코드를 받으면 정수를 큐에 넣는다. * 결과값은 정수가 들어간 큐이다. * * deQ(que): 큐를 받으면 큐의 맨 앞의 정수를 빼서 {정수, 정수 뺀 큐}를 리턴한다. * * <에러 설명> * deQ할 때 444가 두 번 연속 찍히면 : queue가 비어있다는 에러. **/ let emptyStack := {top := unit, bot := unit} in /* ltor: que:{L, R} -> {L, R} */ let procedure ltor(que) = let ls := que.L in let rs := que.R in let result := unit in if ls = emptyStack then result := {L := ls, R := rs} else result := call ltor({L := ls.bot, R := {top := ls.top, bot := rs}}) end; result end end end in let /* Q: {L:emptyStack, R:emptyStack} */ Q := {L := emptyStack, R := emptyStack} in let /* enQ: {Q, int} -> Q */ procedure enQ(pair) = let que := pair.queue in {L := {top := pair.num, bot := que.L}, R := que.R} end in let /* deQ: Q -> {int, Q} */ procedure deQ(que) = let ls := que.L in let rs := que.R in if rs = emptyStack then (if ls = emptyStack then (write 444; write 444) else que := call ltor(que); ls := que.L; rs := que.R end) end; {num := rs.top, queue := {L := ls, R := rs.bot}} end end in let emptyQ := Q in emptyQ /*************/ /* TEST CODE */ /*************/ /* 주석처리함 let rlt := 0 in rlt := call enQ({queue := emptyQ, num := 1}); rlt := call enQ({queue := rlt, num := 2}); rlt := call deQ(rlt); write (rlt.num); rlt := call enQ({queue := rlt.queue, num := 10}); rlt := call deQ(rlt); write (rlt.num); rlt := call deQ(rlt.queue); write (rlt.num) end */ end end end end end end (****************************************************************************** * Exercise 3. * gift ******************************************************************************) type require = id * (cond list) and cond = Items of gift list | Same of id | Common of cond * cond | Except of cond * gift list and gift = int and giftset = gift Set.t and id = A | B | C | D | E val lfold = List.fold_right fun fixpoint f x = if f x = x then x else fixpoint f (f x) val rec getGifts : cond -> (id, giftset) Map.t -> giftset =fn c m => case c of Items gifts => lfold Set.add gifts Set.empty |Same id => Map.find id m |Common (c1,c2) => Set.inter (getGifts c1 m) (getGifts c2 m) |Except (c,gifts) => lfold Set.remove gifts (getGifts c m) val add : (require list * (id, giftset) Map.t) -> (require list * (id, giftset) Map.t) =fn (reqs, m) => lfold (fn (id, conds) (r,m) => let val gifts = (fn cs m => lfold (fn c s => Set.union (getGifts c m) s) cs Set.empty) conds m val gifts' = Set.union gifts (Map.find id m) in (r, Map.add id gifts' m) end) reqs (reqs, m) val shoppingList : require list -> (id * gift list) list =fn reqs => let val m = lfold (fn id map => Map.add id Set.empty map) [A,B,C,D,E] Map.empty val (_,m') = fixpoint add (reqs, m) in Map.fold (fn id set l => (id, Set.elements set)::l) m' [] end