From c95f1b3efced12df21e9e99369cdb1a0a7d8ec2d Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Sun, 8 Jan 2012 14:55:53 +0000
Subject: 	* boot/ast.boot (bfEnum): New. 	* boot/translator.boot
 (translateToplevel): Use it to translate 	enumeration definitions. 
 * interp/types.boot (%ConstructorKind): Use new syntax.

---
 src/ChangeLog                   |  7 +++++++
 src/boot/ast.boot               |  3 +++
 src/boot/strap/ast.clisp        |  3 +++
 src/boot/strap/translator.clisp | 41 +++++++++++++++++++++++++----------------
 src/boot/translator.boot        |  4 +++-
 src/interp/types.boot           |  4 ++--
 6 files changed, 43 insertions(+), 19 deletions(-)

(limited to 'src')

diff --git a/src/ChangeLog b/src/ChangeLog
index 9a089bd6..5f30c52b 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,10 @@
+2012-01-08  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* boot/ast.boot (bfEnum): New.
+	* boot/translator.boot (translateToplevel): Use it to translate
+	enumeration definitions.
+	* interp/types.boot (%ConstructorKind): Use new syntax.
+
 2012-01-01  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* interp/define.boot (evalCategoryForm): New.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 656fdceb..23bd1425 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1312,6 +1312,9 @@ bfDs n ==
   n = 0 => '""
   strconc('"D",bfDs(n-1))
 
+bfEnum(t,csts) ==
+  ['DEFTYPE,t,nil,backquote(['MEMBER,:csts],nil)]
+
 bfHandlers(n,e,hs) == main(n,e,hs,nil) where
   main(n,e,hs,xs) ==
     hs = nil =>
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index b0c40086..e90f8223 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -2329,6 +2329,9 @@
 
 (DEFUN |bfDs| (|n|) (COND ((EQL |n| 0) "") (T (CONCAT "D" (|bfDs| (- |n| 1))))))
 
+(DEFUN |bfEnum| (|t| |csts|)
+  (LIST 'DEFTYPE |t| NIL (|backquote| (CONS 'MEMBER |csts|) NIL)))
+
 (DEFUN |bfHandlers| (|n| |e| |hs|) (|bfHandlers,main| |n| |e| |hs| NIL))
 
 (DEFUN |bfHandlers,main| (|n| |e| |hs| |xs|)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 4294b1ba..eec8f45e 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -609,7 +609,7 @@
       (T |x|)))))
 
 (DEFUN |translateToplevel| (|b| |export?|)
-  (PROG (|lhs| |t| |ISTMP#2| |sig| |ns| |n| |ISTMP#1| |xs|)
+  (PROG (|csts| |lhs| |t| |ISTMP#2| |sig| |ns| |n| |ISTMP#1| |xs|)
     (DECLARE
      (SPECIAL |$currentModuleName| |$foreignsDefsForCLisp|
       |$constantIdentifiers| |$InteractiveMode| |$activeNamespace|))
@@ -725,21 +725,30 @@
                  (|bfMDef| |op| |args| |body|)))
               (|%Structure|
                (LET ((|t| (CADR |b|)) (|alts| (CADDR |b|)))
-                 (LET ((|bfVar#5| NIL)
-                       (|bfVar#6| NIL)
-                       (|bfVar#4| |alts|)
-                       (|alt| NIL))
-                   (LOOP
-                    (COND
-                     ((OR (NOT (CONSP |bfVar#4|))
-                          (PROGN (SETQ |alt| (CAR |bfVar#4|)) NIL))
-                      (RETURN |bfVar#5|))
-                     ((NULL |bfVar#5|)
-                      (SETQ |bfVar#5| #2=(CONS (|bfCreateDef| |alt|) NIL))
-                      (SETQ |bfVar#6| |bfVar#5|))
-                     (T (RPLACD |bfVar#6| #2#)
-                      (SETQ |bfVar#6| (CDR |bfVar#6|))))
-                    (SETQ |bfVar#4| (CDR |bfVar#4|))))))
+                 (COND
+                  ((AND (CONSP |alts|) (NULL (CDR |alts|))
+                        (PROGN
+                         (SETQ |ISTMP#1| (CAR |alts|))
+                         (AND (CONSP |ISTMP#1|)
+                              (EQ (CAR |ISTMP#1|) '|Enumeration|)
+                              (PROGN (SETQ |csts| (CDR |ISTMP#1|)) T))))
+                   (LIST (|bfEnum| |t| |csts|)))
+                  (T
+                   (LET ((|bfVar#5| NIL)
+                         (|bfVar#6| NIL)
+                         (|bfVar#4| |alts|)
+                         (|alt| NIL))
+                     (LOOP
+                      (COND
+                       ((OR (NOT (CONSP |bfVar#4|))
+                            (PROGN (SETQ |alt| (CAR |bfVar#4|)) NIL))
+                        (RETURN |bfVar#5|))
+                       ((NULL |bfVar#5|)
+                        (SETQ |bfVar#5| #2=(CONS (|bfCreateDef| |alt|) NIL))
+                        (SETQ |bfVar#6| |bfVar#5|))
+                       (T (RPLACD |bfVar#6| #2#)
+                        (SETQ |bfVar#6| (CDR |bfVar#6|))))
+                      (SETQ |bfVar#4| (CDR |bfVar#4|))))))))
               (|%Namespace|
                (LET ((|n| (CADR |b|)))
                  (PROGN
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index a58f55eb..ec035b43 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -479,7 +479,9 @@ translateToplevel(b,export?) ==
 
     %Macro(op,args,body) => bfMDef(op,args,body)
 
-    %Structure(t,alts) => [bfCreateDef alt for alt in alts]
+    %Structure(t,alts) =>
+      alts is [['Enumeration,:csts]] => [bfEnum(t,csts)]
+      [bfCreateDef alt for alt in alts]
 
     %Namespace n =>
       $activeNamespace := symbolName n
diff --git a/src/interp/types.boot b/src/interp/types.boot
index 915279ee..592c70e5 100644
--- a/src/interp/types.boot
+++ b/src/interp/types.boot
@@ -43,5 +43,5 @@ namespace BOOT
 
 %Modemap <=> %List(%Form)                      -- modemap
 
-%ConstructorKind <=>                           -- kind of ctor instances
-  MEMBER(category,domain,package)
+structure %ConstructorKind ==                  -- kind of ctor instances
+  Enumeration(category,domain,package)
-- 
cgit v1.2.3