artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mes.c: add new macro type, junk *macro* hack.

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-07-22 17:13:51 +02:00
parent 04f3323f10
commit efdd84b4c4
7 changed files with 106 additions and 253 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
GNUmakefile
View file

@ -1,6 +1,6 @@
.PHONY: all check default .PHONY: all check default
#CFLAGS=-std=c99 -O3 -finline-functions CFLAGS=-std=c99 -O3 -finline-functions
CFLAGS=-std=c99 -g #CFLAGS=-std=c99 -g
default: all default: all

8
TODO
View file

@ -1,7 +1,9 @@
-*-mode:org-*- -*-mode:org-*-
* define-syntax and syntax-rules * define-syntax and syntax-rules
** syntax.mes ** syntax.mes
** or psyntax.pp Using define-macro-based version.
** psyntax.pp
Find out how to hook-up sc-expand in eval/apply.
** bugs ** bugs
*** c2.mes *** c2.mes
*** c4.mes *** c4.mes
@ -11,8 +13,8 @@
*** v c1.mes *** v c1.mes
*** v c3.mes *** v c3.mes
*** v using (let () ...) in macro.mes/syntax.mes *** v using (let () ...) in macro.mes/syntax.mes
*** syntax.mes: closuring name? etc in syntax.mes *** v syntax.mes: closuring name? etc in syntax.mes
*** syntax.mes: closuring: indicators: eval: no such symbol: --- *** v syntax.mes: closuring: indicators: eval: no such symbol: ---
*** <=, => take only 2 arguments *** <=, => take only 2 arguments
** run PEG ** run PEG
** parse C using PEG ** parse C using PEG

194
mes.c
View file

@ -34,10 +34,9 @@
#include <stdbool.h> #include <stdbool.h>
#define DEBUG 0 #define DEBUG 0
#define XDEBUG 0
#define MES_FULL 1 #define MES_FULL 1
enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR, enum type {CHAR, MACRO, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR,
FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn}; FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
struct scm_t; struct scm_t;
typedef struct scm_t* (*function0_t) (void); typedef struct scm_t* (*function0_t) (void);
@ -61,6 +60,7 @@ typedef struct scm_t {
function3_t function3; function3_t function3;
functionn_t functionn; functionn_t functionn;
struct scm_t* cdr; struct scm_t* cdr;
struct scm_t* macro;
struct scm_t** vector; struct scm_t** vector;
}; };
} scm; } scm;
@ -91,7 +91,6 @@ scm symbol_quote = {SYMBOL, "quote"};
scm symbol_quasiquote = {SYMBOL, "quasiquote"}; scm symbol_quasiquote = {SYMBOL, "quasiquote"};
scm symbol_unquote = {SYMBOL, "unquote"}; scm symbol_unquote = {SYMBOL, "unquote"};
scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"}; scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
scm symbol_macro = {SYMBOL, "*macro*"};
scm symbol_call_with_values = {SYMBOL, "call-with-values"}; scm symbol_call_with_values = {SYMBOL, "call-with-values"};
scm symbol_current_module = {SYMBOL, "current-module"}; scm symbol_current_module = {SYMBOL, "current-module"};
@ -155,9 +154,9 @@ eq_p (scm *x, scm *y)
} }
scm * scm *
macro_p (scm *x, scm *a) macro_p (scm *x)
{ {
return assq (x, cdr (assq (&symbol_macro, a))) != &scm_f ? &scm_t : &scm_f; return x->type == MACRO ? &scm_t : &scm_f;
} }
scm * scm *
@ -286,8 +285,8 @@ apply_env (scm *fn, scm *x, scm *a)
a = cdadr (fn); a = cdadr (fn);
return eval (cons (&symbol_begin, body), pairlis (args, x, a)); return eval (cons (&symbol_begin, body), pairlis (args, x, a));
} }
else if ((macro = assq (car (fn), cdr (assq (&symbol_macro, a)))) != &scm_f) { else if ((macro = lookup_macro (car (fn), a)) != &scm_f) {
scm *r = apply_env (eval (cdr (macro), a), cdr (fn), a); scm *r = apply_env (eval (macro, a), cdr (fn), a);
scm *e = eval (r, a); scm *e = eval (r, a);
return apply_env (e, x, a); return apply_env (e, x, a);
} }
@ -296,6 +295,8 @@ apply_env (scm *fn, scm *x, scm *a)
return apply_env (efn, x, a); return apply_env (efn, x, a);
} }
scm *make_symbol (char const *s);
scm * scm *
eval (scm *e, scm *a) eval (scm *e, scm *a)
{ {
@ -318,84 +319,35 @@ eval (scm *e, scm *a)
return e; return e;
else if (atom_p (car (e)) == &scm_t) else if (atom_p (car (e)) == &scm_t)
{ {
//scm *macro;
if (car (e) == &symbol_quote) if (car (e) == &symbol_quote)
return cadr (e); return cadr (e);
if (car (e) == &symbol_begin) if (car (e) == &symbol_begin)
{ {
scm *orig_a = a;
scm *body = cdr (e); scm *body = cdr (e);
if (body == &scm_nil) return &scm_nil;
e = car (body);
body = cdr (body);
scm *r = &scm_unspecified;
#if DEBUG
printf ("BEGIN eval e=");
display (e);
puts ("");
#endif
// closure defines in one go
#define WHILE while
#define BREAK break
scm *defines = &scm_nil; scm *defines = &scm_nil;
scm *macros = &scm_nil; while (body != &scm_nil) {
WHILE (e->type == PAIR e = car (body);
&& (eq_p (car (e), &symbol_define) == &scm_t body = cdr (body);
|| eq_p (car (e), &symbol_define_macro) == &scm_t)) { if (e->type == PAIR
if (eq_p (car (e), &symbol_define) == &scm_t) && (eq_p (car (e), &symbol_define) == &scm_t
|| eq_p (car (e), &symbol_define_macro) == &scm_t)) {
defines = append2 (defines, cons (def (e), &scm_nil)); defines = append2 (defines, cons (def (e), &scm_nil));
else if (eq_p (car (e), &symbol_define_macro) == &scm_t) e = &scm_unspecified;
macros = append2 (macros, cons (def (e), &scm_nil));
if (body == &scm_nil) e = &scm_unspecified;
if (body == &scm_nil) BREAK;
if (body != &scm_nil) {
e = car (body);
body = cdr (body);
} }
else break;
} }
breek:; a = append2 (defines, a);
while (defines != &scm_nil) {
scm* xmacros = cons (&symbol_macro,
append2 (macros, cdr (assq (&symbol_macro, a))));
scm *aa = a;
if (macros != &scm_nil) aa = cons (xmacros, aa);
aa = append2 (defines, aa);
a = aa;
scm *names = &scm_nil;
scm *values = &scm_nil;
WHILE (defines != &scm_nil) {
scm *name = caar (defines); scm *name = caar (defines);
scm *d = cdar (defines);
scm *x = define (d, a);
scm *entry = assq (name, a); scm *entry = assq (name, a);
set_cdr_x (entry, cdr (x)); scm *x = cdar (defines);
set_cdr_x (entry, cdr (define (x, a)));
defines = cdr (defines); defines = cdr (defines);
names = cons (name, names);
values = cons (cdr (x), values);
} }
scm *fubar = cons (&scm_dot, &scm_dot);
WHILE (macros != &scm_nil) { scm *r = eval (e, cons (fubar, a));
scm *name = caar (macros); if (r->type == PAIR && macro_p (cdr (r)))
scm *d = cdar (macros); a = cons (r, a); // macros defining macros...
scm *x = define (d, a);
scm *entry = assq (name, cdr (assq (&symbol_macro, a)));
set_cdr_x (entry, cdr (x));
macros = cdr (macros);
names = cons (name, names);
values = cons (cdr (x), values);
}
scm *foo = cons (&scm_dot, &scm_dot);
r = eval (e, cons (foo, a));
if (body == &scm_nil) return r; if (body == &scm_nil) return r;
return eval (cons (&symbol_begin, body), a); return eval (cons (&symbol_begin, body), a);
} }
@ -410,9 +362,9 @@ eval (scm *e, scm *a)
if (car (e) == &symbol_cond) if (car (e) == &symbol_cond)
return evcon (cdr (e), a); return evcon (cdr (e), a);
if (eq_p (car (e), &symbol_define_macro) == &scm_t) if (eq_p (car (e), &symbol_define_macro) == &scm_t)
return define_macro (e, a); return define (e, a);
if ((macro = assq (car (e), cdr (assq (&symbol_macro, a)))) != &scm_f) if ((macro = lookup_macro (car (e), a)) != &scm_f)
return eval (apply_env (cdr (macro), cdr (e), a), a); return eval (apply_env (macro, cdr (e), a), a);
if (car (e) == &symbol_set_x) if (car (e) == &symbol_set_x)
return set_env_x (cadr (e), eval (caddr (e), a), a); return set_env_x (cadr (e), eval (caddr (e), a), a);
} }
@ -558,6 +510,15 @@ make_char (int x)
return p; return p;
} }
scm *
make_macro (scm *x) //int
{
scm *p = malloc (sizeof (scm));
p->type = MACRO;
p->macro = x;
return p;
}
scm * scm *
make_number (int x) make_number (int x)
{ {
@ -697,37 +658,33 @@ lookup (char *x, scm *a)
{ {
if (isdigit (*x) || (*x == '-' && isdigit (*(x+1)))) if (isdigit (*x) || (*x == '-' && isdigit (*(x+1))))
return make_number (atoi (x)); return make_number (atoi (x));
if (*x == '\'') return &symbol_quote;
// Hmmm
if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified;
if (!strcmp (x, scm_nil.name)) return &scm_nil;
if (!strcmp (x, scm_t.name)) return &scm_t;
if (!strcmp (x, scm_f.name)) return &scm_f;
if (!strcmp (x, scm_dot.name)) return &scm_dot; if (!strcmp (x, scm_dot.name)) return &scm_dot;
if (!strcmp (x, scm_f.name)) return &scm_f;
if (!strcmp (x, scm_nil.name)) return &scm_nil;
if (!strcmp (x, scm_t.name)) return &scm_t;
if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified;
if (!strcmp (x, symbol_begin.name)) return &symbol_begin; if (!strcmp (x, symbol_begin.name)) return &symbol_begin;
if (!strcmp (x, symbol_cond.name)) return &symbol_cond;
if (!strcmp (x, symbol_closure.name)) return &symbol_closure; if (!strcmp (x, symbol_closure.name)) return &symbol_closure;
if (!strcmp (x, symbol_cond.name)) return &symbol_cond;
if (!strcmp (x, symbol_current_module.name)) return &symbol_current_module;
if (!strcmp (x, symbol_lambda.name)) return &symbol_lambda; if (!strcmp (x, symbol_lambda.name)) return &symbol_lambda;
if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x; if (!strcmp (x, symbol_quasiquote.name)) return &symbol_quasiquote;
if (!strcmp (x, symbol_quote.name)) return &symbol_quote; if (!strcmp (x, symbol_quote.name)) return &symbol_quote;
if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x;
if (!strcmp (x, symbol_unquote.name)) return &symbol_unquote;
if (!strcmp (x, symbol_unquote_splicing.name)) return &symbol_unquote_splicing;
if (!strcmp (x, scm_car.name)) return &scm_car; if (!strcmp (x, scm_car.name)) return &scm_car;
if (!strcmp (x, scm_cdr.name)) return &scm_cdr; if (!strcmp (x, scm_cdr.name)) return &scm_cdr;
if (!strcmp (x, scm_display.name)) return &scm_display; if (!strcmp (x, scm_display.name)) return &scm_display;
if (!strcmp (x, scm_builtin_list.name)) return &scm_builtin_list; if (!strcmp (x, scm_builtin_list.name)) return &scm_builtin_list;
if (*x == '\'') return &symbol_quote;
if (*x == '`') return &symbol_quasiquote; if (*x == '`') return &symbol_quasiquote;
if (*x == ',' && *(x+1) == '@') return &symbol_unquote_splicing; if (*x == ',' && *(x+1) == '@') return &symbol_unquote_splicing;
if (*x == ',') return &symbol_unquote; if (*x == ',') return &symbol_unquote;
if (!strcmp (x, symbol_quasiquote.name)) return &symbol_quasiquote;
if (!strcmp (x, symbol_unquote.name)) return &symbol_unquote;
if (!strcmp (x, symbol_unquote_splicing.name)) return &symbol_unquote_splicing;
return make_symbol (x); return make_symbol (x);
} }
@ -838,6 +795,11 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
if (x->type == CHAR && x->value == 10) printf ("#\\%s", "newline"); if (x->type == CHAR && x->value == 10) printf ("#\\%s", "newline");
else if (x->type == CHAR && x->value == 32) printf ("#\\%s", "space"); else if (x->type == CHAR && x->value == 32) printf ("#\\%s", "space");
else if (x->type == CHAR) printf ("#\\%c", x->value); else if (x->type == CHAR) printf ("#\\%c", x->value);
else if (x->type == MACRO) {
printf ("(*macro* ");
display_helper (x->macro, cont, sep, quote);
printf (")");
}
else if (x->type == NUMBER) printf ("%d", x->value); else if (x->type == NUMBER) printf ("%d", x->value);
else if (x->type == PAIR) { else if (x->type == PAIR) {
if (car (x) == &symbol_circ) { if (car (x) == &symbol_circ) {
@ -1146,25 +1108,7 @@ mes_environment ()
{ {
scm *a = &scm_nil; scm *a = &scm_nil;
a = add_environment (a, "*macro*", &scm_nil);
#if MES_FULL
a = add_environment (a, "()", &scm_nil);
a = add_environment (a, "#t", &scm_t);
a = add_environment (a, "#f", &scm_f);
a = add_environment (a, "*unspecified*", &scm_unspecified);
a = add_environment (a, "lambda", &symbol_lambda);
a = add_environment (a, "*dot*", &scm_dot);
a = add_environment (a, "current-module", &symbol_current_module);
a = add_environment (a, "begin", &symbol_begin);
a = add_environment (a, "cond", &symbol_cond);
a = add_environment (a, "list", &symbol_list);
#include "environment.i" #include "environment.i"
#endif
return a; return a;
} }
@ -1192,25 +1136,27 @@ def (scm *x)
scm * scm *
define (scm *x, scm *a) define (scm *x, scm *a)
{ {
if (atom_p (cadr (x)) != &scm_f) scm *e;
return cons (cadr (x), eval (caddr (x), cons (cons (cadr (x), cadr (x)), a))); scm *name = cadr (x);
scm *p = pairlis (cadr (x), cadr (x), a); if (name->type != PAIR)
return cons (caadr (x), eval (make_lambda (cdadr (x), cddr (x)), p)); e = eval (caddr (x), cons (cons (cadr (x), cadr (x)), a));
}
scm *
define_macro (scm *x, scm *a)
{
scm *macros = assq (&symbol_macro, a);
scm *macro;
if (atom_p (cadr (x)) != &scm_f)
macro = cons (cadr (x), eval (caddr (x), cons (cons (cadr (x), cadr (x)), a)));
else { else {
name = car (name);
scm *p = pairlis (cadr (x), cadr (x), a); scm *p = pairlis (cadr (x), cadr (x), a);
macro = cons (caadr(x), eval (make_lambda (cdadr (x), cddr (x)), p)); e = eval (make_lambda (cdadr (x), cddr (x)), p);
} }
set_cdr_x (macros, cons (macro, cdr (macros))); if (eq_p (car (x), &symbol_define_macro) == &scm_t)
return a; e = make_macro (e);
return cons (name, e);
}
scm *
lookup_macro (scm *x, scm *a)
{
scm *m = assq (x, a);
if (m != &scm_f && macro_p (cdr (m)) != &scm_f)
return cdr (m)->macro;
return &scm_f;
} }
scm * scm *

8
mes.test
View file

@ -1,21 +1,17 @@
#! /bin/sh #! /bin/sh
set -x #set -x
mes=${1-./mes.scm} mes=${1-./mes.scm}
echo 0 | $mes echo 0 | $mes
echo 1 | $mes echo 1 | $mes
#echo car | $mes "((0 1))"
echo "(car '(0 1))" | $mes echo "(car '(0 1))" | $mes
echo "(car (quote (0 1)))" | $mes echo "(car (quote (0 1)))" | $mes
echo "(car '(0 1))" | $mes echo "(car '(0 1))" | $mes
#echo cdr | $mes "((0 1))"
echo "(cdr '(0 1))" | $mes echo "(cdr '(0 1))" | $mes
#echo cons | $mes "(0 1)"
echo "(cons 0 1)" | $mes echo "(cons 0 1)" | $mes
#echo "(lambda (x y) (cons x y))" | $mes "(0 1)"
echo "((lambda (x y) (cons x y)) 0 1)" | $mes echo "((lambda (x y) (cons x y)) 0 1)" | $mes
## echo "((label fun (lambda (x) x)) 2 2)" | $mes
echo "(< 0 0)" | $mes echo "(< 0 0)" | $mes
echo "(< 0 1)" | $mes echo "(< 0 1)" | $mes
# LISP-1.5 label dropped for now
# echo "((label fun\ # echo "((label fun\
# (lambda (x) (cons x\ # (lambda (x) (cons x\
# (cond ((< 0 x) (fun (- x 1)))\ # (cond ((< 0 x) (fun (- x 1)))\

1
scm.mes
View file

@ -44,7 +44,6 @@
(define-macro (let-loop label bindings rest) (define-macro (let-loop label bindings rest)
`((lambda (,label) `((lambda (,label)
(display "loop") (newline)
(set! ,label (lambda ,(split-params bindings '()) ,@rest)) (set! ,label (lambda ,(split-params bindings '()) ,@rest))
(,label ,@(split-values bindings '()))) (,label ,@(split-values bindings '())))
*unspecified*)) *unspecified*))

142
syntax.mes
View file

@ -1,5 +1,4 @@
;; -*-scheme-*- ;; -*-scheme-*-
;;(define else #t)
(define (syntax-error message thing) (define (syntax-error message thing)
(display "syntax-error:") (display "syntax-error:")
(display message) (display message)
@ -9,75 +8,25 @@
(display "mes:define-syntax...") (display "mes:define-syntax...")
;;(define (caddr x) (car (cdr (cdr x))))
;; (define (caddr x)
;; (display "wanna caddr:")
;; (display x)
;; (newline))
;; (define-macro mes:define-syntax
;; (lambda (form expander)
;; (expander `(define-macro ,(cadr form)
;; (let ((transformer ,(caddr form)))
;; (lambda (form expander)
;; (expander (transformer form
;; (lambda (x) x)
;; eq?)
;; expander))))
;; expander)))
;; (define (dinges form expander)
;; (display "dinges form:")
;; (display form)
;; (newline)
;; `(define-macro BOO ;;;,(cadr form)
;; (let ((transformer ,(caddr form)))
;; (lambda (form expander)
;; (expander (transformer form
;; (lambda (x) x)
;; eq?)
;; expander)))))
;; (define-macro (mes:define-syntax form expander)
;; `(expander (dinges form expander)
;; expander))
(define-macro (mes:define-syntax macro-name transformer . stuff) (define-macro (mes:define-syntax macro-name transformer . stuff)
;; (display "mes:define-syntax:")
;; (newline)
;; (display `(define-macro (,macro-name . args)
;; (,transformer (cons ',macro-name args)
;; (lambda (x) x)
;; eq?)))
;; (newline)
`(define-macro (,macro-name . args) `(define-macro (,macro-name . args)
(,transformer (cons ',macro-name args) (,transformer (cons ',macro-name args)
(lambda (x) x) (lambda (x) x)
eq?) eq?)))
))
;; (define-macro (mes:define-syntax form expander) ;; Rewrite-rule compiler (a.k.a. "extend-syntax")
;; (expander `(define-macro ,(cadr form)
;; (let ((transformer ,(caddr form)))
;; (lambda (form expander)
;; (expander (transformer form
;; (lambda (x) x)
;; eq?)
;; expander))))
;; expander))
;; (define-macro (mes:define-syntax form expander) ;; Example:
;; (expander `(define-macro ((cadr form) form expander) ;;
;; (let ((transformer (caddr form))) ;; (define-syntax or
;; (expander (transformer form ;; (syntax-rules ()
;; (lambda (x) x) ;; ((or) #f)
;; eq?) ;; ((or e) e)
;; expander))) ;; ((or e1 e ...) (let ((temp e1))
;; expander)) ;; (if temp temp (or e ...))))))
(newline) (newline)
(display "mes:define-syntax syntax-rules...") (display "mes:define-syntax syntax-rules...")
(newline) (newline)
@ -96,9 +45,7 @@
(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")
(lambda (exp r c) (lambda (exp r c)
(define %input (r '%input)) ;Gensym these, if you like. (define %input (r '%input)) ;Gensym these, if you like.
@ -111,19 +58,16 @@
(define subkeywords (cadr exp)) (define subkeywords (cadr exp))
(define (make-transformer rules) (define (make-transformer rules)
;;x;;(display "make-transformer") (newline) `(lambda (,%input ,%rename ,%compare)
`(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input))) (let ((,%tail (cdr ,%input)))
;;x;;(display "TEEL:") (display ,%tail) (newline) (cond ,@(map process-rule rules)
(cond ,@(map process-rule rules) (else
(#t ;;else
(syntax-error (syntax-error
"use of macro doesn't match definition" "use of macro doesn't match definition"
,%input)))))) ,%input))))))
(define (process-rule rule) (define (process-rule rule)
;;x;;(display "process-rule") (newline) (cond ((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))
@ -140,8 +84,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)
;;x;;(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))))
(#t `()))) (#t `())))
@ -154,16 +97,14 @@
,@(process-match `(cdr ,%temp) (cdr pattern)))))) ,@(process-match `(cdr ,%temp) (cdr pattern))))))
((or (null? pattern) (boolean? pattern) (char? pattern)) ((or (null? pattern) (boolean? pattern) (char? pattern))
`((eq? ,input ',pattern))) `((eq? ,input ',pattern)))
(#t ;;else (else
`((equal? ,input ',pattern))))) `((equal? ,input ',pattern)))))
(define (process-segment-match input pattern) (define (process-segment-match input pattern)
;;x;;(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))
;;x;;(display "loop") (newline)
(or (null? l) (or (null? l)
(and (pair? l) (and (pair? l)
,@conjuncts ,@conjuncts
@ -173,44 +114,28 @@
;; 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)
;;x;;(display "process-pattern pattern=") (display pattern) (newline)
(cond ((name? pattern) (cond ((name? pattern)
;;x;;(display "name!") (newline)
;;x;;(display "subkeywords: ") (display subkeywords) (newline)
(cond ((memq pattern subkeywords) (cond ((memq pattern subkeywords)
;;;;(member pattern subkeywords)
'()) '())
(#t (#t
;;x;;(display "hiero mapit=") (display mapit)
;;x;;(display " path=") (display path) (newline)
(list (list pattern (mapit path)))))) (list (list pattern (mapit path))))))
((segment-pattern? pattern) ((segment-pattern? pattern)
;;x;;(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
;;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
;;x;;(display " x=%temp ==> mapit==> ") (display path) (newline)
path) ;+++ path) ;+++
(#t (#t
;;x;;(display "not!")
`(map (lambda (,%temp) ,x) `(map (lambda (,%temp) ,x)
,path))))))) ,path)))))))
((pair? pattern) ((pair? pattern)
;;x;;(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 (else '())))
;;x;;(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)
;;x;;(display "process-template") (newline)
(cond ((name? template) (cond ((name? template)
(let ((probe (assq template env))) (let ((probe (assq template env)))
(cond (probe (cond (probe
@ -233,40 +158,37 @@
,@vars))))) ,@vars)))))
(cond ((null? (cddr template)) (cond ((null? (cddr template))
gen) ;+++ gen) ;+++
(#t `(append ,gen ,(process-template (cddr template) (else
rank env))))))))) `(append ,gen ,(process-template (cddr template)
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)))
(#t ;;else (else `(quote ,template))))
`(quote ,template))))
;; 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)
;;x;;(display "meta-variables") (newline)
(cond ((name? pattern) (cond ((name? pattern)
(cond ((memq pattern subkeywords) (cond ((memq pattern subkeywords)
vars) vars)
(#t (cons (cons pattern rank) vars)))) (else (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)
(meta-variables (car pattern) rank (meta-variables (car pattern) rank
(meta-variables (cdr pattern) rank vars))) (meta-variables (cdr pattern) rank vars)))
(#t ;;else (else vars)))
vars)))
;; 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)
;;x;;(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)))
(and probe (>= (cdr probe) rank)))) (and probe (>= (cdr probe) rank))))
(cons template free)) (cons template free))
(#t free))) (else free)))
((segment-template? template) ((segment-template? template)
(free-meta-variables (car template) (free-meta-variables (car template)
rank env rank env
@ -277,14 +199,10 @@
rank env rank env
(free-meta-variables (cdr template) (free-meta-variables (cdr template)
rank env free))) rank env free)))
(#t ;;else (else free)))
free)))
c ;ignored c ;ignored
;; (display "HELLO")
;; (newline)
;; Kludge for Scheme48 linker. ;; Kludge for Scheme48 linker.
;; `(cons ,(make-transformer rules) ;; `(cons ,(make-transformer rules)
;; ',(find-free-names-in-syntax-rules subkeywords rules)) ;; ',(find-free-names-in-syntax-rules subkeywords rules))
@ -311,13 +229,5 @@
(begin exp ...))))) (begin exp ...)))))
(display (mes:when #t "when:hello syntax world")) (display (mes:when #t "when:hello syntax world"))
;; (define-macro (when cond exp . rest)
;; `(if ,cond
;; (begin ,exp . ,rest)))
;; (define-macro (when clause . rest)
;; (list 'cond (list clause (list 'let '() rest))))
(newline) (newline)
'syntax-dun 'syntax-dun

2
test.mes
View file

@ -21,7 +21,7 @@
;; The Maxwell Equations of Software -- John McCarthy page 13 ;; The Maxwell Equations of Software -- John McCarthy page 13
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
;; haha, broken. lat0r ;; haha, broken...lat0r
(define result #f) (define result #f)
(let ((pass 0) (let ((pass 0)
(fail 0) (fail 0)