andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

syntax.mes: use cond iso if. rode harink

This commit is contained in:
Jan Nieuwenhuizen 2016-07-17 11:53:37 +02:00
parent 341d064a34
commit 6f40e02029
1 changed files with 57 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
syntax.mes
View File

@ -143,7 +143,7 @@
,%input)))))) ,%input))))))
(define (process-rule rule) (define (process-rule rule)
(if (and (pair? rule) (cond ((and (pair? rule)
(pair? (cdr rule)) (pair? (cdr rule))
(null? (cddr rule))) (null? (cddr rule)))
(let ((pattern (cdar rule)) (let ((pattern (cdar rule))
@ -154,16 +154,16 @@
(lambda (x) x)) (lambda (x) x))
,(process-template template ,(process-template template
0 0
(meta-variables pattern 0 '()))))) (meta-variables pattern 0 '()))))))
(syntax-error "ill-formed syntax rule" rule))) (syntax-error "ill-formed syntax rule" rule)))
;; Generate code to test whether input expression matches pattern ;; Generate code to test whether input expression matches pattern
(define (process-match input pattern) (define (process-match input pattern)
(cond ((name? pattern) (cond ((name? pattern)
(if (member pattern subkeywords) (cond ((member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern))) `((,%compare ,input (,%rename ',pattern))))
`())) (#t `())))
((segment-pattern? pattern) ((segment-pattern? pattern)
(process-segment-match input (car pattern))) (process-segment-match input (car pattern)))
((pair? pattern) ((pair? pattern)
@ -178,30 +178,30 @@
(define (process-segment-match input pattern) (define (process-segment-match input pattern)
(let ((conjuncts (process-match '(car l) pattern))) (let ((conjuncts (process-match '(car l) pattern)))
(if (null? conjuncts) (cond ((null? conjuncts)
`((list? ,input)) ;+++ `((list? ,input))) ;+++
`((let loop ((l ,input)) (#t `((let loop ((l ,input))
(or (null? l) (or (null? l)
(and (pair? l) (and (pair? l)
,@conjuncts ,@conjuncts
(loop (cdr l))))))))) (loop (cdr l))))))))))
;; Generate code to take apart the input expression ;; Generate code to take apart the input expression
;; This is pretty bad, but it seems to work (can't say why). ;; This is pretty bad, but it seems to work (can't say why).
(define (process-pattern pattern path mapit) (define (process-pattern pattern path mapit)
(cond ((name? pattern) (cond ((name? pattern)
(if (memq pattern subkeywords) (cond ((memq pattern subkeywords)
'() '())
(list (list pattern (mapit path))))) (#t (list (list pattern (mapit path))))))
((segment-pattern? pattern) ((segment-pattern? pattern)
(process-pattern (car pattern) (process-pattern (car pattern)
%temp %temp
(lambda (x) ;temp is free in x (lambda (x) ;temp is free in x
(mapit (if (eq? %temp x) (mapit (cond ((eq? %temp x)
path ;+++ path) ;+++
`(map (lambda (,%temp) ,x) (#t `(map (lambda (,%temp) ,x)
,path)))))) ,path)))))))
((pair? pattern) ((pair? pattern)
(append (process-pattern (car pattern) `(car ,path) mapit) (append (process-pattern (car pattern) `(car ,path) mapit)
(process-pattern (cdr pattern) `(cdr ,path) mapit))) (process-pattern (cdr pattern) `(cdr ,path) mapit)))
@ -213,28 +213,28 @@
(define (process-template template rank env) (define (process-template template rank env)
(cond ((name? template) (cond ((name? template)
(let ((probe (assq template env))) (let ((probe (assq template env)))
(if probe (cond (probe
(if (<= (cdr probe) rank) (cond ((<= (cdr probe) rank)
template template)
(syntax-error "template rank error (too few ...'s?)" (#t (syntax-error "template rank error (too few ...'s?)"
template)) template))))
`(,%rename ',template)))) (#t `(,%rename ',template)))))
((segment-template? template) ((segment-template? template)
(let ((vars (let ((vars
(free-meta-variables (car template) (+ rank 1) env '()))) (free-meta-variables (car template) (+ rank 1) env '())))
(if (null? vars) (cond ((null? vars)
(syntax-error "too many ...'s" template) (syntax-error "too many ...'s" template))
(let* ((x (process-template (car template) (#t (let* ((x (process-template (car template)
(+ rank 1) (+ rank 1)
env)) env))
(gen (if (equal? (list x) vars) (gen (cond ((equal? (list x) vars)
x ;+++ x) ;+++
`(map (lambda ,vars ,x) (#t `(map (lambda ,vars ,x)
,@vars)))) ,@vars)))))
(if (null? (cddr template)) (cond ((null? (cddr template))
gen ;+++ gen) ;+++
`(append ,gen ,(process-template (cddr template) (#t `(append ,gen ,(process-template (cddr template)
rank env))))))) rank env)))))))))
((pair? template) ((pair? template)
`(cons ,(process-template (car template) rank env) `(cons ,(process-template (car template) rank env)
,(process-template (cdr template) rank env))) ,(process-template (cdr template) rank env)))
@ -245,9 +245,9 @@
(define (meta-variables pattern rank vars) (define (meta-variables pattern rank vars)
(cond ((name? pattern) (cond ((name? pattern)
(if (memq pattern subkeywords) (cond ((memq pattern subkeywords)
vars vars)
(cons (cons pattern rank) vars))) (#t (cons (cons pattern rank) vars))))
((segment-pattern? pattern) ((segment-pattern? pattern)
(meta-variables (car pattern) (+ rank 1) vars)) (meta-variables (car pattern) (+ rank 1) vars))
((pair? pattern) ((pair? pattern)
@ -260,11 +260,11 @@
(define (free-meta-variables template rank env free) (define (free-meta-variables template rank env free)
(cond ((name? template) (cond ((name? template)
(if (and (not (memq template free)) (cond ((and (not (memq template free))
(let ((probe (assq template env))) (let ((probe (assq template env)))
(and probe (>= (cdr probe) rank)))) (and probe (>= (cdr probe) rank))))
(cons template free) (cons template free))
free)) (#t free)))
((segment-template? template) ((segment-template? template)
(free-meta-variables (car template) (free-meta-variables (car template)
rank env rank env
@ -295,7 +295,7 @@
((mes:or) #f) ((mes:or) #f)
((mes:or e) e) ((mes:or e) e)
((mes:or e1 e ...) (let ((temp e1)) ((mes:or e1 e ...) (let ((temp e1))
(if temp temp (or e ...)))))) (cond (temp temp) (#t (or e ...)))))))
(display "(mes:or #f (= 0 1) 'hello-syntax-world): ") (display "(mes:or #f (= 0 1) 'hello-syntax-world): ")
(display (mes:or #f (= 0 1) 'hello-syntax-world)) (display (mes:or #f (= 0 1) 'hello-syntax-world))