Use IF iso COND as primitive; keep COND primitive as option.
authorJan Nieuwenhuizen <janneke@gnu.org>
Wed, 27 Jul 2016 06:49:45 +0000 (08:49 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Wed, 27 Jul 2016 06:49:45 +0000 (08:49 +0200)
GNUmakefile
base.mes
base0-cond.mes [new file with mode: 0644]
base0-if.mes [new file with mode: 0644]
cgram-ll1 [new file with mode: 0644]
let.mes
lib/srfi/srfi-0.scm
mes.c
scm.mes
test/base.test
test/scm.test

index 52eae27513a564cb025f0f582b4dd557cb90ffa4..33ea193d823524a0cba0023c092b2c9fbe1b8323 100644 (file)
@@ -1,6 +1,15 @@
 .PHONY: all check default 
-CFLAGS=-std=c99 -O3 -finline-functions
-#CFLAGS=-std=c99 -g
+CFLAGS:=-std=c99 -O3 -finline-functions
+#CFLAGS:=-std=c99 -g
+
+COND:=0
+ifeq ($(COND),1)
+CONDIF:=cond
+else
+CONDIF:=if
+endif
+
+CFLAGS+=-DCOND=$(COND)
 
 default: all
 
@@ -33,17 +42,18 @@ mes.h: mes.c GNUmakefile
 check: all guile-check
 #      ./mes.test
 #      ./mes.test ./mes
-       cat base0.mes base.mes lib/test.mes test/base.test | ./mes
-       cat base0.mes base.mes lib/test.mes test/closure.test | ./mes
-       cat base0.mes base.mes quasiquote.mes lib/test.mes test/quasiquote.test | ./mes
-       cat base0.mes base.mes quasiquote.mes let.mes lib/test.mes test/let.test | ./mes
-       cat base0.mes base.mes quasiquote.mes let.mes lib/srfi/srfi-0.scm scm.mes lib/test.mes test/scm.test | ./mes
+       cat base0.mes base0-$(CONDIF).mes base.mes lib/test.mes test/base.test | ./mes
+       cat base0.mes base0-$(CONDIF).mes base.mes lib/test.mes test/closure.test | ./mes
+       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes lib/test.mes test/quasiquote.test | ./mes
+       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes lib/test.mes test/let.test | ./mes
+       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes lib/srfi/srfi-0.scm scm.mes lib/test.mes test/scm.test | ./mes
 
 guile-check:
        guile -s <(cat base.mes lib/test.mes test/base.test)
        guile -s <(cat base.mes lib/test.mes test/closure.test)
        guile -s <(cat base.mes lib/test.mes test/quasiquote.test)
        guile -s <(cat quasiquote.mes lib/test.mes test/quasiquote.test)
+#      guile -s <(cat base.mes quasiquote.mes let.mes lib/test.mes test/let.test)
 #      guile -s <(cat base.mes let.mes test/foo.test)
 #      exit 1
        guile -s <(cat lib/test.mes test/base.test)
@@ -57,10 +67,10 @@ run: all
        cat scm.mes test.mes | ./mes
 
 psyntax: all
-       cat base0.mes base.mes quasiquote.mes let.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
+       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
 
 syntax: all
-       cat base0.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes syntax-test.mes | ./mes
+       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax.mes syntax-test.mes | ./mes
 
 syntax.test: syntax.mes syntax-test.mes
        cat $^ > $@
@@ -78,7 +88,7 @@ guile-syntax-case: syntax-case.test
        guile -s $^
 
 macro: all
-       cat base0.mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes
+       cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes
 
 peg: all
        cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes | ./mes
@@ -99,7 +109,7 @@ record: all
 
 
 paren: all
-       echo -e 'EOF\n___P((()))' | cat base0.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm paren.scm - | ./mes
+       echo -e 'EOF\n___P((()))' | cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm paren.scm - | ./mes
 
 paren.test: lib/lalr.scm paren.scm
        cat $^ > $@
@@ -108,7 +118,7 @@ guile-paren: paren.test
        echo '___P((()))' | guile -s $^ 
 
 mescc: all
-       echo ' EOF ' | cat base0.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm c-lexer.scm mescc.scm - main.c | ./mes
+       echo ' EOF ' | cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm c-lexer.scm mescc.scm - main.c | ./mes
 
 mescc.test: lib/lalr.scm c-lexer.scm mescc.scm
        cat $^ > $@
index a388a8a5990e6ed16371a8b2208269aa15a8420e..31bcda13941d86b49faeb8318b7a8d1af18645db 100644 (file)
--- a/base.mes
+++ b/base.mes
 (define (identity x) x)
 (define else #t)
 
-(define (not x)
-  (cond (x #f)
-        (#t #t)))
-
-(define guile? (not (pair? (current-module))))
-
-(define-macro (or2 x y)
-  `(cond (,x ,x) (#t ,y)))
-
-(define-macro (and2 x y)
-  `(cond (,x ,y) (#t #f)))
-
-(define-macro (and . x)
-  (cond ((null? x) #t)
-        ((null? (cdr x)) (car x))
-        (#t (list 'cond (list (car x) (cons 'and (cdr x)))
-                  '(#t #f)))))
-
+;;; COND based
 (define-macro (or . x)
-  (cond
+  (cond ;; COND
    ((null? x) #f)
    ((null? (cdr x)) (car x))
-   (#t (list 'cond (list (car x))
+   (#t (list 'cond (list (car x)) ;; COND
              (list #t (cons 'or (cdr x)))))))
 
-(define (cons* x . rest)
-  (define (loop rest)
-    (cond ((null? (cdr rest)) (car rest))
-          (#t (cons (car rest) (loop (cdr rest))))))
-  (loop (cons x rest)))
+(define-macro (and . x)
+  (cond ((null? x) #t) ;; COND
+        ((null? (cdr x)) (car x))
+        (#t (list 'cond (list (car x) (cons 'and (cdr x))) ;; COND
+                  '(#t #f)))))
+
+(define (not x)
+  (cond (x #f) ;; COND
+        (#t #t)))
 
 (define (equal? a b) ;; FIXME: only 2 arg
-  (cond ((and (null? a) (null? b)) #t)
+  (cond ((and (null? a) (null? b)) #t) ;; COND
         ((and (pair? a) (pair? b))
          (and (equal? (car a) (car b))
               (equal? (cdr a) (cdr b))))
         (#t (eq? a b))))
 
 (define (memq x lst)
-  (cond ((null? lst) #f)
+  (cond ((null? lst) #f) ;; COND
         ((eq? x (car lst)) lst)
         (#t (memq x (cdr lst)))))
 
 (define (map f l . r)
-  (cond ((null? l) '())
+  (cond ((null? l) '()) ;; COND
         ((null? r) (cons (f (car l)) (map f (cdr l))))
         ((null? (cdr r))
          (cons (f (car l) (caar r)) (map f (cdr l) (cdar r))))))
 
+;; IF based
+(define-macro (or . x)
+  (if (null? x) #f ;; IF
+      (if (null? (cdr x)) (car x) ;; IF
+          (list 'if (car x) (car x)
+                (cons* 'or (cdr x))))))
+
+(define-macro (and . x)
+  (if (null? x) #t ;; IF
+      (if (null? (cdr x)) (car x) ;; IF
+          (list 'if (car x) (cons 'and (cdr x)) ;; IF
+                #f))))
+
+(define (not x)
+  (if x #f #t))
+
+(define (equal? a b) ;; FIXME: only 2 arg
+  (if (and (null? a) (null? b)) #t ;; IF
+      (if (and (pair? a) (pair? b))
+          (and (equal? (car a) (car b))
+               (equal? (cdr a) (cdr b)))
+          (if (and (string? a) (string? b)) ;; IF
+              (eq? (string->symbol a) (string->symbol b))
+              (if (and (vector? a) (vector? b)) ;; IF
+                  (equal? (vector->list a) (vector->list b))
+                  (eq? a b))))))
+
+(define (memq x lst)
+  (if (null? lst) #f ;; IF
+      (if (eq? x (car lst)) lst ;; IF
+          (memq x (cdr lst)))))
+
+(define guile? (not (pair? (current-module))))
+
+(define (map f l . r)
+  (if (null? l) '() ;; IF
+      (if (null? r) (cons (f (car l)) (map f (cdr l))) ;; IF
+          (if (null? (cdr r)) ;; IF
+              (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))
+
 (define-macro (simple-let bindings . rest)
   (cons (cons 'lambda (cons (map car bindings) rest))
         (map cadr bindings)))
diff --git a/base0-cond.mes b/base0-cond.mes
new file mode 100644 (file)
index 0000000..6d6b21c
--- /dev/null
@@ -0,0 +1,31 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; base.mes: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-macro (if expr then . else)
+  (list 'cond ;; COND
+        (list expr then)
+        (list #t (list 'cond (list (pair? else) ;; COND
+                                   (cons (cons 'lambda (cons '() (cons (cons 'begin (cons *unspecified* else)) '()))) '()))))))
+
+(define (cons* x . rest)
+  (define (loop rest)
+    (cond ((null? (cdr rest)) (car rest)) ;; COND
+          (#t (cons (car rest) (loop (cdr rest))))))
+  (loop (cons x rest)))
diff --git a/base0-if.mes b/base0-if.mes
new file mode 100644 (file)
index 0000000..7a7280b
--- /dev/null
@@ -0,0 +1,40 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; base.mes: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(define (cons* x . rest)
+  (define (loop rest)
+    (if (null? (cdr rest)) (car rest) ;; IF
+        (cons (car rest) (loop (cdr rest)))))
+  (loop (cons x rest)))
+
+(define-macro cond
+  (lambda clauses
+    (if (null? clauses) *unspecified* ;; IF
+        (if (null? (cdr clauses)) ;; IF
+            (list 'if (car (car clauses)) ;; IF
+                  (cons* 'begin (car (car clauses)) (cdr (car clauses)))
+                  *unspecified*)
+            (if (eq? (car (cadr clauses)) 'else) ;; IF
+                (list 'if (car (car clauses)) ;; IF
+                      (cons* 'begin (car (car clauses)) (cdr (car clauses)))
+                      (cons* 'begin *unspecified* (cdr (cadr clauses))))
+                (list 'if (car (car clauses)) ;; IF
+                      (cons* 'begin (car (car clauses)) (cdr (car clauses)))
+                      (cons* 'cond (cdr clauses)))))))) ;; IF
diff --git a/cgram-ll1 b/cgram-ll1
new file mode 100644 (file)
index 0000000..2c23d51
--- /dev/null
+++ b/cgram-ll1
@@ -0,0 +1,825 @@
+; Author: Mohd Hanafiah Abdullah (napi@cs.indiana.edu or napi@ms.mimos.my)
+; Please report any bugs that you find.  Thanks.
+;
+; ANSI C LL(k) GRAMMAR (1 <= k <= 2)
+;
+; THE TERMINALS
+;
+; "identifier" "octal_constant" "hex_constant" "decimal_constant"
+; "float_constant" "char_constant" "string_literal" "sizeof"
+; "->" "++" "--" "<<" ">>" "<=" ">=" "==" "!="
+; "&&" "||" "*=" "/=" "%=" "+="
+; "-=" "<<=" ">>=" "&="
+; "^=" "|="
+
+; "typedef" "extern" "static" "auto" "register"
+; "char" "short" "int" "long" "signed" "unsigned" "float" "double"
+; "const" "volatile" "void"
+; "struct" "union" "enum" "..."
+
+; "case" "default" "if" "else" "switch" "while" "do" "for" "goto"
+; "continue" "break" "return"
+;---------------------------------------------------------------------------
+
+(define g
+       '((primary_expr
+               ("identifier")
+               ("octal_constant")
+               ("hex_constant")
+               ("decimal_constant")
+               ("float_constant")
+               ("char_constant")
+               ("string_literal")
+               ("(" expr ")"))
+
+       (postfix_expr
+               (primary_expr postfix_exprP))
+
+       (postfix_exprP
+               ("[" expr "]" postfix_exprP)
+               ("(" fact_postfix_exprP)
+               ("." "identifier" postfix_exprP)
+               ("->" "identifier" postfix_exprP)
+               ("++" postfix_exprP)
+               ("--" postfix_exprP)
+               ())
+
+       (fact_postfix_exprP
+               (argument_expr_list ")" postfix_exprP)
+               (")" postfix_exprP))
+
+       (argument_expr_list
+               (assignment_expr argument_expr_listP))
+
+       (argument_expr_listP
+               ("," assignment_expr argument_expr_listP)
+               ())
+
+       (unary_expr
+               (postfix_expr)
+               ("++" unary_expr)
+               ("--" unary_expr)
+               (unary_operator cast_expr)
+               ("sizeof" fact_unary_expr))
+
+       (fact_unary_expr
+               ("identifier" postfix_exprP)
+               ("octal_constant" postfix_exprP)
+               ("hex_constant" postfix_exprP)
+               ("decimal_constant" postfix_exprP)
+               ("float_constant" postfix_exprP)
+               ("char_constant" postfix_exprP)
+               ("string_literal" postfix_exprP)
+               ("++" unary_expr)
+               ("--" unary_expr)
+               (unary_operator cast_expr)
+               ("sizeof" fact_unary_expr)
+               ("(" fact_fact_unary_expr))
+
+       (fact_fact_unary_expr
+               (expr ")" postfix_exprP)
+               (type_name ")"))
+
+       (unary_operator
+               ("&")
+               ("*")
+               ("+")
+               ("-")
+               ("~")
+               ("!"))
+
+       (cast_expr
+               ("identifier" postfix_exprP)
+               ("octal_constant" postfix_exprP)
+               ("hex_constant" postfix_exprP)
+               ("decimal_constant" postfix_exprP)
+               ("float_constant" postfix_exprP)
+               ("char_constant" postfix_exprP)
+               ("string_literal" postfix_exprP)
+               ("++" unary_expr)
+               ("--" unary_expr)
+               (unary_operator cast_expr)
+               ("sizeof" fact_unary_expr)
+               ("(" fact_cast_expr))
+
+       (fact_cast_expr
+               (expr ")" postfix_exprP)
+               (type_name ")" cast_expr))
+
+       (multiplicative_expr
+               (cast_expr multiplicative_exprP))
+
+       (multiplicative_exprP
+               ("*" cast_expr multiplicative_exprP)
+               ("/" cast_expr multiplicative_exprP)
+               ("%" cast_expr multiplicative_exprP)
+               ())
+
+       (additive_expr
+               (multiplicative_expr additive_exprP))
+
+       (additive_exprP
+               ("+" multiplicative_expr additive_exprP)
+               ("-" multiplicative_expr additive_exprP)
+               ())
+
+       (shift_expr
+               (additive_expr shift_exprP))
+
+       (shift_exprP
+               ("<<" additive_expr shift_exprP)
+               (">>" additive_expr shift_exprP)
+               ())
+
+       (relational_expr
+               (shift_expr relational_exprP))
+
+       (relational_exprP
+               ("<" shift_expr relational_exprP)
+               (">" shift_expr relational_exprP)
+               ("<=" shift_expr relational_exprP)
+               (">=" shift_expr relational_exprP)
+               ())
+
+       (equality_expr
+               (relational_expr equality_exprP))
+
+       (equality_exprP
+               ("==" relational_expr equality_exprP)
+               ("!=" relational_expr equality_exprP)
+               ())
+
+       (and_expr
+               (equality_expr and_exprP))
+
+       (and_exprP
+               ("&" equality_expr and_exprP)
+               ())
+
+       (exclusive_or_expr
+               (and_expr exclusive_or_exprP))
+
+       (exclusive_or_exprP
+               ("^" and_expr exclusive_or_exprP)
+               ())
+
+       (inclusive_or_expr
+               (exclusive_or_expr inclusive_or_exprP))
+
+       (inclusive_or_exprP
+               ("|" exclusive_or_expr inclusive_or_exprP)
+               ())
+
+       (logical_and_expr
+               (inclusive_or_expr logical_and_exprP))
+
+       (logical_and_exprP
+               ("&&" inclusive_or_expr logical_and_exprP)
+               ())
+
+       (logical_or_expr
+               (logical_and_expr logical_or_exprP))
+
+       (logical_or_exprP
+               ("||" logical_and_expr logical_or_exprP)
+               ())
+
+       (conditional_expr
+               (logical_or_expr fact_conditional_expr))
+
+       (fact_conditional_expr
+               ("?" expr ":" conditional_expr)
+               ())
+
+       (assignment_expr
+               (conditional_expr fact_assignment_expr))
+
+       (fact_assignment_expr
+               (assignment_operator assignment_expr)
+               ())
+
+       (assignment_operator
+               ("=")
+               ("*=")
+               ("/=")
+               ("%=")
+               ("+=")
+               ("-=")
+               ("<<=")
+               (">>=")
+               ("&=")
+               ("^=")
+               ("|="))
+
+       (OPT_EXPR
+               (expr)
+               ())
+
+       (expr
+               (assignment_expr exprP))
+
+       (exprP
+               ("," assignment_expr exprP)
+               ())
+
+       (constant_expr
+               (conditional_expr))
+
+       (declaration
+               (declaration_specifiers fact_declaration))
+
+       (fact_declaration
+               (init_declarator_list ";")
+               (";"))
+
+       (declaration_specifiers
+               (storage_class_specifier fact_declaration_specifiers1)
+               (type_specifier fact_declaration_specifiers2)
+               (type_qualifier fact_declaration_specifiers3))
+
+       (fact_declaration_specifiers1
+               (declaration_specifiers)
+               ())
+
+       (fact_declaration_specifiers2
+               (declaration_specifiers)
+               ())
+
+       (fact_declaration_specifiers3
+               (declaration_specifiers)
+               ())
+
+       (init_declarator_list
+               (init_declarator init_declarator_listP))
+
+       (init_declarator_listP
+               ("," init_declarator init_declarator_listP)
+               ())
+
+       (init_declarator
+               (declarator fact_init_declarator))
+
+       (fact_init_declarator
+               ("=" initializer)
+               ())
+
+       (storage_class_specifier
+               ("typedef")
+               ("extern")
+               ("static")
+               ("auto")
+               ("register"))
+
+       (type_specifier
+               ("void")
+               ("char")
+               ("short")
+               ("int")
+               ("long")
+               ("float")
+               ("double")
+               ("signed")
+               ("unsigned")
+               (struct_or_union_specifier)
+               (enum_specifier)
+               (typedef_name))
+
+       (struct_or_union_specifier
+               (struct_or_union fact_struct_or_union_specifier))
+
+       (fact_struct_or_union_specifier
+               ("{" struct_declaration_list "}")
+               ("identifier" fact_fact_struct_or_union_specifier))
+
+       (fact_fact_struct_or_union_specifier
+               ("{" struct_declaration_list "}")
+               ())
+
+       (struct_or_union
+               ("struct")
+               ("union"))
+
+       (struct_declaration_list
+               (struct_declaration struct_declaration_listP))
+
+       (struct_declaration_listP
+               (struct_declaration struct_declaration_listP)
+               ())
+
+       (struct_declaration
+               (specifier_qualifier_list struct_declarator_list ";"))
+
+       (specifier_qualifier_list
+               (type_specifier fact_specifier_qualifier_list1)
+               (type_qualifier fact_specifier_qualifier_list2))
+
+       (fact_specifier_qualifier_list1
+               (specifier_qualifier_list)
+               ())
+
+       (fact_specifier_qualifier_list2
+               (specifier_qualifier_list)
+               ())
+
+       (struct_declarator_list
+               (struct_declarator struct_declarator_listP))
+
+       (struct_declarator_listP
+               ("," struct_declarator struct_declarator_listP)
+               ())
+
+       (struct_declarator
+               (declarator fact_struct_declarator)
+               (":" constant_expr))
+
+       (fact_struct_declarator
+               (":" constant_expr)
+               ())
+
+       (enum_specifier
+               ("enum" fact_enum_specifier))
+
+       (fact_enum_specifier
+               ("{" enumerator_list "}")
+               ("identifier" fact_fact_enum_specifier))
+
+       (fact_fact_enum_specifier
+               ("{" enumerator_list "}")
+               ())
+
+       (enumerator_list
+               (enumerator enumerator_listP))
+
+       (enumerator_listP
+               ("," enumerator enumerator_listP)
+               ())
+
+       (enumerator
+               ("identifier" fact_enumerator))
+
+       (fact_enumerator
+               ("=" constant_expr)
+               ())
+
+       (type_qualifier
+               ("const")
+               ("volatile"))
+
+       (declarator
+               (pointer direct_declarator)
+               (direct_declarator))
+
+       (direct_declarator
+               ("identifier" direct_declaratorP)
+               ("(" declarator ")" direct_declaratorP))
+
+       (direct_declaratorP
+               ("[" fact_direct_declaratorP1)
+               ("(" fact_direct_declaratorP2)
+               ())
+
+       (fact_direct_declaratorP1
+               (constant_expr "]" direct_declaratorP)
+               ("]" direct_declaratorP))
+
+       (fact_direct_declaratorP2
+               (parameter_type_list ")" direct_declaratorP)
+               (identifier_list ")" direct_declaratorP)
+               (")" direct_declaratorP))
+
+       (pointer
+               ("*" fact_pointer))
+
+       (fact_pointer
+               (type_qualifier_list fact_fact_pointer)
+               (pointer)
+               ())
+
+       (fact_fact_pointer
+               (pointer)
+               ())
+
+       (type_qualifier_list
+               (type_qualifier type_qualifier_listP))
+
+       (type_qualifier_listP
+               (type_qualifier type_qualifier_listP)
+               ())
+
+       (identifier_list
+               ("identifier" identifier_listP))
+
+       (identifier_listP
+               ("," "identifier" identifier_listP)
+               ())
+
+       (parameter_type_list
+               (parameter_list fact_parameter_type_list))
+
+       (fact_parameter_type_list
+               ("," "...")
+               ())
+
+       (parameter_list
+               (parameter_declaration parameter_listP))
+
+       (parameter_listP
+               ("," parameter_declaration parameter_listP)
+               ())
+
+       (parameter_declaration
+               (declaration_specifiers fact_parameter_declaration))
+
+       (fact_parameter_declaration
+               (modified_declarator)
+               ())
+
+       (modified_declarator
+               (pointer fact_modified_declarator)
+               (direct_modified_declarator))
+
+       (fact_modified_declarator
+               (direct_modified_declarator)
+               ())
+
+       (direct_modified_declarator
+               ("identifier" direct_modified_declaratorP)
+               ("[" fact_direct_modified_declarator1)
+               ("(" fact_direct_modified_declarator2))
+
+       (fact_direct_modified_declarator1
+               (constant_expr  "]" direct_modified_declaratorP)
+               ("]" direct_modified_declaratorP))
+
+       (fact_direct_modified_declarator2
+               (modified_declarator ")" direct_modified_declaratorP)
+               (parameter_type_list ")" direct_modified_declaratorP)
+               (")" direct_modified_declaratorP))
+
+       (direct_modified_declaratorP
+               ("[" fact_direct_modified_declaratorP1)
+               ("(" fact_direct_modified_declaratorP2)
+               ())
+
+       (fact_direct_modified_declaratorP1
+               (constant_expr  "]" direct_modified_declaratorP)
+               ("]" direct_modified_declaratorP))
+
+       (fact_direct_modified_declaratorP2
+               (parameter_type_list ")" direct_modified_declaratorP)
+               (")" direct_modified_declaratorP))
+
+       (type_name
+               (specifier_qualifier_list fact_type_name))
+
+       (fact_type_name
+               (abstract_declarator)
+               ())
+
+       (abstract_declarator
+               (pointer fact_abstract_declarator)
+               (direct_abstract_declarator))
+
+       (fact_abstract_declarator
+               (direct_abstract_declarator)
+               ())
+
+       (direct_abstract_declarator
+               ("[" fact_direct_abstract_declarator1)
+               ("(" fact_direct_abstract_declarator2))
+
+       (fact_direct_abstract_declarator1
+               (constant_expr "]" direct_abstract_declaratorP)
+               ("]" direct_abstract_declaratorP))
+
+       (fact_direct_abstract_declarator2
+               (abstract_declarator ")" direct_abstract_declaratorP)
+               (parameter_type_list ")" direct_abstract_declaratorP)
+               (")" direct_abstract_declaratorP))
+
+       (direct_abstract_declaratorP
+               ("[" fact_direct_abstract_declaratorP1)
+               ("(" fact_direct_abstract_declaratorP2)
+               ())
+
+       (fact_direct_abstract_declaratorP1
+               (constant_expr "]" direct_abstract_declaratorP)
+               ("]" direct_abstract_declaratorP))
+
+       (fact_direct_abstract_declaratorP2
+               (parameter_type_list ")" direct_abstract_declaratorP)
+               (")" direct_abstract_declaratorP))
+
+       (typedef_name
+               ("identifier"))
+
+       (initializer
+               (assignment_expr)
+               ("{" initializer_list fact_initializer))
+
+       (fact_initializer
+               ("}")
+               ("," "}"))
+
+       (initializer_list
+               (initializer initializer_listP))
+
+       (initializer_listP
+               ("," initializer initializer_listP)
+               ())
+
+       (statement
+               (labeled_statement)
+               (compound_statement)
+               (expression_statement)
+               (selection_statement)
+               (iteration_statement)
+               (jump_statement))
+
+       (labeled_statement
+               ("identifier" ":" statement)
+               ("case" constant_expr ":" statement)
+               ("default" ":" statement))
+
+       (compound_statement
+               ("{" fact_compound_statement))
+
+       (fact_compound_statement
+               (declaration_list fact_fact_compound_statement)
+               (statement_list "}")
+               ("}"))
+
+       (fact_fact_compound_statement
+               (statement_list "}")
+               ("}"))
+
+       (declaration_list
+               (declaration declaration_listP))
+
+       (declaration_listP
+               (declaration declaration_listP)
+               ())
+
+       (statement_list
+               (statement statement_listP))
+
+       (statement_listP
+               (statement statement_listP)
+               ())
+
+       (expression_statement
+               (expr ";")
+               (";"))
+
+       (selection_statement
+               ("if" "(" expr ")" statement fact_selection_statement)
+               ("switch" "(" expr ")" statement))
+
+       (fact_selection_statement
+               ("else" statement)
+               ())
+
+       (iteration_statement
+               ("while" "(" expr ")" statement)
+               ("do" statement "while" "(" expr ")" ";")
+               ("for" "(" OPT_EXPR ";" OPT_EXPR ";" OPT_EXPR ")" statement))
+
+       (jump_statement
+               ("goto" "identifier" ";")
+               ("continue" ";")
+               ("break" ";")
+               ("return" fact_jump_statement))
+
+       (fact_jump_statement
+               (";")
+               (expr ";"))
+
+       (translation_unit
+               (external_declaration translation_unitP))
+
+       (translation_unitP
+               (external_declaration translation_unitP)
+               ())
+
+       (external_declaration
+               (arbitrary_declaration))
+
+       (OPT_DECLARATION_LIST
+               (declaration_list)
+               ())
+
+       (arbitrary_declaration
+               (declaration_specifiers fact_arbitrary_declaration)
+               (declarator OPT_DECLARATION_LIST compound_statement))
+
+       (fact_arbitrary_declaration
+               (choice1)
+               (";"))
+
+       (choice1
+               (init_declarator fact_choice1))
+
+       (fact_choice1
+               ("," choice1)
+               (";")
+               (OPT_DECLARATION_LIST compound_statement))
+))
+
+------------------------------Cut Here---------------------------------------
+; f-f-d.s
+;
+; Computation of the LL(1) condition, LL(1) director sets,
+; and FIRST and FOLLOW sets.
+;
+; Grammars are represented as a list of entries, where each
+; entry is a list giving the productions for a nonterminal.
+; The first entry in the grammar must be for the start symbol.
+; The car of an entry is the nonterminal; the cdr is a list
+; of productions.  Each production is a list of grammar symbols
+; giving the right hand side for the production; the empty string
+; is represented by the empty list.
+; A nonterminal is represented as a Scheme symbol.
+; A terminal is represented as a Scheme string.
+;
+; Example:
+;
+;  (define g
+;    '((S ("id" ":=" E "\;")
+;         ("while" E S)
+;         ("do" S A "od"))
+;      (A ()
+;         (S A))
+;      (E (T E'))
+;      (E' () ("+" T E') ("-" T E'))
+;      (T (F T'))
+;      (T' () ("*" F T') ("/" F T'))
+;      (F ("id") ("(" E ")"))))
+
+; Given a grammar, returns #t if it is LL(1), else returns #f.
+
+(define (LL1? g)
+  (define (loop dsets)
+    (cond ((null? dsets) #t)
+          ((disjoint? (cdr (car dsets))) (loop (cdr dsets)))
+          (else (display "Failure of LL(1) condition ")
+                (write (car dsets))
+                (newline)
+                (loop (cdr dsets)))))
+  (define (disjoint? sets)
+    (cond ((null? sets) #t)
+          ((null? (car sets)) (disjoint? (cdr sets)))
+          ((member-remaining-sets? (caar sets) (cdr sets))
+           #f)
+          (else (disjoint? (cons (cdr (car sets)) (cdr sets))))))
+  (define (member-remaining-sets? x sets)
+    (cond ((null? sets) #f)
+          ((member x (car sets)) #t)
+          (else (member-remaining-sets? x (cdr sets)))))
+  (loop (director-sets g)))
+
+; Given a grammar, returns the director sets for each production.
+; In a director set, the end of file token is represented as the
+; Scheme symbol $.
+
+(define (director-sets g)
+  (let ((follows (follow-sets g)))
+    (map (lambda (p)
+           (let ((lhs (car p))
+                 (alternatives (cdr p)))
+             (cons lhs
+                   (map (lambda (rhs)
+                          (let ((f (first rhs g '())))
+                            (if (member "" f)
+                                (union (lookup lhs follows)
+                                       (remove "" f))
+                                f)))
+                        alternatives))))
+         g)))
+
+; Given a string of grammar symbols, a grammar, and a list of nonterminals
+; that have appeared in the leftmost position during the recursive
+; computation of FIRST(s), returns FIRST(s).
+; In the output, the empty string is represented as the Scheme string "".
+; Prints a warning message if left recursion is detected.
+
+(define (first s g recursion)
+  (cond ((null? s) '(""))
+        ((memq (car s) recursion)
+         (display "Left recursion for ")
+         (write (car s))
+         (newline)
+         '())
+        ((and (null? (cdr s)) (string? (car s))) s)
+        ((and (null? (cdr s)) (symbol? (car s)))
+         (let ((p (assoc (car s) g))
+               (newrecursion (cons (car s) recursion)))
+           (cond ((not p)
+                  (error "No production for " (car s)))
+                 (else (apply union
+                              (map (lambda (s) (first s g newrecursion))
+                                   (cdr p)))))))
+        (else (let ((x (first (list (car s)) g recursion)))
+                (if (member "" x)
+                    (append (remove "" x)
+                            (first (cdr s) g recursion))
+                    x)))))
+
+; Given a grammar g, returns FOLLOW(g).
+; In the output, the end of file token is represented as the Scheme
+; symbol $.
+; Warning messages will be printed if left recursion is detected.
+
+(define (follow-sets g)
+  
+  ; Uses a relaxation algorithm.
+  
+  (define (loop g table)
+    (let* ((new (map (lambda (x) (cons x (fol x g table)))
+                     (map car g)))
+           (new (cons (cons (caar new) (union '($) (cdar new)))
+                      (cdr new))))
+      (if (equal-table? table new)
+          table
+          (loop g new))))
+  
+  ; Given a nonterminal, a grammar, and a table giving
+  ; preliminary follow sets for all nonterminals, returns
+  ; the next approximation to the follow set for the given
+  ; nonterminal.
+  
+  (define (fol x g t)
+    (define (fol-production p)
+      (let ((lhs (car p))
+            (alternatives (cdr p)))
+        (do ((l alternatives (cdr l))
+             (f '() (union (fol-alternative x (car l)) f)))
+            ((null? l)
+             (if (member "" f)
+                 (union (lookup lhs t)
+                        (remove "" f))
+                 f)))))
+    (define (fol-alternative x rhs)
+      (cond ((null? rhs) '())
+            ((eq? x (car rhs))
+             (union (first (cdr rhs) g '())
+                    (fol-alternative x (cdr rhs))))
+            (else (fol-alternative x (cdr rhs)))))
+    (apply union (map fol-production g)))
+  
+  (loop g
+        (cons (list (caar g) '$)
+              (map (lambda (p) (cons (car p) '()))
+                   (cdr g)))))
+
+; Tables represented as association lists using eq? for equality.
+
+(define (lookup x t)
+  (cdr (assq x t)))
+
+(define (equal-table? x y)
+  (cond ((and (null? x) (null? y)) #t)
+        ((or (null? x) (null? y)) #f)
+        (else (let ((entry (assoc (caar x) y)))
+                (if entry
+                    (and (equal-as-sets? (cdr (car x)) (cdr entry))
+                         (equal-table? (cdr x) (remove entry y)))
+                    #f)))))
+
+; Sets represented as lists.
+
+(define (equal-as-sets? x y)
+  (and (every? (lambda (a) (member a y)) x)
+       (every? (lambda (a) (member a x)) y)))
+
+(define (union . args)
+  (define (union2 x y)
+    (cond ((null? x) y)
+          ((member (car x) y)
+           (union (cdr x) y))
+          (else (cons (car x)
+                      (union (cdr x) y)))))
+  (cond ((null? args) '())
+        ((null? (cdr args)) (car args))
+        ((null? (cddr args)) (union2 (car args) (cadr args)))
+        (else (union2 (union2 (car args) (cadr args))
+                      (apply union (cddr args))))))
+
+(define (every? p? l)
+  (cond ((null? l) #t)
+        ((p? (car l)) (every? p? (cdr l)))
+        (else #f)))
+
+ (define remove
+   (lambda (item ls)
+    (cond
+       ((null? ls) '())
+       ((equal? (car ls) item) (remove item (cdr ls)))
+       (else (cons (car ls) (remove item (cdr ls)))))))
+  (define pp-director-sets
+    (lambda (g)
+      (pp (director-sets g))))
+    
+  (define pp-follow-sets
+    (lambda (g)
+      (pp (follow-sets g))))
diff --git a/let.mes b/let.mes
index 70375643bd0c62174c3e8b0ba87a160c88106b34..b8d694a7a9a1439c1a00838d6479570144763818 100644 (file)
--- a/let.mes
+++ b/let.mes
      (set! ,label (lambda ,(map car bindings) ,@rest))
      (,label ,@(map cadr bindings))))
 
+;; COND
 (define-macro (let bindings-or-label . rest)
-  `(cond (,(symbol? bindings-or-label)
+  `(cond (,(symbol? bindings-or-label) ;; COND
           (xnamed-let ,bindings-or-label ,(car rest) ,(cdr rest)))
          (#t (xsimple-let ,bindings-or-label ,rest))))
 
+;; IF
+(define-macro (let bindings-or-label . rest)
+  `(if ,(symbol? bindings-or-label) ;; IF
+       (xnamed-let ,bindings-or-label ,(car rest) ,(cdr rest))
+       (xsimple-let ,bindings-or-label ,rest)))
+
 (define (expand-let* bindings body)
   (cond ((null? bindings)
          `((lambda () ,@body)))
index 9ef411848eb9ee4a78f7e93819f4cdb93aa825e5..be71317ebdb3af9478aec251aa1f32993d8ec73a 100644 (file)
@@ -4,7 +4,7 @@
   `(assq ,x (cddr (current-module))))
 
 (define (cond-expand-expander clauses)
-  (named-let loop ((clauses clauses))
+  (let loop ((clauses clauses))
     (if (defined? (caar clauses))
         (eval (cons 'begin (cdar clauses)) (current-module))
         (loop (cdr clauses)))))
diff --git a/mes.c b/mes.c
index 191b868d390cc3fc0194865c4a19be395ffaa68e..41dda0f4201a53f694044bad26c17e8db3a85bba 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -88,6 +88,7 @@ scm symbol_lambda = {SYMBOL, "lambda"};
 scm symbol_begin = {SYMBOL, "begin"};
 scm symbol_list = {SYMBOL, "list"};
 scm symbol_cond = {SYMBOL, "cond"};
+scm symbol_if = {SYMBOL, "if"};
 scm symbol_quote = {SYMBOL, "quote"};
 scm symbol_quasiquote = {SYMBOL, "quasiquote"};
 scm symbol_unquote = {SYMBOL, "unquote"};
@@ -386,19 +387,24 @@ eval (scm *e, scm *a)
         return make_closure (cadr (e), cddr (e), assq (&symbol_closure, a));
       if (car (e) == &symbol_closure)
         return e;
+      if ((macro = assq (&symbol_sc_expand, a)) != &scm_f)
+        if (cdr (macro) != &scm_f)
+          return eval (apply_env (cdr (macro), e, a), a);
+      if ((macro = lookup_macro (car (e), a)) != &scm_f)
+        return eval (apply_env (macro, cdr (e), a), a);
+#if COND
       if (car (e) == &symbol_cond)
         return evcon (cdr (e), a);
+#else
+      if (car (e) == &symbol_if)
+        return if_env (cdr (e), a);
+#endif
       if (eq_p (car (e), &symbol_define) == &scm_t)
         return define (e, a);
       if (eq_p (car (e), &symbol_define_macro) == &scm_t)
         return define (e, a);
       if (car (e) == &symbol_set_x)
         return set_env_x (cadr (e), eval (caddr (e), a), a);
-      if ((macro = assq (&symbol_sc_expand, a)) != &scm_f)
-        if (cdr (macro) != &scm_f)
-          return eval (apply_env (cdr (macro), e, a), a);
-      if ((macro = lookup_macro (car (e), a)) != &scm_f)
-        return eval (apply_env (macro, cdr (e), a), a);
       if (car (e) == &symbol_unquote)
         return eval (cadr (e), a);
       if (car (e) == &symbol_quasiquote)
@@ -424,6 +430,16 @@ evcon (scm *c, scm *a)
   return evcon (cdr (c), a);
 }
 
+scm *
+if_env (scm *e, scm *a)
+{
+  if (eval (car (e), a) != &scm_f)
+    return eval (cadr (e), a);
+  if (cddr (e) != &scm_nil)
+    return eval (caddr (e), a);
+  return &scm_unspecified;
+}
+
 scm *
 evlis (scm *m, scm *a)
 {
@@ -755,11 +771,13 @@ lookup (char *x, scm *a)
   if (!strcmp (x, scm_nil.name)) return &scm_nil;
   if (!strcmp (x, scm_t.name)) return &scm_t;
   if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified;
-
   if (!strcmp (x, symbol_begin.name)) return &symbol_begin;
   if (!strcmp (x, symbol_closure.name)) return &symbol_closure;
+#if COND
   if (!strcmp (x, symbol_cond.name)) return &symbol_cond;
-  if (!strcmp (x, symbol_current_module.name)) return &symbol_current_module;
+#else
+  if (!strcmp (x, symbol_if.name)) return &symbol_if;
+#endif
   if (!strcmp (x, symbol_lambda.name)) return &symbol_lambda;
 
   if (!strcmp (x, symbol_quasiquote.name)) return &symbol_quasiquote;
@@ -792,6 +810,10 @@ lookup (char *x, scm *a)
     fprintf (stderr, "mes: got EOF\n");
     return &scm_nil; // `EOF': eval program, which may read stdin
   }
+
+  // Hmm?
+  if (!strcmp (x, symbol_current_module.name)) return &symbol_current_module;
+
   return make_symbol (x);
 }
 
diff --git a/scm.mes b/scm.mes
index 3e22291d8d40418626af7b73030e46ea68160caf..fe22b8ee958da203241703fdd6d38a65394f6c05 100755 (executable)
--- a/scm.mes
+++ b/scm.mes
 
 (define (list . rest) rest)
 
-(define-macro (if expr then . else)
-  `(cond
-    (,expr ,then)
-    (#t (cond (,(pair? else) ((lambda () ,@else)))))))
-
 (define-macro (case val . args)
   (if (null? args)
       #f
 
 (define integer? number?)
 
-(define (equal? a b) ;; FIXME: only 2 arg
-  (cond ((and (null? a) (null? b)) #t)
-        ((and (pair? a) (pair? b))
-         (and (equal? (car a) (car b))
-              (equal? (cdr a) (cdr b))))
-        ((and (string? a) (string? b))
-         (eq? (string->symbol a) (string->symbol b)))
-        ((and (vector? a) (vector? b))
-         (equal? (vector->list a) (vector->list b)))
-        (#t (eq? a b))))
-
 (define (vector . rest) (list->vector rest))
 (define (make-vector n . x)
   (let ((fill (if (pair? x) (car x) *unspecified*)))
 (define assv-ref assq-ref)
 
 (define (assoc key alist)
-  (cond ((null? alist) #f)
+  (cond ((null? alist) #f) ;; COND
         ((equal? key (caar alist)) (car alist))
         (#t (assoc key (cdr alist)))))
 
+(define (assoc key alist)
+  (if (null? alist) #f ;; IF
+      (if (equal? key (caar alist)) (car alist)
+          (assoc key (cdr alist)))))
+
 (define (assoc-ref alist key)
   (let ((entry (assoc key alist)))
     (if entry (cdr entry)
         #f)))
 
 (define (memq x lst)
-  (cond ((null? lst) #f)
+  (cond ((null? lst) #f) ;; COND
         ((eq? x (car lst)) lst)
         (#t (memq x (cdr lst)))))
+
+(define (memq x lst)
+  (if (null? lst) #f ;; IF
+      (if (eq? x (car lst)) lst
+          (memq x (cdr lst)))))
 (define memv memq)
 
 (define (member x lst)
-  (cond ((null? lst) #f)
+  (cond ((null? lst) #f) ;; COND
         ((equal? x (car lst)) lst)
         (#t (member x (cdr lst)))))
 
-(define (map f l . r)
-  (cond ((null? l) '())
-        ((null? r) (cons (f (car l)) (map f (cdr l))))
-        ((null? (cdr r))
-         (cons (f (car l) (caar r)) (map f (cdr l) (cdar r))))))
+(define (member x lst)
+  (if (null? lst) #f ;; IF
+      (if (equal? x (car lst)) lst
+          (member x (cdr lst)))))
 
-(define (identity x) x)
 (define (for-each f l . r)
-  (cond ((null? l) '())
+  (cond ((null? l) '()) ;; COND
         ((null? r) (f (car l)) (for-each f (cdr l)))
         ((null? (cdr r))
          (for-each f (cdr l) (cdar r)))))
 
-(define (not x)
-  (cond (x #f)
-        (#t #t)))
+(define (for-each f l . r)
+  (if (null? l) '() ;; IF
+      (if (null? r) (begin (f (car l)) (for-each f (cdr l)))
+          (if (null? (cdr r))
+              (for-each f (cdr l) (cdar r))))))
 
 (define (<= . rest)
   (or (apply < rest)
   (or (apply > rest)
       (apply = rest)))
 
+;; (define (>= . rest)
+;;   (if (apply > rest) #t
+;;       (if (apply = rest) #t
+;;           #f)))
+
 (define quotient /)
 
 (define (remainder x y)
index c6dabfda21cedf7eb4066b1cf2ca50a44293922d..6de418068439e9c053b4986bb8c032b90b00ec44 100644 (file)
 (begin (define *top-begin-a* '*top-begin-a*))
 (pass-if "top begin " (seq? *top-begin-a* '*top-begin-a*))
 
+(pass-if "if" (seq? (if #t 'true) 'true))
+(pass-if "if 2" (seq? (if #f #f) *unspecified*))
+(pass-if "if 3" (seq? (if (seq? 0 '0) 'true 'false) 'true))
+(pass-if "if 4" (seq? (if (= 1 2) 'true 'false) 'false))
+
+;;(pass-if ">=" (seq? (>= 3 2 1) #t))
+
+(if (defined? 'cond)
+    (begin
+      (pass-if "cond" (seq? (cond (#f #f) (#t #t)) #t))
+      (pass-if "cond" (seq? (cond (#t)) #t))
+      (pass-if "cond 2" (seq? (cond (#f)) *unspecified*))
+      (pass-if "cond 3" (seq? (cond (#t 0)) 0))
+      (pass-if "cond 3" (seq? (cond (#f 1) (#t 0)) 0)))
+    )
+
 (pass-if "and" (seq? (and 1) 1))
 (pass-if "and 2" (seq? (and 1 (= 0 1) #f) #f))
 (pass-if "or" (seq? (or) #f))
 (pass-if "or 2" (seq? (or 1) 1))
 (pass-if "or 3" (seq? (or #f (= 0 1) 3) 3))
+(pass-if "or 4" (seq? (or (= 0 0) (= 0 1)) #t))
+(pass-if "or 5" (seq? (or (= 0 1) (= 0 0)) #t))
 (pass-if "let" (seq? (let () 0) 0))
 (pass-if "let 2" (seq? (let ((x 0)) x) 0))
 (pass-if "let 3" (seq? (let ((p 5) (q 6)) (+ p q)) 11))
index b44374b88b873ec797736ce16168405f3e0541c8..520f79820cfe9ba21acc14d9902740ea44ad005f 100644 (file)
 (pass-if "first dummy" #t)
 (pass-if-not "second dummy" #f)
 
-(pass-if "if" (seq? (if #t 'true) 'true))
-(pass-if "if 2" (seq? (if (seq? 0 '0) 'true 'false) 'true))
-(pass-if "if 3" (seq? (if (= 1 2) 'true 'false) 'false))
-
 (pass-if "when" (seq? (when #t 'true) 'true))
 (pass-if "when 2" (seq? (when #f 'true) *unspecified*))