Add for and while loops

miniml/compiler/compile.scm

@@ -63,8 +63,8 @@
    ;; Token definitions
    (LPAREN LBRACE RBRACE QUOTE TILDE
            QUESTION SEMICOLONSEMICOLON LBRACK RBRACK LBRACKBAR BARRBRACK
-           AND BEGIN END EXCEPTION EXTERNAL FUN FUNCTION FUNCTOR IF IN MODULE
-           MUTABLE OF OPEN REC SIG STRUCT TRY TYPE VAL WHEN WITH
+           AND BEGIN DO DONE DOWNTO END EXCEPTION EXTERNAL FOR FUN FUNCTION FUNCTOR IF IN MODULE
+           MUTABLE OF OPEN REC SIG STRUCT TO TRY TYPE VAL WHEN WHILE WITH
            EOF STRING LIDENT UIDENT INT
            (right: MINUSGT)
            (left: BAR)
@@ -374,7 +374,10 @@
     (LBRACKBAR semi_separated_expr_list_opt BARRBRACK) : (lid->econstr "" $2)
     (PREFIXOP simple_expr) : (mkapp1 $1 $2)
     (simple_expr DOT LPAREN expr RPAREN) : (mkapp2 "array_get" $1 $4)
-    (simple_expr DOT LBRACK expr RBRACK) : (mkapp2 "string_get" $1 $4))
+    (simple_expr DOT LBRACK expr RBRACK) : (mkapp2 "string_get" $1 $4)
+    (WHILE expr DO expr DONE) : (list 'EWhile $2 $4)
+    (FOR lident_ext EQ expr TO expr DO expr DONE) : (list 'EFor $2 'UpTo $4 $6 $8)
+    (FOR lident_ext EQ expr DOWNTO expr DO expr DONE) : (list 'EFor $2 'DownTo $4 $6 $8))
 
    (labelled_simple_expr
     (simple_expr) : (mknolabelapp $1)
@@ -502,11 +505,15 @@
     (cons "as" (cons 'AS #f))
     (cons "asr" (cons 'INFIXOP4 "asr"))
     (cons "begin" (cons 'BEGIN #f))
+    (cons "do" (cons 'DO #f))
+    (cons "done" (cons 'DONE #f))
+    (cons "downto" (cons 'DOWNTO #f))
     (cons "else" (cons 'ELSE #f))
     (cons "end" (cons 'END #f))
     (cons "exception" (cons 'EXCEPTION #f))
     (cons "external" (cons 'EXTERNAL #f))
     (cons "false" (cons 'UIDENT "false"))
+    (cons "for" (cons 'FOR #f))
     (cons "fun" (cons 'FUN #f))
     (cons "function" (cons 'FUNCTION #f))
     (cons "functor" (cons 'FUNCTOR #f))
@@ -528,11 +535,13 @@
     (cons "sig" (cons 'SIG #f))
     (cons "struct" (cons 'STRUCT #f))
     (cons "then" (cons 'THEN #f))
+    (cons "to" (cons 'TO #f))
     (cons "true" (cons 'UIDENT "true"))
     (cons "try" (cons 'TRY #f))
     (cons "type" (cons 'TYPE #f))
     (cons "val" (cons 'VAL #f))
     (cons "when" (cons 'WHEN #f))
+    (cons "while" (cons 'WHILE #f))
     (cons "with" (cons 'WITH #f))
     ))
 
@@ -1098,10 +1107,12 @@
 (define GETFIELD 71)
 (define SETFIELD 77)
 (define BRANCH 84)
+(define BRANCHIF 85)
 (define BRANCHIFNOT 86)
 (define SWITCH 87)
 (define PUSHTRAP 89)
 (define POPTRAP 90)
+(define CHECKSIGNALS 92)
 (define C_CALL1 93)
 (define C_CALL2 94)
 (define C_CALL3 95)
@@ -1109,6 +1120,10 @@
 (define C_CALL5 97)
 (define C_CALLN 98)
 (define CONSTINT 103)
+(define NEQ 122)
+(define LTINT 123)
+(define GTINT 125)
+(define OFFSETINT 127)
 (define ISINT 129)
 (define BNEQ 132)
 (define STOP 143)
@@ -1918,6 +1933,10 @@
       (map (match-lambda ((arg . ('Nolabel))
              (lower-notail arg)
         )) args)))
+    (('EWhile cond body) (list 'LWhile (lower-notail cond) (lower-notail body)))
+    (('EFor v dir b1 b2 body)
+     (let ((env (local-var env v)))
+       (list 'LFor v dir (lower-notail b1) (lower-notail b2) (lower-expr env #f body))))
 )))
 
 (define (local-var-with-shape env v shape)
@@ -2233,6 +2252,48 @@
      (compile-letexits env stacksize exit-defs body))
     (('LExit exit args)
      (compile-exit env stacksize exit args))
+    (('LWhile cond body)
+     (let* ((labcond (newlabel))
+            (labloop (newlabel)))
+       (bytecode-BRANCH-to labcond)
+       (bytecode-emit-label labloop)
+       (bytecode-put-u32-le CHECKSIGNALS)
+       (compile-expr env stacksize body)
+       (bytecode-emit-label labcond)
+       (compile-expr env stacksize cond)
+       (bytecode-put-u32-le BRANCHIF)
+       (bytecode-emit-labref labloop)
+       (bytecode-CONSTINT 0)
+       ))
+    (('LFor v dir b1 b2 body)
+     (let* ((labloop (newlabel))
+            (labend (newlabel)))
+       (compile-expr env stacksize b1)
+       (bytecode-put-u32-le PUSH)
+       (compile-expr env (+ stacksize 1) b2)
+       (bytecode-put-u32-le PUSH)
+       (bytecode-put-u32-le PUSH)
+       (bytecode-ACC 2)
+       (bytecode-put-u32-le (if (equal? dir 'UpTo) GTINT LTINT))
+       (bytecode-put-u32-le BRANCHIF)
+       (bytecode-emit-labref labend)
+       (bytecode-emit-label labloop)
+       (bytecode-put-u32-le CHECKSIGNALS)
+       (compile-expr (stack-var env v stacksize) (+ stacksize 2) body)
+       (bytecode-ACC 1)
+       (bytecode-put-u32-le PUSH)
+       (bytecode-put-u32-le OFFSETINT)
+       (bytecode-put-u32-le (if (equal? dir 'UpTo) 1 -1))
+       (bytecode-put-u32-le ASSIGN)
+       (bytecode-put-u32-le 2)
+       (bytecode-ACC 1)
+       (bytecode-put-u32-le NEQ)
+       (bytecode-put-u32-le BRANCHIF)
+       (bytecode-emit-labref labloop)
+       (bytecode-emit-label labend)
+       (bytecode-CONSTINT 0)
+       (bytecode-POP 2)
+       ))
 ))
 
 (define (compile-expr-list env stacksize l)
@@ -2589,6 +2650,14 @@
       (fv-expr body bv)))
     (('LExit exit args)
      (fv-expr-list args bv))
+    (('LWhile cond body)
+     (vset-union
+      (fv-expr cond bv)
+      (fv-expr body bv)))
+    (('LFor v dir b1 b2 body)
+     (vset-union (fv-expr b1 bv)
+     (vset-union (fv-expr b2 bv)
+                 (fv-expr body (bv-add-var v bv)))))
   ))
 
 (define (fv-expr-list exprs bv)

miniml/compiler/test/Makefile

@@ -33,7 +33,8 @@ TESTS=\
 	infix_sugar \
 	functors \
 	exits \
-	external_exceptions
+	external_exceptions \
+	loops
 
 .PHONY: all
 all: $(addprefix test-,$(TESTS))

miniml/compiler/test/loops.info.reference

@@ -0,0 +1 @@
+Bytecode size:    5721 bytes

miniml/compiler/test/loops.ml

@@ -0,0 +1,49 @@
+let () =
+  print_endline "nonempty while";
+  let x = ref 42 in
+  while !x > 0 do
+    show_int !x;
+    x := !x / 2
+  done;
+  print_newline ()
+
+let () =
+  print_endline "empty while";
+  while false do
+    show_int 42
+  done;
+  print_newline ()
+
+let () =
+  print_endline "nonempty for (up)";
+  for x = 0 to 10 do
+    show_int x
+  done;
+  print_newline ()
+
+let () =
+  print_endline "nonempty for (down)";
+  for x = 10 downto 0 do
+    show_int x
+  done;
+  print_newline ()
+
+let () =
+  print_endline "one-iteration for";
+  for x = 42 to 42 do
+    show_int x
+  done;
+  for x = 42 downto 42 do
+    show_int x
+  done;
+  print_newline ()
+
+let () =
+  print_endline "empty for";
+  for x = 1 to 0 do
+    show_int x
+  done;
+  for x = 0 downto 1 do
+    show_int x
+  done;
+  print_newline ()

miniml/compiler/test/loops.output.reference

@@ -0,0 +1,12 @@
+nonempty while
+ 42 21 10 5 2 1
+empty while
+
+nonempty for (up)
+ 0 1 2 3 4 5 6 7 8 9 10
+nonempty for (down)
+ 10 9 8 7 6 5 4 3 2 1 0
+one-iteration for
+ 42 42
+empty for
+