From 69e8450c1bbec8fde577ecd44a977d74f72e38b1 Mon Sep 17 00:00:00 2001
From: Justin Ethier <justin.ethier@gmail.com>
Date: Thu, 7 Jan 2016 22:45:03 -0500
Subject: [PATCH] Adding define-c

---
 scheme/cyclone/transforms.sld | 22 +++++++++++++++++-----
 1 file changed, 17 insertions(+), 5 deletions(-)

diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld
index d970b784..2eea5ea0 100644
--- a/scheme/cyclone/transforms.sld
+++ b/scheme/cyclone/transforms.sld
@@ -86,7 +86,7 @@
     define->lambda 
     define->var 
     define->exp 
-    define-c
+    define-c?
     set!? 
     set!->var 
     set!->exp 
@@ -888,6 +888,12 @@
              (loop (cdr top-lvl)
                    (cons (car top-lvl) globals)
                    exprs))))
+         ((define-c? (car top-lvl))
+          ;; Add as a new global, for now keep things simple
+          ;; since this is compiler-specific
+          (loop (cdr top-lvl)
+                (cons (car top-lvl) globals)
+                exprs))
          (else
            (loop (cdr top-lvl)
                  globals
@@ -916,7 +922,8 @@
   (let ((globals '()))
     (for-each
       (lambda (e)
-        (if (define? e)
+        (if (or (define? e)
+                (define-c? e))
             (set! globals (cons (define->var e) globals))))
       exp)
     globals))
@@ -978,6 +985,7 @@
                                      (search (if->else exp)))))
       ((define? exp)     (union (list (define->var exp))
                               (search (define->exp exp))))
+      ((define-c? exp) (list (define->var exp)))
       ((set!? exp)     (union (list (set!->var exp)) 
                               (search (set!->exp exp))))
       ; Application:
@@ -1399,13 +1407,17 @@
 
   (let* ((global-def? (define? ast)) ;; No internal defines by this phase
          (ast-cps
-          (if global-def?
+          (cond
+           (global-def?
             (remove-unused
               `(define ,(define->var ast)
                 ,@(let ((k (gensym 'k))
                         (r (gensym 'r)))
-                   (cps (car (define->exp ast)) 'unused))))
-            (cps ast '%halt))))
+                   (cps (car (define->exp ast)) 'unused)))))
+            ((define-c? ast)
+             ast)
+            (else
+              (cps ast '%halt)))))
     ast-cps))