artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Use IF iso COND as primitive; keep COND primitive as option.

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-07-27 08:49:45 +02:00
parent af1b6dc88d
commit 287c0284fe
11 changed files with 1057 additions and 82 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
GNUmakefile
View 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 $^ > $@

83
base.mes
View file

@ -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)))

31
base0-cond.mes Normal file
View file

@ -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)))

40
base0-if.mes Normal file
View file

@ -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

825
cgram-ll1 Normal file
View file

@ -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))))

9
let.mes
View file

@ -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)))

2
lib/srfi/srfi-0.scm
View 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)))))

36
mes.c
View file

@ -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);
}

57
scm.mes
View file

@ -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)

18
test/base.test
View file

@ -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))

4
test/scm.test
View file

@ -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*))