From 341d064a34f7222730af84ec0beec3d3720de441 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 17 Jul 2016 11:37:22 +0200 Subject: [PATCH] hax0rz..ugh + next name? test in macro.mes. --- macro.mes | 36 +++--- mes.c | 20 +++- syntax.mes | 346 ++++++++++++++++++++++++++++------------------------- 3 files changed, 224 insertions(+), 178 deletions(-) diff --git a/macro.mes b/macro.mes index 5b212a8a..d43a3fd4 100644 --- a/macro.mes +++ b/macro.mes @@ -58,20 +58,28 @@ ) (d-s s-r - (lambda (. n-a) - (display "YEAH:") - (display n-a) - (newline) - '(lambda (. i) ;;(i r c) - (display "transformers") - (newline) - ''tee-hee-hee - ) - ;; (define (foo) (display "Footje") (newline) 'f-f-f) - ;; foo - ;;"blaat" - ) - ;;(let ()) + (;; let () ;; syntax-rules uses (let () ...), + ;; mes doesn't support that yet; use ((lambda () ...)) + (lambda () + ;; syntax-rules uses defines that get closured-in + ;; mes doesn't support that yet; move down + ;; (define name? symbol?) + (lambda (. n-a) + (define name? symbol?) + + (display "YEAH:") + (display n-a) + (display (name? n-a)) + (newline) + '(lambda (. i) ;;(i r c) + (display "transformers") + (newline) + ''tee-hee-hee + ) + ;; (define (foo) (display "Footje") (newline) 'f-f-f) + ;; foo + ;;"blaat" + ))) ) (display "calling s-r") diff --git a/mes.c b/mes.c index 10d4cd62..ca367be1 100644 --- a/mes.c +++ b/mes.c @@ -291,6 +291,17 @@ apply_env_ (scm *fn, scm *x, scm *a) return begin_env (cddr (fn), pairlis (cadr (fn), x, a)); else if (car (fn) == &scm_label) return apply_env (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a)); + else if (car (fn)->type == PAIR) { +#if DEBUG // FIXME: for macro.mes/syntax.mes this feels *wrong* + printf ("APPLY WTF: fn="); + display (fn); + puts (""); +#endif + //return apply_env_ (eval_ (fn, a), x, a); + scm *e = eval_ (fn, a); + return apply_env_ (e, x, a); + //return &scm_unspecified; + } #if MACROS else if ((macro = assq (car (fn), cdr (assq (&scm_macro, a)))) != &scm_f) { #if DEBUG @@ -302,13 +313,18 @@ apply_env_ (scm *fn, scm *x, scm *a) display (cdr (fn)); puts (""); #endif - scm *r = apply_env (cdr (macro), cdr (fn), a); + //scm *r = apply_env (cdr (macro), cdr (fn), a); + scm *r = apply_env (eval_ (cdr (macro), a), cdr (fn), a); #if DEBUG printf ("APPLY MACRO GOT: ==> "); display (r); puts (""); #endif - return apply_env (r, x, a); + //return apply_env (r, x, a); + + scm *e = eval_ (r, a); + return apply_env (e, x, a); + //return eval_ (cons (r, x), a); //return apply_env_ (eval (cdr (macro), a), x, a); //return eval (apply_env_ (cdr (macro), x, a), a); diff --git a/syntax.mes b/syntax.mes index 513900e3..5228bc3d 100644 --- a/syntax.mes +++ b/syntax.mes @@ -6,6 +6,8 @@ ;;(display thing) (newline)) +(define (member x lst) + (display "MEMBER x=") (display x) (newline) (memq x lst)) (display "mes:define-syntax...") ;;(define (caddr x) (car (cdr (cdr x)))) @@ -81,191 +83,211 @@ (newline) (mes:define-syntax syntax-rules - (let () - ;;begin + (;; let () ;; syntax-rules uses (let () ...), + ;; mes doesn't support that yet; use ((lambda () ...)) + (lambda () - (define name? symbol?) + ;; syntax-rules uses defines that get closured-in + ;; mes doesn't support that yet; move down + ;; (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 "...") '---)) + ;; (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 "...") '---)) - (display "BOOO") + (display "BOOO") - (lambda (exp r c) + (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)) + ;; FIXME: mes, moved down + (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 "...") '---)) + ;; end FIXME + - (define rules (cddr exp)) - (define subkeywords (cadr exp)) + (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 (make-transformer rules) - `(lambda (,%input ,%rename ,%compare) - (let ((,%tail (cdr ,%input))) - (cond ,@(map process-rule rules) - (#t ;;else - (syntax-error - "use of macro doesn't match definition" - ,%input)))))) + (define rules (cddr exp)) + (define subkeywords (cadr exp)) - (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))) + (define (make-transformer rules) + `(lambda (,%input ,%rename ,%compare) + (let ((,%tail (cdr ,%input))) + (cond ,@(map process-rule rules) + (#t ;;else + (syntax-error + "use of macro doesn't match definition" + ,%input)))))) - ;; Generate code to test whether input expression matches pattern + (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))) - (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))) - (#t ;;else - `((equal? ,input ',pattern))))) + ;; Generate code to test whether input expression matches 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))))))))) + (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))) + (#t ;;else + `((equal? ,input ',pattern))))) - ;; Generate code to take apart the input expression - ;; This is pretty bad, but it seems to work (can't say why). + (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))))))))) - (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))) - (#t ;;else - '()))) + ;; Generate code to take apart the input expression + ;; This is pretty bad, but it seems to work (can't say why). - ;; Generate code to compose the output expression according to template + (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))) + (#t ;;else + '()))) - (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))) - (#t ;;else - `(quote ,template)))) + ;; Generate code to compose the output expression according to template - ;; Return an association list of (var . rank) + (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))) + (#t ;;else + `(quote ,template)))) - (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))) - (#t ;;else - vars))) + ;; Return an association list of (var . rank) - ;; Return a list of meta-variables of given higher 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))) + (#t ;;else + vars))) - (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))) - (#t ;;else - free))) + ;; Return a list of meta-variables of given higher rank - c ;ignored + (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))) + (#t ;;else + free))) - (display "HELLO") - (newline) + c ;ignored - ;; Kludge for Scheme48 linker. - ;; `(cons ,(make-transformer rules) - ;; ',(find-free-names-in-syntax-rules subkeywords rules)) + (display "HELLO") + (newline) - (make-transformer rules)))) + ;; Kludge for Scheme48 linker. + ;; `(cons ,(make-transformer rules) + ;; ',(find-free-names-in-syntax-rules subkeywords rules)) + + (make-transformer rules))))) (mes:define-syntax mes:or