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

syntax.mes: more debugging.

This commit is contained in:
Jan Nieuwenhuizen 2016-07-17 22:06:28 +02:00
parent bfb2f42cd5
commit 7eb56a400a
1 changed files with 70 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
syntax.mes
View File

@ -1,3 +1,4 @@
;; -*-scheme-*-
;;(define else #t) ;;(define else #t)
(define (syntax-error message thing) (define (syntax-error message thing)
(display "syntax-error:") (display "syntax-error:")
@ -7,7 +8,22 @@
(newline)) (newline))
(define (member x lst) (define (member x lst)
(display "MEMBER x=") (display x) (newline) (memq x lst)) (display "MEMBER x=") (display x)
(display " lst=") (display lst)
(display " => ") (display (memq x lst))
(newline)
(memq x lst))
(display "mes:define-syntax...")
(define (equal? a b) ;; FIXME: only 2 arg + broken for lists
(display "EQUAL? a=") (display a)
(display " b=") (display b) (newline)
;;(eq? a b)
(cond ((and (null? a) (null? b)) #t)
((and (pair? a) (pair? b))
(and (equal? (car a) (car b))
(equal? (cdr a) (cdr b))))
(#t (eq? a b))))
(display "mes:define-syntax...") (display "mes:define-syntax...")
;;(define (caddr x) (car (cdr (cdr x)))) ;;(define (caddr x) (car (cdr (cdr x))))
@ -101,7 +117,7 @@
;; (pair? (cdr pattern)) ;; (pair? (cdr pattern))
;; (memq (cadr pattern) indicators-for-zero-or-more))) ;; (memq (cadr pattern) indicators-for-zero-or-more)))
;; (define indicators-for-zero-or-more (list (string->symbol "...") '---)) ;;(define indicators-for-zero-or-more (list (string->symbol "...") '---))
(display "BOOO") (display "BOOO")
@ -111,16 +127,39 @@
(define name? symbol?) (define name? symbol?)
(define (segment-pattern? pattern) (define (segment-pattern? pattern)
(display "segment-pattern?: ")
(display pattern)
(newline)
(display "segment-template?: ")
(display (segment-template? pattern))
(newline)
(and (segment-template? pattern) (and (segment-template? pattern)
(or (null? (cddr pattern)) (or (null? (cddr pattern))
(syntax-error "segment matching not implemented" pattern)))) (syntax-error "segment matching not implemented" pattern))))
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
(define (segment-template? pattern) (define (segment-template? pattern)
(and (pair? pattern) (and (pair? pattern)
(display "pair?: ")
(display (pair? pattern))
(newline)
(pair? (cdr pattern)) (pair? (cdr pattern))
(memq (cadr pattern) indicators-for-zero-or-more))) (display "pair? cdr: ")
(display (pair? (cdr pattern)))
(newline)
;; (display "indicators: ")
;; (display indicators-for-zero-or-more)
;; (newline)
(display "cadr pattern: ")
(display (cadr pattern))
(newline)
(display "memq?: ")
;;(memq (cadr pattern) indicators-for-zero-or-more)
(memq (cadr pattern) (list (string->symbol "...") '---))
;;(member (cadr pattern) indicators-for-zero-or-more)
))
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
;; end FIXME ;; end FIXME
@ -134,6 +173,7 @@
(define subkeywords (cadr exp)) (define subkeywords (cadr exp))
(define (make-transformer rules) (define (make-transformer rules)
(display "make-transformer") (newline)
`(lambda (,%input ,%rename ,%compare) `(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input))) (let ((,%tail (cdr ,%input)))
(cond ,@(map process-rule rules) (cond ,@(map process-rule rules)
@ -143,6 +183,7 @@
,%input)))))) ,%input))))))
(define (process-rule rule) (define (process-rule rule)
(display "process-rule") (newline)
(cond ((and (pair? rule) (cond ((and (pair? rule)
(pair? (cdr rule)) (pair? (cdr rule))
(null? (cddr rule))) (null? (cddr rule)))
@ -160,6 +201,7 @@
;; 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)
(display "process-match") (newline)
(cond ((name? pattern) (cond ((name? pattern)
(cond ((member pattern subkeywords) (cond ((member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern)))) `((,%compare ,input (,%rename ',pattern))))
@ -177,10 +219,12 @@
`((equal? ,input ',pattern))))) `((equal? ,input ',pattern)))))
(define (process-segment-match input pattern) (define (process-segment-match input pattern)
(display "process-segment-match") (newline)
(let ((conjuncts (process-match '(car l) pattern))) (let ((conjuncts (process-match '(car l) pattern)))
(cond ((null? conjuncts) (cond ((null? conjuncts)
`((list? ,input))) ;+++ `((list? ,input))) ;+++
(#t `((let loop ((l ,input)) (#t `((let loop ((l ,input))
(display "loop") (newline)
(or (null? l) (or (null? l)
(and (pair? l) (and (pair? l)
,@conjuncts ,@conjuncts
@ -190,27 +234,45 @@
;; 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)
(display "process-pattern pattern=") (display pattern) (newline)
(cond ((name? pattern) (cond ((name? pattern)
(display "name!") (newline)
(display "subkeywords: ") (display subkeywords) (newline)
(cond ((memq pattern subkeywords) (cond ((memq pattern subkeywords)
;;;;(member pattern subkeywords)
'()) '())
(#t (list (list pattern (mapit path)))))) (#t
(display "hiero mapit=") (display mapit)
(display " path=") (display path)
(newline)
(list (list pattern (mapit path))))))
((segment-pattern? pattern) ((segment-pattern? pattern)
(display "segment!") (newline)
(process-pattern (car pattern) (process-pattern (car pattern)
%temp %temp
(lambda (x) ;temp is free in x (lambda (x) ;temp is free in x
(display "mapit x=") (display x) (newline)
(mapit (cond ((eq? %temp x) (mapit (cond ((eq? %temp x)
;; guile: x=%temp ==> mapit==> (cdr %tail)
;; mes: x=%temp ==> mapit==> %temp
(display " x=%temp ==> mapit==> ") (display path) (newline)
path) ;+++ path) ;+++
(#t `(map (lambda (,%temp) ,x) (#t
(display "not!")
`(map (lambda (,%temp) ,x)
,path))))))) ,path)))))))
((pair? pattern) ((pair? pattern)
(display "pair!") (newline)
(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)))
(#t ;;else (#t ;;else
(display "else!") (newline)
'()))) '())))
;; Generate code to compose the output expression according to template ;; Generate code to compose the output expression according to template
(define (process-template template rank env) (define (process-template template rank env)
(display "process-template") (newline)
(cond ((name? template) (cond ((name? template)
(let ((probe (assq template env))) (let ((probe (assq template env)))
(cond (probe (cond (probe
@ -244,6 +306,7 @@
;; Return an association list of (var . rank) ;; Return an association list of (var . rank)
(define (meta-variables pattern rank vars) (define (meta-variables pattern rank vars)
(display "meta-variables") (newline)
(cond ((name? pattern) (cond ((name? pattern)
(cond ((memq pattern subkeywords) (cond ((memq pattern subkeywords)
vars) vars)
@ -259,6 +322,7 @@
;; Return a list of meta-variables of given higher rank ;; Return a list of meta-variables of given higher rank
(define (free-meta-variables template rank env free) (define (free-meta-variables template rank env free)
(display "free-meta-variables") (newline)
(cond ((name? template) (cond ((name? template)
(cond ((and (not (memq template free)) (cond ((and (not (memq template free))
(let ((probe (assq template env))) (let ((probe (assq template env)))