From 287c0284fe704a672a201b7668d7a5275576b939 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 27 Jul 2016 08:49:45 +0200 Subject: [PATCH] Use IF iso COND as primitive; keep COND primitive as option. --- GNUmakefile | 34 +- base.mes | 83 +++-- base0-cond.mes | 31 ++ base0-if.mes | 40 +++ cgram-ll1 | 825 ++++++++++++++++++++++++++++++++++++++++++++ let.mes | 9 +- lib/srfi/srfi-0.scm | 2 +- mes.c | 36 +- scm.mes | 57 ++- test/base.test | 18 + test/scm.test | 4 - 11 files changed, 1057 insertions(+), 82 deletions(-) create mode 100644 base0-cond.mes create mode 100644 base0-if.mes create mode 100644 cgram-ll1 diff --git a/GNUmakefile b/GNUmakefile index 52eae275..33ea193d 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -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 $^ > $@ diff --git a/base.mes b/base.mes index a388a8a5..31bcda13 100644 --- a/base.mes +++ b/base.mes @@ -21,39 +21,26 @@ (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)))) @@ -64,16 +51,56 @@ (#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 index 00000000..6d6b21ce --- /dev/null +++ b/base0-cond.mes @@ -0,0 +1,31 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +(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 index 00000000..7a7280b7 --- /dev/null +++ b/base0-if.mes @@ -0,0 +1,40 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +(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 index 00000000..2c23d511 --- /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 70375643..b8d694a7 100644 --- a/let.mes +++ b/let.mes @@ -42,11 +42,18 @@ (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))) diff --git a/lib/srfi/srfi-0.scm b/lib/srfi/srfi-0.scm index 9ef41184..be71317e 100644 --- a/lib/srfi/srfi-0.scm +++ b/lib/srfi/srfi-0.scm @@ -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 191b868d..41dda0f4 100644 --- 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 3e22291d..fe22b8ee 100755 --- a/scm.mes +++ b/scm.mes @@ -20,11 +20,6 @@ (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 @@ -57,17 +52,6 @@ (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*))) @@ -90,42 +74,52 @@ (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) @@ -135,6 +129,11 @@ (or (apply > rest) (apply = rest))) +;; (define (>= . rest) +;; (if (apply > rest) #t +;; (if (apply = rest) #t +;; #f))) + (define quotient /) (define (remainder x y) diff --git a/test/base.test b/test/base.test index c6dabfda..6de41806 100644 --- a/test/base.test +++ b/test/base.test @@ -27,11 +27,29 @@ (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)) diff --git a/test/scm.test b/test/scm.test index b44374b8..520f7982 100644 --- a/test/scm.test +++ b/test/scm.test @@ -26,10 +26,6 @@ (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*))