From 64aeafac79d72f440b6546bae91583e6efd6b674 Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Sat, 1 Jun 2013 07:35:18 +0000
Subject: Support --output in compiler, for bootstrapping stage.

---
 src/boot/ast.boot               |  6 +++++-
 src/boot/strap/ast.clisp        | 23 ++++++++++++++++-------
 src/boot/strap/parser.clisp     |  4 ++--
 src/boot/strap/tokens.clisp     | 12 ++++++------
 src/boot/strap/translator.clisp |  2 +-
 5 files changed, 30 insertions(+), 17 deletions(-)

(limited to 'src/boot')

diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index dfffa58a..14259ebd 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -811,16 +811,20 @@ bfHas(expr,prop) ==
 bfKeyArg(k,x) ==
   ['%Key,k,x]
 
+lispKey k ==
+  makeSymbol(stringUpcase symbolName k,'"KEYWORD")
+
 bfExpandKeys l ==
   args := nil
   while l is [a,:l] repeat
     a is ['%Key,k,x] =>
-      args := [x,makeSymbol(stringUpcase symbolName k,'"KEYWORD"),:args]
+      args := [x,lispKey k,:args]
     args := [a,:args]
   reverse! args      
 
 bfApplication(bfop, bfarg) ==
   bfTupleP bfarg => [bfop,:bfExpandKeys rest bfarg]
+  bfarg is ['%Key,k,v] => [bfop,lispKey k,v]
   [bfop,bfarg]
  
 -- returns the meaning of x in the appropriate Boot dialect.
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index a51ee1c2..6cb05e57 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -1223,6 +1223,8 @@
 
 (DEFUN |bfKeyArg| (|k| |x|) (LIST '|%Key| |k| |x|))
 
+(DEFUN |lispKey| (|k|) (INTERN (STRING-UPCASE (SYMBOL-NAME |k|)) "KEYWORD"))
+
 (DEFUN |bfExpandKeys| (|l|)
   (LET* (|x| |ISTMP#2| |k| |ISTMP#1| |a| |args|)
     (PROGN
@@ -1241,17 +1243,24 @@
                     (SETQ |ISTMP#2| (CDR |ISTMP#1|))
                     (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
                          (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
-        (SETQ |args|
-                (CONS |x|
-                      (CONS
-                       (INTERN (STRING-UPCASE (SYMBOL-NAME |k|)) "KEYWORD")
-                       |args|))))
+        (SETQ |args| (CONS |x| (CONS (|lispKey| |k|) |args|))))
        (T (SETQ |args| (CONS |a| |args|)))))
      (|reverse!| |args|))))
 
 (DEFUN |bfApplication| (|bfop| |bfarg|)
-  (COND ((|bfTupleP| |bfarg|) (CONS |bfop| (|bfExpandKeys| (CDR |bfarg|))))
-        (T (LIST |bfop| |bfarg|))))
+  (LET* (|v| |ISTMP#2| |k| |ISTMP#1|)
+    (COND ((|bfTupleP| |bfarg|) (CONS |bfop| (|bfExpandKeys| (CDR |bfarg|))))
+          ((AND (CONSP |bfarg|) (EQ (CAR |bfarg|) '|%Key|)
+                (PROGN
+                 (SETQ |ISTMP#1| (CDR |bfarg|))
+                 (AND (CONSP |ISTMP#1|)
+                      (PROGN
+                       (SETQ |k| (CAR |ISTMP#1|))
+                       (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+                       (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+                            (PROGN (SETQ |v| (CAR |ISTMP#2|)) T))))))
+           (LIST |bfop| (|lispKey| |k|) |v|))
+          (T (LIST |bfop| |bfarg|)))))
 
 (DEFUN |bfReName| (|x|)
   (LET* (|a|)
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index b6c95484..985611d3 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -388,7 +388,7 @@
       (COND (|done| (RETURN NIL))
             (T
              (SETQ |found|
-                     (LET ((#1=#:G725
+                     (LET ((#1=#:G720
                             (CATCH :OPEN-AXIOM-CATCH-POINT
                               (APPLY |f| |ps| NIL))))
                        (COND
@@ -1371,7 +1371,7 @@
      (SETQ |op| (|enclosingFunction| (|parserLoadUnit| |ps|)))
      (SETQ |varno| (|parserGensymSequenceNumber| |ps|))
      (UNWIND-PROTECT
-         (LET ((#1=#:G726
+         (LET ((#1=#:G721
                 (CATCH :OPEN-AXIOM-CATCH-POINT
                   (PROGN
                    (SETF (|enclosingFunction| (|parserLoadUnit| |ps|)) NIL)
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 3c0dd848..afd689ad 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -84,10 +84,10 @@
   (LET* (|s|)
     (COND
      ((SETQ |s|
-              (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
+              (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
                 (LET ((|bfVar#1| NIL))
                   (LOOP
-                   (MULTIPLE-VALUE-BIND (#2=#:G725 |k| |v|)
+                   (MULTIPLE-VALUE-BIND (#2=#:G720 |k| |v|)
                        (#1#)
                      (COND ((NOT #2#) (RETURN |bfVar#1|))
                            (T
@@ -138,9 +138,9 @@
                  (COND ((> |i| 255) (RETURN NIL)) (T (SETF (ELT |a| |i|) |b|)))
                  (SETQ |i| (+ |i| 1))))
               |a|))
-     (WITH-HASH-TABLE-ITERATOR (#1=#:G726 |shoeKeyTable|)
+     (WITH-HASH-TABLE-ITERATOR (#1=#:G721 |shoeKeyTable|)
        (LOOP
-        (MULTIPLE-VALUE-BIND (#2=#:G727 |s| #:G728)
+        (MULTIPLE-VALUE-BIND (#2=#:G722 |s| #:G723)
             (#1#)
           (COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
      |d|)))
@@ -154,9 +154,9 @@
      (LET ((|i| 0))
        (LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
              (SETQ |i| (+ |i| 1))))
-     (WITH-HASH-TABLE-ITERATOR (#1=#:G729 |shoeKeyTable|)
+     (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
        (LOOP
-        (MULTIPLE-VALUE-BIND (#2=#:G730 |k| #:G731)
+        (MULTIPLE-VALUE-BIND (#2=#:G725 |k| #:G726)
             (#1#)
           (COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL)
                 (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))))))
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 4cc7a1bb..d3f85676 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -416,7 +416,7 @@
      (SETQ |ps| (|makeParserState| |toks|))
      (|bpFirstTok| |ps|)
      (SETQ |found|
-             (LET ((#1=#:G734
+             (LET ((#1=#:G729
                     (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem| |ps|))))
                (COND
                 ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
-- 
cgit v1.2.3