From 4ebf86fc014d407548be8af728191fe02401bf1a Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Thu, 12 Jan 2012 12:50:31 +0000
Subject: 	* boot/parser.boot (bpFunction): New. 	(bpConstTok): Include
 it. 	* boot/ast.boot (bfFunction): New. 	* boot/tokens.boot: `function'
 is now a keyword.

---
 src/boot/ast.boot           |  2 ++
 src/boot/parser.boot        |  6 +++++-
 src/boot/strap/ast.clisp    |  2 ++
 src/boot/strap/parser.clisp |  8 ++++++--
 src/boot/strap/tokens.clisp | 39 +++++++++++++++++++++++++++++----------
 src/boot/tokens.boot        |  2 +-
 6 files changed, 45 insertions(+), 14 deletions(-)

(limited to 'src/boot')

diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 23bd1425..c45ade39 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -151,6 +151,8 @@ bfSymbol x==
   string? x=> x
   quote x
 
+bfFunction x ==
+  ["FUNCTION",x]
  
 bfDot: () -> %Symbol
 bfDot() == 
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
index a7706e9a..516b47de 100644
--- a/src/boot/parser.boot
+++ b/src/boot/parser.boot
@@ -385,7 +385,7 @@ bpConstTok() ==
     bpNext()
     bpRequire function bpSexp and
       bpPush bfSymbol bpPop1()
-  bpString()
+  bpString() or bpFunction()
 
 bpChar() ==
   $stok is ["ID",:.] and $ttok is "char" =>
@@ -663,6 +663,10 @@ bpString()==
   shoeTokType $stok is "STRING" and
     bpPush(quote makeSymbol $ttok) and bpNext()
  
+bpFunction() ==
+  bpEqKey "FUNCTION" and bpRequire function bpPrimary1
+    and bpPush bfFunction bpPop1()
+
 bpThetaName() ==
   $stok is ["ID",:.] and $ttok has SHOETHETA =>
     bpPushId()
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index e90f8223..8d1d93f4 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -179,6 +179,8 @@
 
 (DEFUN |bfSymbol| (|x|) (COND ((STRINGP |x|) |x|) (T (|quote| |x|))))
 
+(DEFUN |bfFunction| (|x|) (LIST 'FUNCTION |x|))
+
 (DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfDot|))
 
 (DEFUN |bfDot| () 'DOT)
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index 34fff72f..dd1d4dfd 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -388,7 +388,7 @@
     (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|)))
    ((|bpEqPeek| 'QUOTE) (|bpNext|)
     (AND (|bpRequire| #'|bpSexp|) (|bpPush| (|bfSymbol| (|bpPop1|)))))
-   (T (|bpString|))))
+   (T (OR (|bpString|) (|bpFunction|)))))
 
 (DEFUN |bpChar| ()
   (PROG (|ISTMP#1| |s| |a|)
@@ -530,7 +530,7 @@
      (COND
       ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (NOT (|bpExceptions|)))
        (SETQ |a| (GET |$ttok| 'SHOEINF))
-       (COND ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|)))
+       (COND ((NULL |a|) (AND (|bpPush| (|keywordId| |$ttok|)) (|bpNext|)))
              (T (AND (|bpPush| |a|) (|bpNext|)))))
       (T NIL)))))
 
@@ -655,6 +655,10 @@
   (AND (EQ (|shoeTokType| |$stok|) 'STRING)
        (|bpPush| (|quote| (INTERN |$ttok|))) (|bpNext|)))
 
+(DEFUN |bpFunction| ()
+  (AND (|bpEqKey| 'FUNCTION) (|bpRequire| #'|bpPrimary1|)
+       (|bpPush| (|bfFunction| (|bpPop1|)))))
+
 (DEFUN |bpThetaName| ()
   (DECLARE (SPECIAL |$stok| |$ttok|))
   (COND
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index c259bda3..7b16a885 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -29,8 +29,8 @@
   (LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE)
         (LIST "catch" 'CATCH) (LIST "cross" 'CROSS) (LIST "do" 'DO)
         (LIST "else" 'ELSE) (LIST "finally" 'FINALLY) (LIST "for" 'FOR)
-        (LIST "forall" 'FORALL) (LIST "has" 'HAS) (LIST "if" 'IF)
-        (LIST "import" 'IMPORT) (LIST "in" 'IN) (LIST "is" 'IS)
+        (LIST "forall" 'FORALL) (LIST "function" 'FUNCTION) (LIST "has" 'HAS)
+        (LIST "if" 'IF) (LIST "import" 'IMPORT) (LIST "in" 'IN) (LIST "is" 'IS)
         (LIST "isnt" 'ISNT) (LIST "leave" 'LEAVE) (LIST "macro" 'MACRO)
         (LIST "module" 'MODULE) (LIST "namespace" 'NAMESPACE) (LIST "of" 'OF)
         (LIST "or" 'OR) (LIST "rem" 'REM) (LIST "repeat" 'REPEAT)
@@ -64,6 +64,26 @@
 
 (DEFPARAMETER |shoeKeyTable| (|shoeKeyTableCons|))
 
+(DEFUN |keywordId| (|t|)
+  (PROG (|s|)
+    (RETURN
+     (COND
+      ((SETQ |s|
+               (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
+                 (LET ((|bfVar#1| NIL))
+                   (LOOP
+                    (MULTIPLE-VALUE-BIND (#2=#:G720 |k| |v|)
+                        (#1#)
+                      (COND ((NOT #2#) (RETURN |bfVar#1|))
+                            (T
+                             (AND (EQ |v| |t|)
+                                  (PROGN
+                                   (SETQ |bfVar#1| |k|)
+                                   (COND
+                                    (|bfVar#1| (RETURN |bfVar#1|))))))))))))
+       (INTERN |s|))
+      (T |t|)))))
+
 (DEFUN |shoeInsert| (|s| |d|)
   (PROG (|v| |k| |n| |u| |h| |l|)
     (RETURN
@@ -106,9 +126,9 @@
                         (T (SETF (ELT |a| |i|) |b|)))
                   (SETQ |i| (+ |i| 1))))
                |a|))
-      (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
+      (WITH-HASH-TABLE-ITERATOR (#1=#:G721 |shoeKeyTable|)
         (LOOP
-         (MULTIPLE-VALUE-BIND (#2=#:G720 |s| #:G721)
+         (MULTIPLE-VALUE-BIND (#2=#:G722 |s| #:G723)
              (#1#)
            (COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
       |d|))))
@@ -123,9 +143,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=#:G722 |shoeKeyTable|)
+      (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
         (LOOP
-         (MULTIPLE-VALUE-BIND (#2=#:G723 |k| #:G724)
+         (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))))))
@@ -187,10 +207,9 @@
              (LIST '|exit| 'EXIT) (LIST '|false| 'NIL) (LIST '|fifth| 'FIFTH)
              (LIST '|first| 'CAR) (LIST '|float?| 'FLOATP)
              (LIST '|flushOutput| 'FORCE-OUTPUT) (LIST '|fourth| 'CADDDR)
-             (LIST '|function| 'FUNCTION) (LIST '|function?| 'FUNCTIONP)
-             (LIST '|gensym| 'GENSYM) (LIST '|genvar| 'GENVAR)
-             (LIST '|integer?| 'INTEGERP) (LIST 'LAST '|last|)
-             (LIST '|list| 'LIST) (LIST '|listEq?| 'EQUAL)
+             (LIST '|function?| 'FUNCTIONP) (LIST '|gensym| 'GENSYM)
+             (LIST '|genvar| 'GENVAR) (LIST '|integer?| 'INTEGERP)
+             (LIST 'LAST '|last|) (LIST '|list| 'LIST) (LIST '|listEq?| 'EQUAL)
              (LIST '|lowerCase?| 'LOWER-CASE-P) (LIST '|makeSymbol| 'INTERN)
              (LIST '|maxIndex| 'MAXINDEX) (LIST '|mkpf| 'MKPF)
              (LIST '|newVector| 'MAKE-ARRAY) (LIST '|nil| NIL)
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index a008556c..b9a2e2a8 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -67,6 +67,7 @@ shoeKeyWords == [  _
             ['"finally", "FINALLY"], _
             ['"for",  "FOR"] , _
             ['"forall", "FORALL"] , _
+            ['"function", "FUNCTION"] , _
             ['"has", "HAS"] , _
             ['"if", "IF"], _
             ['"import", "IMPORT"], _
@@ -269,7 +270,6 @@ for i in [ _
   ["float?",   "FLOATP"] , _
   ["flushOutput", "FORCE-OUTPUT"], _
   ["fourth",    "CADDDR"]  , _
-  ["function","FUNCTION"] , _
   ["function?","FUNCTIONP"] , _
   ["gensym",    "GENSYM"]  , _
   ["genvar",    "GENVAR"]  , _
-- 
cgit v1.2.3