use IF as primitive, drop using cond/evcon only option.
This commit is contained in:
Jan Nieuwenhuizen
parent
7c759e0670
commit
4514be76d9
41
GNUmakefile
41
GNUmakefile
|
|
@ -2,15 +2,6 @@
|
||||||
CFLAGS:=-std=c99 -O3 -finline-functions
|
CFLAGS:=-std=c99 -O3 -finline-functions
|
||||||
#CFLAGS:=-std=c99 -g
|
#CFLAGS:=-std=c99 -g
|
||||||
|
|
||||||
COND:=0
|
|
||||||
ifeq ($(COND),1)
|
|
||||||
CONDIF:=cond
|
|
||||||
else
|
|
||||||
CONDIF:=if
|
|
||||||
endif
|
|
||||||
|
|
||||||
CFLAGS+=-DCOND=$(COND)
|
|
||||||
|
|
||||||
default: all
|
default: all
|
||||||
|
|
||||||
all: mes
|
all: mes
|
||||||
|
|
@ -48,11 +39,11 @@ check: all guile-check mes-check
|
||||||
mes-check: all
|
mes-check: all
|
||||||
# ./mes.test
|
# ./mes.test
|
||||||
# ./mes.test ./mes
|
# ./mes.test ./mes
|
||||||
cat base0.mes base0-$(CONDIF).mes base.mes lib/test.mes test/base.test | ./mes
|
cat base0.mes base0-if.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-if.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-if.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-if.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
|
cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes lib/srfi/srfi-0.scm scm.mes lib/test.mes test/scm.test | ./mes
|
||||||
|
|
||||||
guile-check:
|
guile-check:
|
||||||
guile -s <(cat base.mes lib/test.mes test/base.test)
|
guile -s <(cat base.mes lib/test.mes test/base.test)
|
||||||
|
|
@ -73,31 +64,31 @@ run: all
|
||||||
cat scm.mes test.mes | ./mes
|
cat scm.mes test.mes | ./mes
|
||||||
|
|
||||||
psyntax: all
|
psyntax: all
|
||||||
cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
|
cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
|
||||||
|
|
||||||
syntax: all
|
syntax: all
|
||||||
cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax-cond.mes syntax-test.mes | ./mes
|
cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes syntax-test.mes | ./mes
|
||||||
|
|
||||||
syntax.test: syntax-cond.mes syntax-test.mes
|
syntax.test: syntax.mes syntax-test.mes
|
||||||
cat $^ > $@
|
cat $^ > $@
|
||||||
|
|
||||||
guile-syntax: syntax.test
|
guile-syntax: syntax.test
|
||||||
guile -s $^
|
guile -s $^
|
||||||
|
|
||||||
syntax-case: all
|
syntax-case: all
|
||||||
cat scm.mes syntax-cond.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes | ./mes
|
cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes | ./mes
|
||||||
|
|
||||||
syntax-case.test: syntax-cond.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes
|
syntax-case.test: syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes
|
||||||
cat $^ > $@
|
cat $^ > $@
|
||||||
|
|
||||||
guile-syntax-case: syntax-case.test
|
guile-syntax-case: syntax-case.test
|
||||||
guile -s $^
|
guile -s $^
|
||||||
|
|
||||||
macro: all
|
macro: all
|
||||||
cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes
|
cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes
|
||||||
|
|
||||||
peg: all
|
peg: all
|
||||||
cat scm.mes syntax-cond.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
|
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
|
||||||
|
|
||||||
peg.test: peg/pmatch.scm peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes
|
peg.test: peg/pmatch.scm peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes
|
||||||
cat $^ | sed 's,\(;; Packages the results of a parser\),(when (guile?) (set! compile-peg-pattern (@@ (ice-9 peg codegen) compile-peg-pattern)))\n\1,' > $@
|
cat $^ | sed 's,\(;; Packages the results of a parser\),(when (guile?) (set! compile-peg-pattern (@@ (ice-9 peg codegen) compile-peg-pattern)))\n\1,' > $@
|
||||||
|
|
@ -111,11 +102,11 @@ clean:
|
||||||
rm -f mes environment.i mes.h peg.test syntax.test
|
rm -f mes environment.i mes.h peg.test syntax.test
|
||||||
|
|
||||||
record: all
|
record: all
|
||||||
cat scm.mes syntax-cond.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes
|
cat scm.mes syntax.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes
|
||||||
|
|
||||||
|
|
||||||
paren: all
|
paren: all
|
||||||
echo -e 'EOF\n___P((()))' | cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax-cond.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-if.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
|
paren.test: lib/lalr.scm paren.scm
|
||||||
cat $^ > $@
|
cat $^ > $@
|
||||||
|
|
@ -124,7 +115,7 @@ guile-paren: paren.test
|
||||||
echo '___P((()))' | guile -s $^
|
echo '___P((()))' | guile -s $^
|
||||||
|
|
||||||
mescc: all
|
mescc: all
|
||||||
echo ' EOF ' | cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax-cond.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm lib/elf.mes c-lexer.scm mescc.scm - main.c | ./mes > a.out
|
echo ' EOF ' | cat base0.mes base0-if.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 lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm lib/elf.mes c-lexer.scm mescc.scm - main.c | ./mes > a.out
|
||||||
chmod +x a.out
|
chmod +x a.out
|
||||||
|
|
||||||
mescc.test: lib/lalr.scm lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm lib/elf.mes c-lexer.scm mescc.scm
|
mescc.test: lib/lalr.scm lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm lib/elf.mes c-lexer.scm mescc.scm
|
||||||
|
|
@ -142,5 +133,5 @@ hello: hello.o
|
||||||
# ld -A i386 -m elf_i386 -A i386 -o $@ $^
|
# ld -A i386 -m elf_i386 -A i386 -o $@ $^
|
||||||
|
|
||||||
a.out: lib/elf.mes elf.mes GNUmakefile
|
a.out: lib/elf.mes elf.mes GNUmakefile
|
||||||
cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes lib/rnrs/bytevectors.scm lib/elf.mes elf.mes | ./mes > a.out
|
cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes lib/rnrs/bytevectors.scm lib/elf.mes elf.mes | ./mes > a.out
|
||||||
chmod +x a.out
|
chmod +x a.out
|
||||||
|
|
|
||||||
40
base.mes
40
base.mes
|
|
@ -21,46 +21,6 @@
|
||||||
(define (identity x) x)
|
(define (identity x) x)
|
||||||
(define else #t)
|
(define else #t)
|
||||||
|
|
||||||
;;; COND based
|
|
||||||
(define-macro (or . x)
|
|
||||||
(cond ;; COND
|
|
||||||
((null? x) #f)
|
|
||||||
((null? (cdr x)) (car x))
|
|
||||||
(#t (list 'cond (list (car x)) ;; COND
|
|
||||||
(list #t (cons 'or (cdr x)))))))
|
|
||||||
|
|
||||||
(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 (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 (memq x lst)
|
|
||||||
(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? 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
|
;; IF based
|
||||||
(define-macro (or . x)
|
(define-macro (or . x)
|
||||||
(if (null? x) #f ;; IF
|
(if (null? x) #f ;; IF
|
||||||
|
|
|
||||||
|
|
@ -1,31 +0,0 @@
|
||||||
;;; -*-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)))
|
|
||||||
|
|
@ -24,7 +24,7 @@
|
||||||
(cons (car rest) (loop (cdr rest)))))
|
(cons (car rest) (loop (cdr rest)))))
|
||||||
(loop (cons x rest)))
|
(loop (cons x rest)))
|
||||||
|
|
||||||
(define-macro cond
|
(define-macro xcond ;; using evcon: 50% speedup (cond in syntax.mes)
|
||||||
(lambda clauses
|
(lambda clauses
|
||||||
(if (null? clauses) *unspecified* ;; IF
|
(if (null? clauses) *unspecified* ;; IF
|
||||||
(if (null? (cdr clauses)) ;; IF
|
(if (null? (cdr clauses)) ;; IF
|
||||||
|
|
|
||||||
33
let.mes
33
let.mes
|
|
@ -28,10 +28,9 @@
|
||||||
(,label ,@(map cadr bindings))))
|
(,label ,@(map cadr bindings))))
|
||||||
|
|
||||||
(define-macro (let bindings-or-label . rest)
|
(define-macro (let bindings-or-label . rest)
|
||||||
`(`,(cond (,(symbol? bindings-or-label)
|
`(`,(if ,(symbol? bindings-or-label)
|
||||||
(list 'lambda '() (cons* 'named-let ,bindings-or-label ,(car rest) ,(cdr rest))))
|
(list 'lambda '() (cons* 'named-let ,bindings-or-label ,(car rest) ,(cdr rest)))
|
||||||
(#t
|
(list 'lambda '() (cons* 'simple-let ,bindings-or-label ,rest)))))
|
||||||
(list 'lambda '() (cons* 'simple-let ,bindings-or-label ,rest))))))
|
|
||||||
|
|
||||||
(define-macro (xsimple-let bindings rest)
|
(define-macro (xsimple-let bindings rest)
|
||||||
`(,`(lambda ,(map car bindings) ,@rest)
|
`(,`(lambda ,(map car bindings) ,@rest)
|
||||||
|
|
@ -42,12 +41,6 @@
|
||||||
(set! ,label (lambda ,(map car bindings) ,@rest))
|
(set! ,label (lambda ,(map car bindings) ,@rest))
|
||||||
(,label ,@(map cadr bindings))))
|
(,label ,@(map cadr bindings))))
|
||||||
|
|
||||||
;; COND
|
|
||||||
(define-macro (let bindings-or-label . rest)
|
|
||||||
`(cond (,(symbol? bindings-or-label) ;; COND
|
|
||||||
(xnamed-let ,bindings-or-label ,(car rest) ,(cdr rest)))
|
|
||||||
(#t (xsimple-let ,bindings-or-label ,rest))))
|
|
||||||
|
|
||||||
;; IF
|
;; IF
|
||||||
(define-macro (let bindings-or-label . rest)
|
(define-macro (let bindings-or-label . rest)
|
||||||
`(if ,(symbol? bindings-or-label) ;; IF
|
`(if ,(symbol? bindings-or-label) ;; IF
|
||||||
|
|
@ -55,26 +48,26 @@
|
||||||
(xsimple-let ,bindings-or-label ,rest)))
|
(xsimple-let ,bindings-or-label ,rest)))
|
||||||
|
|
||||||
(define (expand-let* bindings body)
|
(define (expand-let* bindings body)
|
||||||
(cond ((null? bindings)
|
(if (null? bindings)
|
||||||
`((lambda () ,@body)))
|
`((lambda () ,@body))
|
||||||
(#t `((lambda (,(caar bindings))
|
`((lambda (,(caar bindings))
|
||||||
,(expand-let* (cdr bindings) body))
|
,(expand-let* (cdr bindings) body))
|
||||||
,@(cdar bindings)))))
|
,@(cdar bindings))))
|
||||||
|
|
||||||
(define-macro (let* bindings . body)
|
(define-macro (let* bindings . body)
|
||||||
(expand-let* bindings body))
|
(expand-let* bindings body))
|
||||||
|
|
||||||
(define (unspecified-bindings bindings params)
|
(define (unspecified-bindings bindings params)
|
||||||
(cond ((null? bindings) params)
|
(if (null? bindings) params
|
||||||
(#t (unspecified-bindings
|
(unspecified-bindings
|
||||||
(cdr bindings)
|
(cdr bindings)
|
||||||
(append params (cons (cons (caar bindings) '(*unspecified*)) '()))))))
|
(append params (cons (cons (caar bindings) '(*unspecified*)) '())))))
|
||||||
|
|
||||||
(define (letrec-setters bindings setters)
|
(define (letrec-setters bindings setters)
|
||||||
(cond ((null? bindings) setters)
|
(if (null? bindings) setters
|
||||||
(#t (letrec-setters (cdr bindings)
|
(letrec-setters (cdr bindings)
|
||||||
(append setters
|
(append setters
|
||||||
(cons (cons 'set! (car bindings)) '()))))))
|
(cons (cons 'set! (car bindings)) '())))))
|
||||||
|
|
||||||
(define-macro (letrec bindings . body)
|
(define-macro (letrec bindings . body)
|
||||||
`(let ,(unspecified-bindings bindings '())
|
`(let ,(unspecified-bindings bindings '())
|
||||||
|
|
|
||||||
5
mes.c
5
mes.c
|
|
@ -375,13 +375,12 @@ eval (scm *e, scm *a)
|
||||||
return eval (apply_env (cdr (macro), e, a), a);
|
return eval (apply_env (cdr (macro), e, a), a);
|
||||||
if ((macro = lookup_macro (car (e), a)) != &scm_f)
|
if ((macro = lookup_macro (car (e), a)) != &scm_f)
|
||||||
return eval (apply_env (macro, cdr (e), a), a);
|
return eval (apply_env (macro, cdr (e), a), a);
|
||||||
#if COND
|
#if 1 //COND
|
||||||
if (car (e) == &symbol_cond)
|
if (car (e) == &symbol_cond)
|
||||||
return evcon (cdr (e), a);
|
return evcon (cdr (e), a);
|
||||||
#else
|
#endif
|
||||||
if (car (e) == &symbol_if)
|
if (car (e) == &symbol_if)
|
||||||
return if_env (cdr (e), a);
|
return if_env (cdr (e), a);
|
||||||
#endif
|
|
||||||
if (eq_p (car (e), &symbol_define) == &scm_t)
|
if (eq_p (car (e), &symbol_define) == &scm_t)
|
||||||
return define (e, a);
|
return define (e, a);
|
||||||
if (eq_p (car (e), &symbol_define_macro) == &scm_t)
|
if (eq_p (car (e), &symbol_define_macro) == &scm_t)
|
||||||
|
|
|
||||||
21
scm.mes
21
scm.mes
|
|
@ -84,11 +84,6 @@
|
||||||
(define assv assq)
|
(define assv assq)
|
||||||
(define assv-ref assq-ref)
|
(define assv-ref assq-ref)
|
||||||
|
|
||||||
(define (assoc key alist)
|
|
||||||
(cond ((null? alist) #f) ;; COND
|
|
||||||
((equal? key (caar alist)) (car alist))
|
|
||||||
(#t (assoc key (cdr alist)))))
|
|
||||||
|
|
||||||
(define (assoc key alist)
|
(define (assoc key alist)
|
||||||
(if (null? alist) #f ;; IF
|
(if (null? alist) #f ;; IF
|
||||||
(if (equal? key (caar alist)) (car alist)
|
(if (equal? key (caar alist)) (car alist)
|
||||||
|
|
@ -99,33 +94,17 @@
|
||||||
(if entry (cdr entry)
|
(if entry (cdr entry)
|
||||||
#f)))
|
#f)))
|
||||||
|
|
||||||
(define (memq x lst)
|
|
||||||
(cond ((null? lst) #f) ;; COND
|
|
||||||
((eq? x (car lst)) lst)
|
|
||||||
(#t (memq x (cdr lst)))))
|
|
||||||
|
|
||||||
(define (memq x lst)
|
(define (memq x lst)
|
||||||
(if (null? lst) #f ;; IF
|
(if (null? lst) #f ;; IF
|
||||||
(if (eq? x (car lst)) lst
|
(if (eq? x (car lst)) lst
|
||||||
(memq x (cdr lst)))))
|
(memq x (cdr lst)))))
|
||||||
(define memv memq)
|
(define memv memq)
|
||||||
|
|
||||||
(define (member x lst)
|
|
||||||
(cond ((null? lst) #f) ;; COND
|
|
||||||
((equal? x (car lst)) lst)
|
|
||||||
(#t (member x (cdr lst)))))
|
|
||||||
|
|
||||||
(define (member x lst)
|
(define (member x lst)
|
||||||
(if (null? lst) #f ;; IF
|
(if (null? lst) #f ;; IF
|
||||||
(if (equal? x (car lst)) lst
|
(if (equal? x (car lst)) lst
|
||||||
(member x (cdr lst)))))
|
(member x (cdr lst)))))
|
||||||
|
|
||||||
(define (for-each f l . r)
|
|
||||||
(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 (for-each f l . r)
|
(define (for-each f l . r)
|
||||||
(if (null? l) '() ;; IF
|
(if (null? l) '() ;; IF
|
||||||
(if (null? r) (begin (f (car l)) (for-each f (cdr l)))
|
(if (null? r) (begin (f (car l)) (for-each f (cdr l)))
|
||||||
|
|
|
||||||
238
syntax-if.mes
238
syntax-if.mes
|
|
@ -1,238 +0,0 @@
|
||||||
;; -*-scheme-*-
|
|
||||||
|
|
||||||
(define (syntax-error message thing)
|
|
||||||
(display "syntax-error:")
|
|
||||||
(display message)
|
|
||||||
(display ":")
|
|
||||||
(display thing)
|
|
||||||
(newline))
|
|
||||||
|
|
||||||
;;; Adapted from scheme48-1.1/scheme/alt/syntax.scm
|
|
||||||
|
|
||||||
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
||||||
|
|
||||||
;;; scheme48-1.1/COPYING
|
|
||||||
|
|
||||||
;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
|
|
||||||
;; All rights reserved.
|
|
||||||
|
|
||||||
;; Redistribution and use in source and binary forms, with or without
|
|
||||||
;; modification, are permitted provided that the following conditions
|
|
||||||
;; are met:
|
|
||||||
;; 1. Redistributions of source code must retain the above copyright
|
|
||||||
;; notice, this list of conditions and the following disclaimer.
|
|
||||||
;; 2. Redistributions in binary form must reproduce the above copyright
|
|
||||||
;; notice, this list of conditions and the following disclaimer in the
|
|
||||||
;; documentation and/or other materials provided with the distribution.
|
|
||||||
;; 3. The name of the authors may not be used to endorse or promote products
|
|
||||||
;; derived from this software without specific prior written permission.
|
|
||||||
|
|
||||||
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
|
||||||
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
|
||||||
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
|
||||||
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
|
||||||
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
|
||||||
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
||||||
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
||||||
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
||||||
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
|
||||||
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
|
|
||||||
|
|
||||||
(define-macro (define-syntax macro-name transformer . stuff)
|
|
||||||
`(define-macro (,macro-name . args)
|
|
||||||
(,transformer (cons ',macro-name args)
|
|
||||||
(lambda (x) x)
|
|
||||||
eq?)))
|
|
||||||
|
|
||||||
;; Rewrite-rule compiler (a.k.a. "extend-syntax")
|
|
||||||
|
|
||||||
;; Example:
|
|
||||||
;;
|
|
||||||
;; (define-syntax or
|
|
||||||
;; (syntax-rules ()
|
|
||||||
;; ((or) #f)
|
|
||||||
;; ((or e) e)
|
|
||||||
;; ((or e1 e ...) (let ((temp e1))
|
|
||||||
;; (if temp temp (or e ...))))))
|
|
||||||
|
|
||||||
(define-syntax syntax-rules
|
|
||||||
(let ()
|
|
||||||
(define name? symbol?)
|
|
||||||
|
|
||||||
(define (segment-pattern? pattern)
|
|
||||||
(and (segment-template? pattern)
|
|
||||||
(or (null? (cddr pattern))
|
|
||||||
(syntax-error "segment matching not implemented" pattern))))
|
|
||||||
|
|
||||||
(define (segment-template? pattern)
|
|
||||||
(and (pair? pattern)
|
|
||||||
(pair? (cdr pattern))
|
|
||||||
(memq (cadr pattern) indicators-for-zero-or-more)))
|
|
||||||
|
|
||||||
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
|
|
||||||
|
|
||||||
(lambda (exp r c)
|
|
||||||
|
|
||||||
(define %input (r '%input)) ;Gensym these, if you like.
|
|
||||||
(define %compare (r '%compare))
|
|
||||||
(define %rename (r '%rename))
|
|
||||||
(define %tail (r '%tail))
|
|
||||||
(define %temp (r '%temp))
|
|
||||||
|
|
||||||
(define rules (cddr exp))
|
|
||||||
(define subkeywords (cadr exp))
|
|
||||||
|
|
||||||
(define (make-transformer rules)
|
|
||||||
`(lambda (,%input ,%rename ,%compare)
|
|
||||||
(let ((,%tail (cdr ,%input)))
|
|
||||||
(cond ,@(map process-rule rules)
|
|
||||||
(else
|
|
||||||
(syntax-error
|
|
||||||
"use of macro doesn't match definition"
|
|
||||||
,%input))))))
|
|
||||||
|
|
||||||
(define (process-rule rule)
|
|
||||||
(if (and (pair? rule)
|
|
||||||
(pair? (cdr rule))
|
|
||||||
(null? (cddr rule)))
|
|
||||||
(let ((pattern (cdar rule))
|
|
||||||
(template (cadr rule)))
|
|
||||||
`((and ,@(process-match %tail pattern))
|
|
||||||
(let* ,(process-pattern pattern
|
|
||||||
%tail
|
|
||||||
(lambda (x) x))
|
|
||||||
,(process-template template
|
|
||||||
0
|
|
||||||
(meta-variables pattern 0 '())))))
|
|
||||||
(syntax-error "ill-formed syntax rule" rule)))
|
|
||||||
|
|
||||||
;; Generate code to test whether input expression matches pattern
|
|
||||||
|
|
||||||
(define (process-match input pattern)
|
|
||||||
(cond ((name? pattern)
|
|
||||||
(if (member pattern subkeywords)
|
|
||||||
`((,%compare ,input (,%rename ',pattern)))
|
|
||||||
`()))
|
|
||||||
((segment-pattern? pattern)
|
|
||||||
(process-segment-match input (car pattern)))
|
|
||||||
((pair? pattern)
|
|
||||||
`((let ((,%temp ,input))
|
|
||||||
(and (pair? ,%temp)
|
|
||||||
,@(process-match `(car ,%temp) (car pattern))
|
|
||||||
,@(process-match `(cdr ,%temp) (cdr pattern))))))
|
|
||||||
((or (null? pattern) (boolean? pattern) (char? pattern))
|
|
||||||
`((eq? ,input ',pattern)))
|
|
||||||
(else
|
|
||||||
`((equal? ,input ',pattern)))))
|
|
||||||
|
|
||||||
(define (process-segment-match input pattern)
|
|
||||||
(let ((conjuncts (process-match '(car l) pattern)))
|
|
||||||
(if (null? conjuncts)
|
|
||||||
`((list? ,input)) ;+++
|
|
||||||
`((let loop ((l ,input))
|
|
||||||
(or (null? l)
|
|
||||||
(and (pair? l)
|
|
||||||
,@conjuncts
|
|
||||||
(loop (cdr l)))))))))
|
|
||||||
|
|
||||||
;; Generate code to take apart the input expression
|
|
||||||
;; This is pretty bad, but it seems to work (can't say why).
|
|
||||||
|
|
||||||
(define (process-pattern pattern path mapit)
|
|
||||||
(cond ((name? pattern)
|
|
||||||
(if (memq pattern subkeywords)
|
|
||||||
'()
|
|
||||||
(list (list pattern (mapit path)))))
|
|
||||||
((segment-pattern? pattern)
|
|
||||||
(process-pattern (car pattern)
|
|
||||||
%temp
|
|
||||||
(lambda (x) ;temp is free in x
|
|
||||||
(mapit (if (eq? %temp x)
|
|
||||||
path ;+++
|
|
||||||
`(map (lambda (,%temp) ,x)
|
|
||||||
,path))))))
|
|
||||||
((pair? pattern)
|
|
||||||
(append (process-pattern (car pattern) `(car ,path) mapit)
|
|
||||||
(process-pattern (cdr pattern) `(cdr ,path) mapit)))
|
|
||||||
(else '())))
|
|
||||||
|
|
||||||
;; Generate code to compose the output expression according to template
|
|
||||||
|
|
||||||
(define (process-template template rank env)
|
|
||||||
(cond ((name? template)
|
|
||||||
(let ((probe (assq template env)))
|
|
||||||
(if probe
|
|
||||||
(if (<= (cdr probe) rank)
|
|
||||||
template
|
|
||||||
(syntax-error "template rank error (too few ...'s?)"
|
|
||||||
template))
|
|
||||||
`(,%rename ',template))))
|
|
||||||
((segment-template? template)
|
|
||||||
(let ((vars
|
|
||||||
(free-meta-variables (car template) (+ rank 1) env '())))
|
|
||||||
(if (null? vars)
|
|
||||||
(syntax-error "too many ...'s" template)
|
|
||||||
(let* ((x (process-template (car template)
|
|
||||||
(+ rank 1)
|
|
||||||
env))
|
|
||||||
(gen (if (equal? (list x) vars)
|
|
||||||
x ;+++
|
|
||||||
`(map (lambda ,vars ,x)
|
|
||||||
,@vars))))
|
|
||||||
(if (null? (cddr template))
|
|
||||||
gen ;+++
|
|
||||||
`(append ,gen ,(process-template (cddr template)
|
|
||||||
rank env)))))))
|
|
||||||
((pair? template)
|
|
||||||
`(cons ,(process-template (car template) rank env)
|
|
||||||
,(process-template (cdr template) rank env)))
|
|
||||||
(else `(quote ,template))))
|
|
||||||
|
|
||||||
;; Return an association list of (var . rank)
|
|
||||||
|
|
||||||
(define (meta-variables pattern rank vars)
|
|
||||||
(cond ((name? pattern)
|
|
||||||
(if (memq pattern subkeywords)
|
|
||||||
vars
|
|
||||||
(cons (cons pattern rank) vars)))
|
|
||||||
((segment-pattern? pattern)
|
|
||||||
(meta-variables (car pattern) (+ rank 1) vars))
|
|
||||||
((pair? pattern)
|
|
||||||
(meta-variables (car pattern) rank
|
|
||||||
(meta-variables (cdr pattern) rank vars)))
|
|
||||||
(else vars)))
|
|
||||||
|
|
||||||
;; Return a list of meta-variables of given higher rank
|
|
||||||
|
|
||||||
(define (free-meta-variables template rank env free)
|
|
||||||
(cond ((name? template)
|
|
||||||
(if (and (not (memq template free))
|
|
||||||
(let ((probe (assq template env)))
|
|
||||||
(and probe (>= (cdr probe) rank))))
|
|
||||||
(cons template free)
|
|
||||||
free))
|
|
||||||
((segment-template? template)
|
|
||||||
(free-meta-variables (car template)
|
|
||||||
rank env
|
|
||||||
(free-meta-variables (cddr template)
|
|
||||||
rank env free)))
|
|
||||||
((pair? template)
|
|
||||||
(free-meta-variables (car template)
|
|
||||||
rank env
|
|
||||||
(free-meta-variables (cdr template)
|
|
||||||
rank env free)))
|
|
||||||
(else free)))
|
|
||||||
|
|
||||||
c ;ignored
|
|
||||||
|
|
||||||
;; Kludge for Scheme48 linker.
|
|
||||||
;; `(cons ,(make-transformer rules)
|
|
||||||
;; ',(find-free-names-in-syntax-rules subkeywords rules))
|
|
||||||
|
|
||||||
(make-transformer rules))))
|
|
||||||
|
|
||||||
(define-macro (define-syntax-rule id-pattern . template)
|
|
||||||
`(define-syntax ,(car id-pattern)
|
|
||||||
(syntax-rules ()
|
|
||||||
((,(car id-pattern) . ,(cdr id-pattern)) ,@template))))
|
|
||||||
Loading…
Reference in a new issue