From efdd84b4c4adcfbd9e0d20f9f52793b8bf81eef8 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 22 Jul 2016 17:13:51 +0200 Subject: [PATCH] mes.c: add new macro type, junk *macro* hack. --- GNUmakefile | 4 +- TODO | 8 ++- mes.c | 194 +++++++++++++++++++--------------------------------- mes.test | 8 +-- scm.mes | 1 - syntax.mes | 142 +++++++------------------------------- test.mes | 2 +- 7 files changed, 106 insertions(+), 253 deletions(-) diff --git a/GNUmakefile b/GNUmakefile index 5e0564e3..db4f96bb 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,6 +1,6 @@ .PHONY: all check default -#CFLAGS=-std=c99 -O3 -finline-functions -CFLAGS=-std=c99 -g +CFLAGS=-std=c99 -O3 -finline-functions +#CFLAGS=-std=c99 -g default: all diff --git a/TODO b/TODO index 8394a8cb..19bdfd9e 100644 --- a/TODO +++ b/TODO @@ -1,7 +1,9 @@ -*-mode:org-*- * define-syntax and syntax-rules ** syntax.mes -** or psyntax.pp +Using define-macro-based version. +** psyntax.pp +Find out how to hook-up sc-expand in eval/apply. ** bugs *** c2.mes *** c4.mes @@ -11,8 +13,8 @@ *** v c1.mes *** v c3.mes *** v using (let () ...) in macro.mes/syntax.mes -*** syntax.mes: closuring name? etc in syntax.mes -*** syntax.mes: closuring: indicators: eval: no such symbol: --- +*** v syntax.mes: closuring name? etc in syntax.mes +*** v syntax.mes: closuring: indicators: eval: no such symbol: --- *** <=, => take only 2 arguments ** run PEG ** parse C using PEG diff --git a/mes.c b/mes.c index f72ebf20..80cd827e 100644 --- a/mes.c +++ b/mes.c @@ -34,10 +34,9 @@ #include #define DEBUG 0 -#define XDEBUG 0 #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}; struct scm_t; typedef struct scm_t* (*function0_t) (void); @@ -61,6 +60,7 @@ typedef struct scm_t { function3_t function3; functionn_t functionn; struct scm_t* cdr; + struct scm_t* macro; struct scm_t** vector; }; } scm; @@ -91,7 +91,6 @@ scm symbol_quote = {SYMBOL, "quote"}; scm symbol_quasiquote = {SYMBOL, "quasiquote"}; scm symbol_unquote = {SYMBOL, "unquote"}; scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"}; -scm symbol_macro = {SYMBOL, "*macro*"}; scm symbol_call_with_values = {SYMBOL, "call-with-values"}; scm symbol_current_module = {SYMBOL, "current-module"}; @@ -155,9 +154,9 @@ eq_p (scm *x, scm *y) } 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 * @@ -286,8 +285,8 @@ apply_env (scm *fn, scm *x, scm *a) a = cdadr (fn); return eval (cons (&symbol_begin, body), pairlis (args, x, a)); } - else if ((macro = assq (car (fn), cdr (assq (&symbol_macro, a)))) != &scm_f) { - scm *r = apply_env (eval (cdr (macro), a), cdr (fn), a); + else if ((macro = lookup_macro (car (fn), a)) != &scm_f) { + scm *r = apply_env (eval (macro, a), cdr (fn), a); scm *e = eval (r, 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); } +scm *make_symbol (char const *s); + scm * eval (scm *e, scm *a) { @@ -318,84 +319,35 @@ eval (scm *e, scm *a) return e; else if (atom_p (car (e)) == &scm_t) { - //scm *macro; if (car (e) == &symbol_quote) return cadr (e); if (car (e) == &symbol_begin) { - - scm *orig_a = a; - 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 *macros = &scm_nil; - WHILE (e->type == PAIR - && (eq_p (car (e), &symbol_define) == &scm_t - || eq_p (car (e), &symbol_define_macro) == &scm_t)) { - if (eq_p (car (e), &symbol_define) == &scm_t) + while (body != &scm_nil) { + e = car (body); + body = cdr (body); + if (e->type == PAIR + && (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)); - else if (eq_p (car (e), &symbol_define_macro) == &scm_t) - 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); + e = &scm_unspecified; } + else break; } - breek:; - - 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) { + a = append2 (defines, a); + while (defines != &scm_nil) { scm *name = caar (defines); - scm *d = cdar (defines); - scm *x = define (d, 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); - - names = cons (name, names); - values = cons (cdr (x), values); } - - WHILE (macros != &scm_nil) { - scm *name = caar (macros); - scm *d = cdar (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)); + scm *fubar = cons (&scm_dot, &scm_dot); + scm *r = eval (e, cons (fubar, a)); + if (r->type == PAIR && macro_p (cdr (r))) + a = cons (r, a); // macros defining macros... if (body == &scm_nil) return r; return eval (cons (&symbol_begin, body), a); } @@ -410,9 +362,9 @@ eval (scm *e, scm *a) if (car (e) == &symbol_cond) return evcon (cdr (e), a); if (eq_p (car (e), &symbol_define_macro) == &scm_t) - return define_macro (e, a); - if ((macro = assq (car (e), cdr (assq (&symbol_macro, a)))) != &scm_f) - return eval (apply_env (cdr (macro), cdr (e), a), a); + return define (e, a); + if ((macro = lookup_macro (car (e), a)) != &scm_f) + return eval (apply_env (macro, cdr (e), a), a); if (car (e) == &symbol_set_x) return set_env_x (cadr (e), eval (caddr (e), a), a); } @@ -558,6 +510,15 @@ make_char (int x) return p; } +scm * +make_macro (scm *x) //int +{ + scm *p = malloc (sizeof (scm)); + p->type = MACRO; + p->macro = x; + return p; +} + scm * make_number (int x) { @@ -697,37 +658,33 @@ lookup (char *x, scm *a) { if (isdigit (*x) || (*x == '-' && isdigit (*(x+1)))) 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_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_cond.name)) return &symbol_cond; 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_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_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_cdr.name)) return &scm_cdr; if (!strcmp (x, scm_display.name)) return &scm_display; if (!strcmp (x, scm_builtin_list.name)) return &scm_builtin_list; - + if (*x == '\'') return &symbol_quote; if (*x == '`') return &symbol_quasiquote; if (*x == ',' && *(x+1) == '@') return &symbol_unquote_splicing; 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); } @@ -838,6 +795,11 @@ display_helper (scm *x, bool cont, char *sep, bool quote) 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) 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 == PAIR) { if (car (x) == &symbol_circ) { @@ -1146,25 +1108,7 @@ mes_environment () { 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" -#endif return a; } @@ -1192,25 +1136,27 @@ def (scm *x) scm * define (scm *x, scm *a) { - if (atom_p (cadr (x)) != &scm_f) - return cons (cadr (x), eval (caddr (x), cons (cons (cadr (x), cadr (x)), a))); - scm *p = pairlis (cadr (x), cadr (x), a); - return cons (caadr (x), eval (make_lambda (cdadr (x), cddr (x)), p)); -} - -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))); + scm *e; + scm *name = cadr (x); + if (name->type != PAIR) + e = eval (caddr (x), cons (cons (cadr (x), cadr (x)), a)); else { + name = car (name); 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))); - return a; + if (eq_p (car (x), &symbol_define_macro) == &scm_t) + 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 * diff --git a/mes.test b/mes.test index a53349a5..debeb604 100755 --- a/mes.test +++ b/mes.test @@ -1,21 +1,17 @@ #! /bin/sh -set -x +#set -x mes=${1-./mes.scm} echo 0 | $mes echo 1 | $mes -#echo car | $mes "((0 1))" echo "(car '(0 1))" | $mes echo "(car (quote (0 1)))" | $mes echo "(car '(0 1))" | $mes -#echo cdr | $mes "((0 1))" echo "(cdr '(0 1))" | $mes -#echo cons | $mes "(0 1)" 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 "((label fun (lambda (x) x)) 2 2)" | $mes echo "(< 0 0)" | $mes echo "(< 0 1)" | $mes +# LISP-1.5 label dropped for now # echo "((label fun\ # (lambda (x) (cons x\ # (cond ((< 0 x) (fun (- x 1)))\ diff --git a/scm.mes b/scm.mes index 8e6a3691..214d26e1 100755 --- a/scm.mes +++ b/scm.mes @@ -44,7 +44,6 @@ (define-macro (let-loop label bindings rest) `((lambda (,label) - (display "loop") (newline) (set! ,label (lambda ,(split-params bindings '()) ,@rest)) (,label ,@(split-values bindings '()))) *unspecified*)) diff --git a/syntax.mes b/syntax.mes index 2a46f332..f312a7fc 100644 --- a/syntax.mes +++ b/syntax.mes @@ -1,5 +1,4 @@ ;; -*-scheme-*- -;;(define else #t) (define (syntax-error message thing) (display "syntax-error:") (display message) @@ -9,75 +8,25 @@ (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) - ;; (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) (,transformer (cons ',macro-name args) (lambda (x) x) - eq?) - )) + eq?))) -;; (define-macro (mes:define-syntax form expander) -;; (expander `(define-macro ,(cadr form) -;; (let ((transformer ,(caddr form))) -;; (lambda (form expander) -;; (expander (transformer form -;; (lambda (x) x) -;; eq?) -;; expander)))) -;; expander)) +;; Rewrite-rule compiler (a.k.a. "extend-syntax") -;; (define-macro (mes:define-syntax form expander) -;; (expander `(define-macro ((cadr form) form expander) -;; (let ((transformer (caddr form))) -;; (expander (transformer form -;; (lambda (x) x) -;; eq?) -;; expander))) -;; expander)) +;; Example: +;; +;; (define-syntax or +;; (syntax-rules () +;; ((or) #f) +;; ((or e) e) +;; ((or e1 e ...) (let ((temp e1)) +;; (if temp temp (or e ...)))))) (newline) - (display "mes:define-syntax syntax-rules...") (newline) @@ -96,9 +45,7 @@ (memq (cadr pattern) indicators-for-zero-or-more))) (define indicators-for-zero-or-more (list (string->symbol "...") '---)) - - ;;(display "BOOO") - + (lambda (exp r c) (define %input (r '%input)) ;Gensym these, if you like. @@ -111,19 +58,16 @@ (define subkeywords (cadr exp)) (define (make-transformer rules) - ;;x;;(display "make-transformer") (newline) - `(lambda (,%input ,%rename ,%compare) + `(lambda (,%input ,%rename ,%compare) (let ((,%tail (cdr ,%input))) - ;;x;;(display "TEEL:") (display ,%tail) (newline) - (cond ,@(map process-rule rules) - (#t ;;else + (cond ,@(map process-rule rules) + (else (syntax-error "use of macro doesn't match definition" ,%input)))))) (define (process-rule rule) - ;;x;;(display "process-rule") (newline) - (cond ((and (pair? rule) + (cond ((and (pair? rule) (pair? (cdr rule)) (null? (cddr rule))) (let ((pattern (cdar rule)) @@ -140,8 +84,7 @@ ;; Generate code to test whether input expression matches pattern (define (process-match input pattern) - ;;x;;(display "process-match") (newline) - (cond ((name? pattern) + (cond ((name? pattern) (cond ((member pattern subkeywords) `((,%compare ,input (,%rename ',pattern)))) (#t `()))) @@ -154,16 +97,14 @@ ,@(process-match `(cdr ,%temp) (cdr pattern)))))) ((or (null? pattern) (boolean? pattern) (char? pattern)) `((eq? ,input ',pattern))) - (#t ;;else + (else `((equal? ,input ',pattern))))) (define (process-segment-match input pattern) - ;;x;;(display "process-segment-match") (newline) (let ((conjuncts (process-match '(car l) pattern))) (cond ((null? conjuncts) `((list? ,input))) ;+++ (#t `((let loop ((l ,input)) - ;;x;;(display "loop") (newline) (or (null? l) (and (pair? l) ,@conjuncts @@ -173,44 +114,28 @@ ;; This is pretty bad, but it seems to work (can't say why). (define (process-pattern pattern path mapit) - ;;x;;(display "process-pattern pattern=") (display pattern) (newline) (cond ((name? pattern) - ;;x;;(display "name!") (newline) - ;;x;;(display "subkeywords: ") (display subkeywords) (newline) (cond ((memq pattern subkeywords) -;;;;(member pattern subkeywords) '()) (#t - ;;x;;(display "hiero mapit=") (display mapit) - ;;x;;(display " path=") (display path) (newline) (list (list pattern (mapit path)))))) ((segment-pattern? pattern) - ;;x;;(display "segment!") (newline) (process-pattern (car pattern) %temp (lambda (x) ;temp is free in x - ;;x;;(display "mapit x=") (display x) (newline) (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) ;+++ (#t - ;;x;;(display "not!") `(map (lambda (,%temp) ,x) ,path))))))) ((pair? pattern) - ;;x;;(display "pair!") (newline) (append (process-pattern (car pattern) `(car ,path) mapit) (process-pattern (cdr pattern) `(cdr ,path) mapit))) - (#t ;;else - ;;x;;(display "else!") (newline) - '()))) + (else '()))) ;; Generate code to compose the output expression according to template (define (process-template template rank env) - ;;x;;(display "process-template") (newline) (cond ((name? template) (let ((probe (assq template env))) (cond (probe @@ -233,40 +158,37 @@ ,@vars))))) (cond ((null? (cddr template)) gen) ;+++ - (#t `(append ,gen ,(process-template (cddr template) - rank env))))))))) + (else + `(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)))) + (else `(quote ,template)))) ;; Return an association list of (var . rank) (define (meta-variables pattern rank vars) - ;;x;;(display "meta-variables") (newline) (cond ((name? pattern) (cond ((memq pattern subkeywords) vars) - (#t (cons (cons pattern rank) vars)))) + (else (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))) + (else vars))) ;; Return a list of meta-variables of given higher rank (define (free-meta-variables template rank env free) - ;;x;;(display "free-meta-variables") (newline) (cond ((name? template) (cond ((and (not (memq template free)) (let ((probe (assq template env))) (and probe (>= (cdr probe) rank)))) (cons template free)) - (#t free))) + (else free))) ((segment-template? template) (free-meta-variables (car template) rank env @@ -277,14 +199,10 @@ rank env (free-meta-variables (cdr template) rank env free))) - (#t ;;else - free))) + (else free))) c ;ignored - ;; (display "HELLO") - ;; (newline) - ;; Kludge for Scheme48 linker. ;; `(cons ,(make-transformer rules) ;; ',(find-free-names-in-syntax-rules subkeywords rules)) @@ -311,13 +229,5 @@ (begin exp ...))))) (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) 'syntax-dun diff --git a/test.mes b/test.mes index 36177ead..23e126df 100644 --- a/test.mes +++ b/test.mes @@ -21,7 +21,7 @@ ;; The Maxwell Equations of Software -- John McCarthy page 13 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf -;; haha, broken. lat0r +;; haha, broken...lat0r (define result #f) (let ((pass 0) (fail 0)