#lang plai-typed (require "typed-lang.rkt") (define (make-ids (n : number)) : (listof symbol) (build-list n (lambda (n) (string->symbol (string-append "var-" (to-string n)))))) ;; cascade-lets will build up the nested lets, and use body as the ;; eventual body, preserving order of evaluation of the expressions (define (cascade-lets (ids : (listof symbol)) (exprs : (listof ExprC)) (body : ExprC)) : ExprC (cond [(empty? ids) body] [(cons? ids) (LetC (first ids) (first exprs) (cascade-lets (rest ids) (rest exprs) body))])) ;; check-type builds an expression that checks the type of the expression ;; given as an argument (define (check-type (expr : ExprC) (type : string)) : ExprC (Prim2C '== (Prim1C 'tagof expr) (StrC type))) ;; and builds up an and expression from its two pieces (define (and (expr1 : ExprC) (expr2 : ExprC)) : ExprC (IfC expr1 expr2 (FalseC))) ;; and builds up an or expression from its two pieces (define (or (expr1 : ExprC) (expr2 : ExprC)) : ExprC (IfC expr1 (TrueC) (IfC expr2 (TrueC) (FalseC)))) ;; all builds up a series of ands over the expression arguments (define (all (exprs : (listof ExprC))) : ExprC (foldl (lambda (exp result) (and exp result)) (TrueC) exprs)) ;; all builds up a series of ors over the expression arguments (define (allors (exprs : (listof ExprC))) : ExprC (foldl (lambda (exp result) (or exp result)) (FalseC) exprs)) ;; map-subtract builds an expression that maps 'num- over a list of expressions (define (map-subtract (exprs : (listof ExprC))) : ExprC (foldl (lambda (expr result) (Prim2C 'num- result expr)) (first exprs) (rest exprs))) (define (desugar-subtract (args : (listof ExprP))) : ExprC (local ([define ids (make-ids (length args))] [define id-exps (map IdC ids)]) (cascade-lets ids (map desugar args) (IfC (all (map (lambda (e) (check-type e "number")) id-exps)) (map-subtract id-exps) (ErrorC (StrC "Bad arguments to -")))))) ;; desugar + helper functions (define (map-add (exprs : (listof ExprC))) : ExprC (foldl (lambda (expr result) (Prim2C 'num+ result expr)) (first exprs) (rest exprs))) (define (map-str-add (exprs : (listof ExprC))) : ExprC (foldl (lambda (expr result) (Prim2C 'string+ result expr)) (first exprs) (rest exprs))) ;; desugar + (define (desugar-add (args : (listof ExprP))) : ExprC (local ([define ids (make-ids (length args))] [define id-exps (map IdC ids)]) (cascade-lets ids (map desugar args) (IfC (all (map (lambda (e) (check-type e "number")) id-exps)) (map-add id-exps) (IfC (all (map (lambda (e) (check-type e "string")) id-exps)) (map-str-add id-exps) (ErrorC (StrC "Bad arguments to +"))))))) ;; desugar > operator (define (desugar-greater-than (args : (listof ExprP))) : ExprC (local ([define argsC (PtoC args)]) (if (= (length argsC) 1) (IfC (all (map (lambda (e) (check-type e "number")) argsC)) (Prim1C '> (first argsC)) (ErrorC (SeqC (StrC "Bad arguments for >:\n") (Prim1C 'print (first argsC))))) (IfC (all (map (lambda (e) (check-type e "number")) argsC)) (Prim2C '> (first argsC) (first (rest argsC))) (ErrorC (SeqC (StrC "Bad arguments for >:\n") (SeqC (ErrorC (first argsC)) (SeqC (StrC "\n") (ErrorC (first (rest argsC))))))))))) ;; desugar < operator (define (desugar-less-than (args : (listof ExprP))) : ExprC (local ([define argsC (PtoC args)]) (if (= (length argsC) 1) (IfC (all (map (lambda (e) (check-type e "number")) argsC)) (Prim1C '< (first argsC)) (ErrorC (SeqC (StrC "Bad arguments for >:\n") (Prim1C 'print (first argsC))))) (IfC (all (map (lambda (e) (check-type e "number")) argsC)) (Prim2C '< (first argsC) (first (rest argsC))) (ErrorC (SeqC (StrC "Bad arguments for >:\n") (SeqC (ErrorC (first argsC)) (SeqC (StrC "\n") (ErrorC (first (rest argsC))))))))))) ;; FieldP to FieldC (define (desugar-FieldP (arg : FieldP)) : FieldC (type-case FieldP arg [fieldP (name value) (fieldC name (desugar value))])) ;; (listof FieldP) -> (listof FieldC) (define (desugarLoFieldP (lofP : (listof FieldP))) : (listof FieldC) (if (empty? lofP) empty (cons (desugar-FieldP (first lofP)) (desugarLoFieldP (rest lofP))))) ;; (listof ExprP) -> (listof ExprC) (define (PtoC (lofP : (listof ExprP))) : (listof ExprC) (if (empty? lofP) empty (cons (desugar (first lofP)) (PtoC (rest lofP))))) ;; Helper for SeqP: (Listof ExprP) -> SeqC (define (loPtoSeqC (lofP : (listof ExprP))) : ExprC (if (= (length lofP) 2) (SeqC (desugar (first lofP)) (desugar (first (rest lofP)))) (SeqC (desugar (first lofP)) (loPtoSeqC (rest lofP))))) ;; Check if exp is equal to exp2 (define (check-expr (expr : ExprC) (expr2 : ExprC)) : ExprC (Prim2C '== expr expr2)) ;; Checks for object duplicates. (define (dupCheck (lofC : (listof ExprC))) : ExprC (if (empty? lofC) (FalseC) (or (allors (map (lambda (e) (check-expr e (first lofC))) lofC)) (dupCheck (rest lofC))))) (define (fieldsToExprC (lofF : (listof FieldP))) : (listof ExprC) (if (empty? lofF) empty (cons (fieldsToExprCHelper (first lofF)) (fieldsToExprC (rest lofF))))) (define (fieldsToExprCHelper (f : FieldP)) : ExprC (type-case FieldP f [fieldP (name value) (StrC name)])) (define (desugar (exprP : ExprP)) : ExprC (type-case ExprP exprP ;; Fill in more cases here... ;; All cases are organized in the same order they are organized in typed-lang.rkt ; [ObjectP (fields) (IfC (dupCheck (fieldsToExprC fields)) ; (ErrorC (StrC "Multiply-defined fields")) ; (ObjectC (desugarLoFieldP fields)))] [ObjectP (fields) (ObjectC (desugarLoFieldP fields))] [DotP (obj field) (GetFieldC (desugar obj) (IdC field))] [BracketP (o f) (GetFieldC (desugar o) (desugar f))] [DotMethodP (o f a) (LetC 'result (GetFieldC (desugar o) (IdC f)) (AppC (IdC 'result) (PtoC a)))] [BrackMethodP (o f a) (LetC 'result (GetFieldC (desugar o) (desugar f)) (AppC (IdC 'result) (PtoC a)))] [FuncP (args b) (FuncC args (desugar b))] [AppP (b args) (AppC (desugar b) (PtoC args))] [DefvarP (s b body) (LetC s (desugar b) (desugar body))] [DeffunP (name ids funbody body) (LetC name (FuncC ids (desugar funbody)) (desugar body))] [IdP (s) (IdC s)] [ForP (init test update body) (LetC 'init (desugar init) (IfC (desugar test) (LetC 'func (FuncC (list) (LetC 'body (desugar body) (LetC 'update (desugar update) (IfC (desugar test) (AppC (IdC 'func) (list)) (IdC 'body))))) (AppC (IdC 'func) (list))) (IdC 'init)))] [WhileP (test body) ;; dummy-fun will tell us it was called if we do so accidentally (local ([define dummy-fun (FuncC (list) (ErrorC (StrC "Dummy function")))]) (IfC (desugar test) ;; while-var will hold the actual function once we tie ;; everything together (LetC 'while-var dummy-fun (LetC 'while-func ;; this function does the real work - it runs the body of ;; the while loop, then re-runs it if the test is true, and ;; stops if its false (FuncC (list) (LetC 'temp-var (desugar body) (IfC (desugar test) (AppC (IdC 'while-var) (list)) (IdC 'temp-var)))) ;; The Set!C here makes sure that 'while-var will resolve ;; to the right value later, and the AppC kicks things off (SeqC (Set!C 'while-var (IdC 'while-func)) (AppC (IdC 'while-var) (list))))) (FalseC)))] [AssignP (lhs value) (type-case LHS lhs [BracketLHS (obj field) (SetFieldC (desugar obj) (desugar field) (desugar value))] [DotLHS (obj field) (SetFieldC (desugar obj) (IdC field) (desugar value))] [IdLHS (id) (Set!C id (desugar value))])] [SeqP (es) (loPtoSeqC es)] [IfP (cond then el) (IfC (desugar cond) (desugar then) (desugar el))] [NumP (n) (NumC n)] [StrP (n) (StrC n)] [TrueP () (TrueC)] [FalseP () (FalseC)] [PrimP (op args) (case op [(-) (cond [(= 0 (length args)) (ErrorC (StrC "Empty list for prim op"))] [(< 0 (length args)) (desugar-subtract args)])] [(+) (cond [(= 0 (length args)) (ErrorC (StrC "Empty list for prim op"))] [(< 0 (length args)) (desugar-add args)])] [(>) (cond [(= 0 (length args)) (ErrorC (StrC "Empty list for prim op"))] [(< 2 (length args)) (ErrorC (StrC "Bad primop"))] [(<= 0 (length args)) (desugar-greater-than args)])] [(<) (cond [(= 0 (length args)) (ErrorC (StrC "Empty list for prim op"))] [(< 2 (length args)) (ErrorC (StrC "Bad primop"))] [(<= 0 (length args)) (desugar-less-than args)])] [(print) (cond [(= 0 (length args)) (ErrorC (StrC "Empty list for prim op"))] [(> 1 (length args)) (ErrorC (StrC "Bad primop"))] [else (Prim1C 'print (desugar(first args)))])] [(==) (cond [(= 0 (length args)) (ErrorC (StrC "Empty list for prim op"))] [(< 2 (length args)) (ErrorC (StrC "Bad primop"))] [(= 2 (length args)) (Prim2C '== (desugar (first args)) (desugar (first (rest args))))] [(= 1 (length args)) (Prim1C '== (desugar (first args)) )])])] [PrimAssignP (op lhs value) (type-case LHS lhs [BracketLHS (obj field) (SetFieldC (desugar obj) (desugar field) (Prim2C op (GetFieldC (desugar obj) (desugar field)) (desugar value)))] [DotLHS (obj field) (SetFieldC (desugar obj) (IdC field) (Prim2C op (GetFieldC (desugar obj) (IdC field)) (desugar value)))] [IdLHS (id) (Set!C id (Prim2C op (IdC id) (desugar value)))])] [PreIncP (lhs) (LetC 'prev (IdC lhs) (SeqC (Set!C lhs (Prim2C '+ (IdC lhs) (NumC 1))) (IdC 'prev)))] [PostIncP (lhs) (SeqC (Set!C lhs (Prim2C '+ (IdC lhs) (NumC 1))) (IdC 'lhs))] [PreDecP (lhs) (LetC 'prev (IdC lhs) (SeqC (Set!C lhs (Prim2C '- (IdC lhs) (NumC 1))) (IdC 'prev)))] [PostDecP (lhs) (SeqC (Set!C lhs (Prim2C '- (IdC lhs) (NumC 1))) (IdC 'lhs))] ;[else (ErrorC (StrC (string-append "Haven't desugared a case yet:\n" ; (to-string exprP))))] ) )