From 7eb56a400a6649e150dff6d7b6d2663605109174 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 17 Jul 2016 22:06:28 +0200 Subject: [PATCH] syntax.mes: more debugging. --- syntax.mes | 76 +++++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 70 insertions(+), 6 deletions(-) diff --git a/syntax.mes b/syntax.mes index 4c8d27fd..7b7a30f8 100644 --- a/syntax.mes +++ b/syntax.mes @@ -1,3 +1,4 @@ +;; -*-scheme-*- ;;(define else #t) (define (syntax-error message thing) (display "syntax-error:") @@ -7,7 +8,22 @@ (newline)) (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...") ;;(define (caddr x) (car (cdr (cdr x)))) @@ -101,7 +117,7 @@ ;; (pair? (cdr pattern)) ;; (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") @@ -111,16 +127,39 @@ (define name? symbol?) (define (segment-pattern? pattern) + (display "segment-pattern?: ") + (display pattern) + (newline) + (display "segment-template?: ") + (display (segment-template? pattern)) + (newline) (and (segment-template? pattern) (or (null? (cddr pattern)) (syntax-error "segment matching not implemented" pattern)))) + (define indicators-for-zero-or-more (list (string->symbol "...") '---)) + (define (segment-template? pattern) (and (pair? pattern) + (display "pair?: ") + (display (pair? pattern)) + (newline) (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 @@ -134,6 +173,7 @@ (define subkeywords (cadr exp)) (define (make-transformer rules) + (display "make-transformer") (newline) `(lambda (,%input ,%rename ,%compare) (let ((,%tail (cdr ,%input))) (cond ,@(map process-rule rules) @@ -143,6 +183,7 @@ ,%input)))))) (define (process-rule rule) + (display "process-rule") (newline) (cond ((and (pair? rule) (pair? (cdr rule)) (null? (cddr rule))) @@ -160,6 +201,7 @@ ;; Generate code to test whether input expression matches pattern (define (process-match input pattern) + (display "process-match") (newline) (cond ((name? pattern) (cond ((member pattern subkeywords) `((,%compare ,input (,%rename ',pattern)))) @@ -177,10 +219,12 @@ `((equal? ,input ',pattern))))) (define (process-segment-match input pattern) + (display "process-segment-match") (newline) (let ((conjuncts (process-match '(car l) pattern))) (cond ((null? conjuncts) `((list? ,input))) ;+++ (#t `((let loop ((l ,input)) + (display "loop") (newline) (or (null? l) (and (pair? l) ,@conjuncts @@ -190,27 +234,45 @@ ;; This is pretty bad, but it seems to work (can't say why). (define (process-pattern pattern path mapit) + (display "process-pattern pattern=") (display pattern) (newline) (cond ((name? pattern) + (display "name!") (newline) + (display "subkeywords: ") (display subkeywords) (newline) (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) + (display "segment!") (newline) (process-pattern (car pattern) %temp (lambda (x) ;temp is free in x + (display "mapit x=") (display x) (newline) (mapit (cond ((eq? %temp x) + ;; guile: x=%temp ==> mapit==> (cdr %tail) + ;; mes: x=%temp ==> mapit==> %temp + (display " x=%temp ==> mapit==> ") (display path) (newline) path) ;+++ - (#t `(map (lambda (,%temp) ,x) + (#t + (display "not!") + `(map (lambda (,%temp) ,x) ,path))))))) ((pair? pattern) + (display "pair!") (newline) (append (process-pattern (car pattern) `(car ,path) mapit) (process-pattern (cdr pattern) `(cdr ,path) mapit))) (#t ;;else + (display "else!") (newline) '()))) ;; Generate code to compose the output expression according to template (define (process-template template rank env) + (display "process-template") (newline) (cond ((name? template) (let ((probe (assq template env))) (cond (probe @@ -244,6 +306,7 @@ ;; Return an association list of (var . rank) (define (meta-variables pattern rank vars) + (display "meta-variables") (newline) (cond ((name? pattern) (cond ((memq pattern subkeywords) vars) @@ -259,6 +322,7 @@ ;; Return a list of meta-variables of given higher rank (define (free-meta-variables template rank env free) + (display "free-meta-variables") (newline) (cond ((name? template) (cond ((and (not (memq template free)) (let ((probe (assq template env)))