[Heavy] Add scheme integer ordering functions

Author: ricejasonf

heavy/include/heavy/Context.h

@@ -226,7 +226,7 @@ class Context : public ContinuationStack<Context>,
   // PushEnvFrame - Creates and pushes an EnvFrame to the
   //                current environment (EnvStack)
   EnvFrame* PushEnvFrame(llvm::ArrayRef<Value> Names);
-  void PopEnvFrame();
+  void PopEnvFrame(EnvFrame*);
   void PushLocalBinding(Binding* B);
 
   // PushLambdaFormals - Check formals, create an EnvFrame,
@@ -303,7 +303,7 @@ class Context : public ContinuationStack<Context>,
     }
   }
 
-  Value RebuildLiteral(Value V);
+  Value RebuildLiteral(Value V, Value Env = nullptr);
 
   Heap<Context>& getAllocator() { return *this; }
 
@@ -395,7 +395,8 @@ class Context : public ContinuationStack<Context>,
     return new (*this) BuiltinSyntax(Fn);
   }
 
-  SyntaxClosure* CreateSyntaxClosure(SourceLocation Loc, Value Node,
+  Value CreateSyntaxClosure(SourceLocation Loc, Value Node, Value Env);
+  SyntaxClosure* CreateSyntaxClosure(SourceLocation Loc, Symbol* S,
                                      Value Env);
 
   SourceValue* CreateSourceValue(SourceLocation Loc) {

heavy/include/heavy/OpGen.h

@@ -374,6 +374,10 @@ class OpGen : public ValueVisitor<OpGen, mlir::Value> {
     return createLiteral(V);
   }
 
+  mlir::Value VisitUndefined(Undefined U) {
+    return createUndefined();
+  }
+
   // VisitOperation and VisitContArg are both idempotent
   // so they are declared static for reuse in the static
   // value conversion functions.

heavy/include/heavy/Value.h

@@ -1634,6 +1634,7 @@ class Module : public ValueBase {
   }
 
   void Insert(String* Id, String* MangledName) {
+    assert(!MangledName->getStringRef().empty());
     Map[Id] = MangledName;
   }
 
@@ -1840,6 +1841,7 @@ class Environment : public ValueBase {
 
   // Add a named location or syntax keyword.
   void Insert(Symbol* S, String* MangledName) {
+    assert(!MangledName->getStringRef().empty());
     EnvMap[S->getString()] = MangledName;
   }
 

heavy/include/heavy/base.sld

@@ -3,7 +3,8 @@
 (define-library (heavy base)
   (import (heavy builtins)
           (heavy base r7rs-syntax)
-          (heavy base list))
+          (heavy base list)
+          (heavy base int))
   (begin
 
     ) ; end of begin
@@ -18,7 +19,6 @@
     quote
     set!
     syntax-rules
-    ir-macro-transformer
     begin
     cond-expand
     define-library
@@ -32,8 +32,8 @@
     -
     /
     *
-    >
-    <
+    < <= > >=
+    positive? zero?
     apply
     append
     call-with-values
@@ -68,7 +68,7 @@
     ; (heavy base list)
     caar cadr cdar cddr
     member memq memv
-    map reverse
+    reverse map
 
     ; eval stuff
     compile

heavy/include/heavy/base/int.sld

@@ -0,0 +1,40 @@
+(import (heavy builtins))
+
+(define-library (heavy base int)
+  (import (heavy builtins)
+          (heavy base r7rs-syntax))
+  (begin
+    (define (< x1 x2 . xN)
+      (if (positive? (- x2 x1))
+        (if (pair? xN)
+          (apply < x2 xN)
+          #t)
+        #f))
+
+    (define (<= x1 x2 . xN)
+      (let ((Difference (- x2 x1)))
+        (if (or (positive? Difference) (zero? Difference))
+          (if (pair? xN)
+            (apply <= x2 xN)
+            #t)
+          #f)))
+
+    (define (> x1 x2 . xN)
+      (if (positive? (- x1 x2))
+        (if (pair? xN)
+          (apply < x2 xN)
+          #t)
+        #f))
+
+    (define (>= x1 x2 . xN)
+      (let ((Difference (- x1 x2)))
+        (if (or (positive? Difference) (zero? Difference))
+          (if (pair? xN)
+            (apply >= x2 xN)
+            #t)
+          #f)))
+
+    ) ; end begin
+  (export
+    < <= > >=
+    ))

heavy/include/heavy/base/list.sld

@@ -2,7 +2,8 @@
 
 (define-library (heavy base list)
   (import (heavy builtins)
-          (heavy base r7rs-syntax))
+          (heavy base r7rs-syntax)
+          (only (heavy base int) < <=))
   (begin
     (define (caar x) (car (car x)))
     (define (cadr x) (car (cdr x)))
@@ -34,10 +35,42 @@
             (cons (car List) NewList))
           NewList)))
 
+    (define (map Proc . InputLists)
+      (define (MapFast FastProc List)
+        (if (pair? List)
+          (cons (FastProc (car List))
+                (MapFast FastProc (cdr List)))
+          '()))
+      (define MaxLen
+        (let Loop ((Lists InputLists)
+                   (MinLength -1))
+          (dump Lists)
+          (if (pair? Lists)
+            (let ((Len (length (car Lists))))
+              (Loop
+                (cdr Lists)
+                (if (<= 0 Len MinLength)
+                  Len
+                  MinLength)))
+            MinLength)))
+      (dump 'wtf)
+      (when (< MaxLen 0)
+        (error "expecting at least one finite list" InputLists))
+      (let Loop ((I 0)
+                 (Lists InputLists)
+                 (Result '()))
+        (if (< I MaxLen)
+          (let ((Args (MapFast car Lists))
+                (NextLists (MapFast cdr Lists)))
+            (Loop (+ I 1) NextLists (cons (apply Proc Args))))
+          Result)))
+
+
+
     ) ; end of begin
   (export
     caar cadr cdar cddr
     member memq memv
-    reverse
+    reverse map
     )
 )

heavy/include/heavy/base/r7rs-syntax.sld

@@ -5,11 +5,10 @@
 (define-library (heavy base r7rs-syntax)
   (import (heavy builtins))
   (begin
-    ; lambda already gives a nice error for an empty body.
     (define-syntax letrec*
       (syntax-rules ()
-        ((letrec* ((var init) ...) body ...)
-         ((lambda () (define var init) ...  body ...)))))
+        ((letrec* ((var init) ...) body1 body ...)
+         ((lambda () (define var init) ...  body1 body ...)))))
 
     (define-syntax letrec
       (syntax-rules ()
@@ -18,14 +17,16 @@
 
     (define-syntax let
       (syntax-rules ()
-        ((let ((name val) ...) body ...)
-          ((lambda (name ...) body ...) val ...))
-        ((let tag ((name val) ...) body ...)
+        ((let ((name val) ...) body1 body ...)
+          ((lambda (name ...) body1 body ...) val ...))
+        ((let tag ((name val) ...) body1 body ...)
           ((letrec
-             ((tag (lambda (name ...) body ...)))
+             ((tag (lambda (name ...) body1 body ...)))
              tag)
             val ...))))
 
+    ; FIXME cond should be in the environment within syntax body.
+    ;       (this applies to all define-syntax)
     (define-syntax cond
       (syntax-rules (else =>)
         ((cond (else result1 result2 ...))