Add support for and

Makefile

@@ -2,8 +2,11 @@ all: generate body
 
 body: link compile run
 
+stdlib:
+	csi -s compile-lib.scm programs/stdlib.scm > stdlib.ll
+
 generate:
-	csi -s compile.scm > body.ll
+	csi -s compile-program.scm programs/main.scm > body.ll
 
 link:
 	cat stdlib-ll/*.ll stdlib.ll body.ll > output.ll

compatibility.scm

@@ -86,9 +86,20 @@
 (def any->string ->string)
 (def fixnum->string number->string)
 
-(defn string-append* (lst)
-      (if (null? lst)
-          ""
-          (string-append (fst lst) (string-append* (rst lst)))))
+(defn string-append* (lst) (foldl string-append "" lst))
 
 (defn id (x) x)
+
+(defn char->string (char) (list->string (list char)))
+
+(defn filter (pred lst)
+         (cond ((null? lst) (list))
+               ((eq? (pred (fst lst)) #t)
+                (cons (fst lst)
+                      (filter pred (rst lst))))
+               (else (filter pred (rst lst)))))
+
+(defn member? (var lst)
+         (cond ((null? lst) #f)
+               ((eq? var (fst lst)) #t)
+               (else (member? var (rst lst)))))

compile-lib.scm

@@ -1,7 +1,7 @@
 (include "compile.scm")
 
 (defn emit-lib (exprs)
-  (let ((preprocessed (map (fn (expr) (~> expr syntax-desugar alpha-convert-expr closure-convert)); normalize-term))
+  (let ((preprocessed (map (fn (expr) (~> expr desugar alpha-convert-expr closure-convert)); normalize-term))
                            exprs)))
     (for-each emit-global-var global-vars)
     (for-each emit-lambda lambdas)
@@ -10,7 +10,7 @@
 
 (defn debug (expr)
       (print (~> expr))
-      (let ((e2 (~> expr syntax-desugar)))
+      (let ((e2 (~> expr desugar)))
         (print e2)
         (let ((e3 (~> e2 alpha-convert-expr)))
           (print e3)

compile-program.scm

@@ -1,7 +1,7 @@
 (include "compile.scm")
 
 (defn emit-program (exprs)
-  (let ((preprocessed (map (fn (expr) (~> expr syntax-desugar alpha-convert-expr closure-convert)); normalize-term))
+  (let ((preprocessed (map (fn (expr) (~> expr desugar alpha-convert-expr closure-convert)); normalize-term))
                            exprs)))
     (for-each emit-global-var global-vars)
     (for-each (fn (expr)
@@ -25,7 +25,7 @@
 
 ; (defn debug (expr)
 ;       (print (~> expr))
-;       (let ((e2 (~> expr syntax-desugar)))
+;       (let ((e2 (~> expr desugar)))
 ;         (print e2)
 ;         (let ((e3 (~> e2 alpha-convert-expr)))
 ;           (print e3)

compile.scm

@@ -7,7 +7,7 @@
 (include "syntax/begin.scm")
 (include "syntax/let.scm")
 (include "syntax/string.scm")
-(include "preprocessing/syntax-desugar.scm")
+(include "preprocessing/desugar.scm")
 (include "preprocessing/alpha-convert.scm")
 (include "preprocessing/closure-convert.scm")
 
@@ -78,10 +78,14 @@
   (print (string-append* (list "@var_" (escape var) " = weak global i64 0"))))
 
 (defn emit-expr (var env expr)
+  ; (print "  ;" var " = " expr)
   (cond
     ((immediate? expr) (emit-immediate var expr))
     ((string? expr) (emit-string var expr))
-    ((tagged-list? expr 'quote) (emit-symbol var (frst expr)))
+    ((tagged-list? expr 'quote)
+     (if (eq? (frst expr) '())
+         (emit-immediate var '())
+         (emit-symbol var (frst expr))))
     ((if? expr) (emit-if var env expr))
     ((begin? expr) (emit-begin var env expr))
     ((let? expr) (emit-let var env expr))
@@ -136,7 +140,9 @@
            (print (string-append* (list "  " var " = call i64 @" (escape name) "(" (string-join2 vars ", ") ")" )))))))
     ((variable? expr) (emit-variable-ref var env expr))
     (else
-      (error "Unknown expression: " expr))))
+      (error "Unknown expression: " expr)))
+  )
+  ; (print "  ; end of " var " = " expr))
 
 (defn emit-variable-ref (var env expr)
   ; (print ">>> emit-var-ref " expr)
@@ -145,7 +151,8 @@
       (if (eq? (string-ref (rst res) 0) #\@)
           (emit-load var (rst res))
           (emit-copy var (rst res)))
-      (error "can't find " var " in env"))))
+      ; (emit-load var (string-append "@var_" (escape expr))))))
+      (error "can't find " expr " in env"))))
 
 (defn emit-symbol (var expr)
   (let ((tmp (generate-var)))
@@ -154,7 +161,7 @@
 
 (defn debug-program (exprs)
   (let ((preprocessed (map (fn (expr)
-                               (~> expr syntax-desugar alpha-convert-expr closure-convert))
+                               (~> expr desugar alpha-convert-expr closure-convert))
                            (append stdlib exprs))))
     (print ">>> Global vars")
     (for-each print global-vars)

helper.scm

@@ -18,29 +18,26 @@
       (string-append "i64, "
                      (arg-str (sub1 arity))))))
 
+(defn escape-char (char) char
+      (cond
+        ((eq? char #\+) "_plus_")
+        ((eq? char #\>) "_greater_")
+        ((eq? char #\<) "_less_")
+        ((eq? char #\=) "_equal_")
+        ((eq? char #\*) "_times_")
+        ((eq? char #\/) "_slash_")
+        ((eq? char #\?) "_questionmark_")
+        (else (char->string char))))
+
 (defn escape (str)
   (~>> str any->string string->list
-       (map any->string)
        (map escape-char)
        (cons "prim_")
-       string-join))
-
-(defn escape-char (str)
-      (cond
-        ((equal? str "+") "_plus_")
-        ((equal? str ">") "_greater_")
-        ((equal? str "<") "_less_")
-        ((equal? str "=") "_equal_")
-        ((equal? str "*") "_times_")
-        ((equal? str "/") "_slash_")
-        ((equal? str "?") "_questionmark_")
-        (else str)))
+       string-append*))
 
 (defn tagged-list? (expr tag)
       (and (pair? expr)
-           (eq? (car expr) tag)))
-
-(defn string-join (lst) (foldl string-append "" lst))
+           (eq? (fst expr) tag)))
 
 (defn map-with-index (f start lst)
       (if (null? lst)
@@ -50,9 +47,20 @@
           (map-with-index f (add1 start) (rst lst)))))
 
 (defn empty-set () (list))
-(defn set (expr) (list expr))
-(defn set-union (a b) (lset-union eq? a b))
-(defn set-subtract (a b) (lset-difference eq? a b))
+(defn singleton-set (expr) (list expr))
+
+(defn set-subtract (a b)
+      (filter (fn (e) (not (member? e b)))
+              a))
+
+(defn set-union (a b)
+      (cond
+        ((null? a) b)
+        ((null? b) a)
+        ((member? (fst b) a)
+         (set-union a (rst b)))
+        (else
+          (set-union (cons (fst b) a) (rst b)))))
 
 (defn set-union* (sets)
       (cond

preprocessing/closure-convert.scm

@@ -1,8 +1,8 @@
 (defn closure-convert-expr (expr)
       (closure-convert expr))
 
-(def lambdas '())
-(def global-vars '())
+(def lambdas (list))
+(def global-vars (list))
 
 (defn register-lamdba (name body)
       (let ((old-lambdas lambdas))
@@ -86,7 +86,7 @@
                     bindings)))))
         ; ((and (symbol? expr) (not (primitive? expr)))
         ((and (symbol? expr) (not (assoc expr (global-var-env))))
-         (set expr))
+         (singleton-set expr))
         ((tagged-list? expr 'quote)
          (empty-set))
         ((list? expr)

preprocessing/desugar.scm

@@ -0,0 +1,166 @@
+(defn desugar (expr)
+      (cond
+        ((thread-first? expr)  (~> expr thread-first->nested-calls desugar))
+        ((thread-last? expr)  (~> expr thread-last->nested-calls desugar))
+        ((list_? expr) (~> expr list->nested-cons desugar))
+        ((let*? expr)  (~> expr let*->nested-lets desugar))
+        ((cond? expr)  (~> expr cond->nested-ifs desugar))
+        ((and? expr)   (~> expr and->if desugar))
+        ((or? expr)    (~> expr or->if desugar))
+        ((defn? expr)  (~> expr defn->def-fn desugar))
+        ((quote? expr) (~> expr frst desugar-quote))
+        ((quasiquote? expr) (~>> expr frst (desugar-quasiquote 1) desugar))
+        ((let? expr)
+         (let* ((bindings (let-bindings expr))
+                (new-bindings
+                  (map (fn (binding)
+                           (list (let-binding-variable binding)
+                                 (desugar (let-binding-value binding))))
+                       bindings)))
+           (make-let new-bindings
+                     (~> expr
+                         let-body_
+                         make-sequence
+                         desugar))))
+        ((begin? expr)
+         (let ((expressions (begin-expressions expr)))
+           (if (null? (rst expressions))
+               (fst expressions)
+               (~>> expressions
+                    (map desugar)
+                    make-begin))))
+        ((def? expr)
+         (make-def (def-name expr)
+                   (desugar (def-value expr))))
+        ((defprim? expr)
+         (make-defprim (defprim-name expr)
+                       (defprim-args expr)
+                       (~> expr
+                           defprim-body_
+                           make-sequence
+                           desugar)))
+        ((fn? expr)
+         (make-fn (fn-params expr)
+                  (~> expr
+                      fn-body_
+                      make-sequence
+                      desugar)))
+        ((assignment? expr)
+         (make-assignment (assignment-name expr)
+                          (desugar (assignment-value expr))))
+        ((list? expr)
+         (map desugar expr))
+        ((atomic? expr) expr)
+        (else
+          (error "Can not desugar expr: " expr))))
+
+(defn desugar-quote (expr)
+      (cond
+        ((pair? expr)
+         `(cons ,(desugar-quote (fst expr))
+                ,(desugar-quote (rst expr))))
+        ((null? expr) '())
+        ((immediate? expr) expr)
+        ((symbol? expr) `(quote ,expr))
+        (else
+          (error "Strange value in quote: " expr))))
+
+(defn desugar-quasiquote (level expr)
+      (cond
+        ((unquote? expr)
+         (if (eq? level 1)
+             (desugar (frst expr))
+             (list 'list ''unquote
+                   (desugar-quasiquote (sub1 level) (frst expr)))))
+        ((quasiquote? expr)
+         `(list 'quasiquote ,(desugar-quasiquote (add1 level)
+                                                 (frst expr))))
+        ((and (pair? expr) (unquote-splicing? (fst expr)))
+         (if (eq? level 1)
+             `(append ,(frfst expr) ,(desugar-quasiquote level (rst expr)))
+             (cons (list 'unquote-splicing
+                         (desugar-quasiquote (sub1 level) (frfst expr)))
+                   (desugar-quasiquote level (frst expr)))))
+        ((pair? expr)
+         `(cons ,(desugar-quasiquote level (fst expr))
+                ,(desugar-quasiquote level (rst expr))))
+        (else (desugar-quote expr))))
+
+(defn let*->nested-lets (expr)
+      (let* ((bindings (let-bindings expr))
+             (body (make-sequence (let-body_ expr))))
+        (if (null? bindings)
+          body
+          (make-let (list (fst bindings))
+                    (~> bindings
+                        rst
+                        (make-let* body)
+                        let*->nested-lets)))))
+
+(defn defn->def-fn (expr)
+      (make-def (defn-name expr)
+                (make-fn (defn-args expr)
+                         (make-sequence (defn-body_ expr)))))
+
+(defn list->nested-cons (expr) (list->nested-cons_ (rst expr)))
+(defn list->nested-cons_ (elems)
+      (if (null? elems)
+        '()
+        (list 'cons (fst elems)
+              (list->nested-cons_ (rst elems)))))
+
+(defn thread-first->nested-calls (expr) (thread-first->nested-calls_ (frst expr) (rrst expr)))
+(defn thread-first->nested-calls_ (var fns)
+      (if (null? fns)
+          var
+          (thread-first->nested-calls_
+            (let ((fn (fst fns)))
+              (if (list? fn)
+                  (cons (fst fn)
+                        (cons var
+                              (rst fn)))
+                  (list fn var)))
+            (rst fns))))
+
+(defn thread-last->nested-calls (expr) (thread-last->nested-calls_ (frst expr) (rrst expr)))
+(defn thread-last->nested-calls_ (var fns)
+      (if (null? fns)
+          var
+          (thread-last->nested-calls_
+            (let ((fn (fst fns)))
+              (if (list? fn)
+                  (append fn (list var))
+                  (list fn var)))
+            (rst fns))))
+
+(defn cond->nested-ifs (expr) (cond->nested-ifs_ (cond-clauses expr)))
+(defn cond->nested-ifs_ (clauses)
+      (cond
+        ((null? clauses) (error "Empty cond: " expr))
+        ((null? (rst clauses)) (error "cond must have at least 2 branches: " expr))
+        ((null? (rrst clauses))
+         (let ((first-clause (fst clauses))
+               (second-clause (frst clauses)))
+           (if (eq? 'else (cond-clause-test second-clause))
+             (make-if (cond-clause-test first-clause)
+                      (make-sequence (cond-clause-action_ first-clause))
+                      (make-sequence (cond-clause-action_ second-clause)))
+             (error "Last clause of cond must be else: " expr))))
+        (else
+          (let ((first-clause (fst clauses))
+                (rest-clauses (rst clauses)))
+            (make-if (cond-clause-test first-clause)
+                     (make-sequence (cond-clause-action_ first-clause))
+                     (cond->nested-ifs_ rest-clauses))))))
+
+(defn or->if (expr) (or->if_ (or-arguments expr)))
+(defn or->if_ (expr)
+  (if (null? expr)
+    #f
+    `(if ,(fst expr) #t ,(or->if_ (rst expr)))))
+
+(defn and->if (expr) (and->if_ (and-arguments expr)))
+(defn and->if_ (expr)
+  (if (null? expr)
+    #t
+    `(if ,(fst expr) ,(and->if_ (rst expr)) #f)))