Merge pull request #20 from metamorph-scheme/TL/semanalfix

some fixes maybe?

src/CodeGeneration/CodeGeneration.hs

@@ -98,7 +98,7 @@ renderExpression = renderExpression'
   where
     renderExpression' (Function (ResolvedPath num)) = "FUNCTION(" ++ show num ++ ")"
     --renderExpression' (Bound parent num) = "BOUND(" ++ show parent ++ "," ++ show num ++ ")"
-    renderExpression' (Lambda variadic (ResolvedPath num) pnum) = "PUSH_LITERAL(" ++ if variadic then "LAMBDA_VARIADIC" else "LAMBDA" ++ "(" ++ show num ++ "," ++ show pnum ++ "))"
+    renderExpression' (Lambda variadic (ResolvedPath num) pnum) = "PUSH_LITERAL(" ++ (if variadic then "LAMBDA_VARIADIC" else "LAMBDA") ++ "(" ++ show num ++ "," ++ show pnum ++ "))"
     renderExpression' (Continuation (ResolvedPath num)) = "PUSH_LITERAL(CONTINUATION(" ++ show num ++ "))"
     --renderExpression' (GlobalBound num) = "GLOBAL_BOUND(" ++ show num ++ ")"
     renderExpression' (Return) = "RETURN"
@@ -127,13 +127,13 @@ generateCode :: Path -> MetaNode'-> Program
 generateCode n (ApplicationNode' _ (BaseFunctionAtom' "call/cc") [expr]) = 
     combinePrograms [
       staticProgram [Continuation n],
-      generateCode n expr,
+      generateCode (appendPath 0 n) expr,
       staticProgram [Applicate 1 n]
     ]
 generateCode n (ApplicationNode' _ (BaseFunctionAtom' "call-with-current-continuation") [expr]) = 
     combinePrograms [
       staticProgram [Continuation n],
-      generateCode n expr,
+      generateCode (appendPath 0 n) expr,
       staticProgram [Applicate 1 n]
     ]
 generateCode n (ApplicationNode' False expr params) = 

src/SemanticAnalysis/SemanticAnalysis.hs

@@ -141,7 +141,7 @@ annotateLambda (LambdaNode params variadic exprs) = do
     pushActivationEntries names
     body' <- annotateBody exprs' True
     popEntries
-    if (\(IdentifierAtom str 0) -> null str) variadic then
+    if (\(IdentifierAtom str _) -> null str) variadic then
         return $ LambdaNode' (length params) False  body'
     else
         return $ LambdaNode' (length params) True body'

testdata/continuation.scm

@@ -0,0 +1,3 @@
+(define cont)
+(define x 0)
+(define (func) (call/cc (lambda (k) (set! cont  k))) (if (= x 100)  ))

testdata/example.scm

@@ -8,11 +8,13 @@
     (if (> n 0) 
         (* n (fac (- n 1)))
         ident))
-(define (q x . y) (append x y))
-(define (test x y . z) (cons (+ x y) z))
-(define n_list `(Hallo ich bin eine Liste ,(* 2 (fac 7))))
-(test 1 4 3 5 1 "String")
-(set! test fac)
-(test 2)
+;(define (q x . y) (append x y))
+;(define (test1 x y . z) (cons (+ x y) z))
+;(define n_list `(Hallo ich bin eine Liste ,(* 2 (fac 7))))
+;(test1 1 4 3 5 1 "String")
+;(set! test1 fac)
+;(test1 2)
 (define cond)
-(if (= cond #t) (* 1 1))
+(if cond (* 1 1))
+;
+;(define (append ls x) (if (= cdr '()) (set-cdr! ls (cons x '())) (append (cdr ls) x)))

testdata/exp.scm

@@ -0,0 +1,10 @@
+(define (plus x y) (+ x y))
+(define (myMap f l1 l2) (if (or  (null? l1) (null? l2)) '() (cons (f (car l1) (car l2)) ( myMap f (cdr l1) (cdr l2)))))
+(define g (myMap plus '(1 2 3 4) '(1 2 3 4)))
+(write-string  (number->string (car g)))
+(newline)
+
+(define (print-numbers ls) (if (null? ls) #f ((lambda () (write-string (number->string (car ls)))  (print-numbers (cdr ls))))))
+
+(print-numbers g)
+(newline)

testdata/nTimes.scheme

@@ -0,0 +1,17 @@
+(define continuation)
+(define counter 0)
+
+(define (nTimes times func x)
+    (set! counter (+ counter 1))
+    (if (> times 0)
+        (nTimes (- times 1) func (func x))
+        x))
+
+(define (pow2AndStore8 x)
+    (let 
+        ( (maybeNum (call/cc (lambda (c) (if (= x 8) (set! continuation c))))) )
+        (if (number? maybeNum) maybeNum (* 2 x))))
+
+(write-string (number->string (nTimes 5 pow2AndStore8 1)))
+(newline)
+(if (= counter 6) (write-string (number->string (continuation 5))))

testdata/weird.scm

@@ -1,4 +1,5 @@
 (define outer #t)
+(define (od? n) #t)
 (let-syntax
   ((hansi (syntax-rules ()
-      ((_ x y z) (and outer (let-syntax ((z (syntax-rules () ((_ a) (odd? a))))) (y (z x)))))))) (hansi 4 not outer))
+      ((_ x y z) (and outer (let-syntax ((z (syntax-rules () ((_ a) #t))) (y (z x)))))))) (hansi 4 not outer))