From 4c9690996cab55f56cb91e82d0661851ee7fdbe4 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Mar 2018 10:05:55 +0100 Subject: [PATCH] mes: Iterative recursive macro expand. * src/mes.c (eval_apply): Iterative recursive macro expand. * src/posix.c (set_current_input_port): Return previous port. * module/mes/catch.mes (%eh): Use core:display. * module/mes/display.mes (display-cut, display-cut2): Move macro definitions to toplevel. --- check-mescc.sh | 2 +- module/mes/catch.mes | 12 +- module/mes/display.mes | 16 +-- module/mes/guile.mes | 39 +++++- module/mes/peg.mes | 7 +- module/mes/psyntax.mes | 17 +-- scripts/repl.mes | 11 +- src/mes.c | 298 +++++++++++++++++++++++++++++++---------- src/posix.c | 5 +- tests/psyntax.test | 181 +++++++++++++------------ 10 files changed, 391 insertions(+), 197 deletions(-) diff --git a/check-mescc.sh b/check-mescc.sh index 382a7b28..d71f27e9 100755 --- a/check-mescc.sh +++ b/check-mescc.sh @@ -20,7 +20,7 @@ export MES=${MES-src/mes.gcc} export MESCC=${MESCC-scripts/mescc.mes} -#export MES_ARENA=${MES_ARENA-200000000} #9GiB +#export MES_ARENA=${MES_ARENA-200000000} > 12GB mem GUILE=${GUILE-guile} MES=${MES-./mes} diff --git a/module/mes/catch.mes b/module/mes/catch.mes index bc0d5dd8..5be7ef83 100644 --- a/module/mes/catch.mes +++ b/module/mes/catch.mes @@ -23,14 +23,14 @@ (define %eh (make-fluid (lambda (key . args) - (if (defined? 'simple-format) + (if #f ;;(defined? 'simple-format) (simple-format (current-error-port) "unhandled exception:~a:~a\n" key args) (begin - (display "unhandled exception:" (current-error-port)) - (display key (current-error-port)) - (display ":" (current-error-port)) - (write args (current-error-port)) - (newline (current-error-port)))) + (core:display-error "unhandled exception:") + (core:display-error key) + (core:display-error ":") + (core:write-error args) + (core:display-error "\n"))) (exit 1)))) (define (catch key thunk handler) diff --git a/module/mes/display.mes b/module/mes/display.mes index 91269703..beb2b075 100644 --- a/module/mes/display.mes +++ b/module/mes/display.mes @@ -40,16 +40,16 @@ (and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e)))) (lambda (a) (xassq x (cdr a))))))) +(define-macro (display-cut f slot n1) + `(lambda (slot) (,f slot ,n1))) + +(define-macro (display-cut2 f slot n1 n2) + `(lambda (slot) (,f slot ,n1 ,n2))) + (define (display x . rest) (let* ((port (if (null? rest) (current-output-port) (car rest))) (write? (and (pair? rest) (pair? (cdr rest)) (cadr rest)))) - (define-macro (cut f slot n1) - `(lambda (slot) (,f slot ,n1))) - - (define-macro (cut2 f slot n1 n2) - `(lambda (slot) (,f slot ,n1 ,n2))) - (define (display-char x port write?) (cond ((and write? (or (eq? x #\") (eq? x #\\))) (write-char #\\ port) @@ -60,7 +60,7 @@ (#t (write-char x port)))) (define (d x cont? sep) - (for-each (cut write-char <> port) (string->list sep)) + (for-each (display-cut write-char <> port) (string->list sep)) (cond ((eof-object? x) (display "#" port)) @@ -114,7 +114,7 @@ ((or (keyword? x) (special? x) (string? x) (symbol? x)) (if (and (string? x) write?) (write-char #\" port)) (if (keyword? x) (display "#:" port)) - (for-each (cut2 display-char <> port write?) (string->list x)) + (for-each (display-cut2 display-char <> port write?) (string->list x)) (if (and (string? x) write?) (write-char #\" port))) ((vector? x) (display "#(" port) diff --git a/module/mes/guile.mes b/module/mes/guile.mes index 627ccf42..2397d4c3 100644 --- a/module/mes/guile.mes +++ b/module/mes/guile.mes @@ -28,7 +28,7 @@ (define-macro (include-from-path file) (let loop ((path (cons %moduledir (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:)))) - (if (getenv "MES_DEBUG") + (if (getenv "MES_DEBUG") ;;(format (current-error-port) "include-from-path: ~s [PATH:~s]\n" file path) (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n"))) (if (null? path) (error "include-from-path: not found: " file) @@ -175,3 +175,40 @@ (let ((lst (filter (negate string-null?) (string-split file-name #\/)))) (if (<= (length lst) 1) "." (string-join (list-head lst (1- (length lst))) "/")))) + +;; FIXME: c&p from display +(define (with-output-to-string thunk) + (define save-write-byte write-byte) + (let ((stdout '())) + (set! write-byte + (lambda (x . rest) + (let ((out? (or (null? rest) (eq? (car rest) (current-output-port))))) + (if (not out?) (apply save-write-byte (cons x rest)) + (begin + (set! stdout (append stdout (list (integer->char x)))) + x))))) + (thunk) + (let ((r (apply string stdout))) + (set! write-byte save-write-byte) + r))) + +;; FIXME: c&p from display +(define (simple-format destination format . rest) + (let ((port (if (boolean? destination) (current-output-port) destination)) + (lst (string->list format))) + (define (simple-format lst args) + (if (pair? lst) + (let ((c (car lst))) + (if (not (eq? c #\~)) (begin (write-char (car lst) port) + (simple-format (cdr lst) args)) + (let ((c (cadr lst))) + (case c + ((#\a) (display (car args) port)) + ((#\s) (write (car args) port))) + (simple-format (cddr lst) (cdr args))))))) + + (if destination (simple-format lst rest) + (with-output-to-string + (lambda () (simple-format lst rest)))))) +(define format simple-format) + diff --git a/module/mes/peg.mes b/module/mes/peg.mes index ac3ba7bf..261178b3 100644 --- a/module/mes/peg.mes +++ b/module/mes/peg.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen +;;; Copyright © 2016,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -25,11 +25,14 @@ ;;; Code: +(mes-use-module (mes let)) +(mes-use-module (mes scm)) (mes-use-module (mes guile)) (mes-use-module (mes pretty-print)) (mes-use-module (mes psyntax)) (mes-use-module (srfi srfi-13)) -(mes-use-module (srfi srfi-9-psyntax)) +;;(mes-use-module (srfi srfi-9-psyntax)) +;;(mes-use-module (srfi srfi-9)) (mes-use-module (mes pmatch)) (include-from-path "mes/peg/cache.scm") (include-from-path "mes/peg/codegen.scm") diff --git a/module/mes/psyntax.mes b/module/mes/psyntax.mes index 5618f12f..abaa9969 100644 --- a/module/mes/psyntax.mes +++ b/module/mes/psyntax.mes @@ -22,22 +22,7 @@ ;;; Code: -(define (env:define a+ a) - (set-cdr! a+ (cdr a)) - (set-cdr! a a+) - (set-cdr! (assq (quote *closure*) a) a+) - (car a+)) - -(define-macro (define ARGS . BODY) - (cons* (quote env:define) - (cons* (quote cons) - (cons* (quote sexp:define) - (list (quote quote) - (cons (quote DEFINE) (cons ARGS BODY))) - (quote ((current-module)))) - (quote ((list)))) - (quote ((current-module))))) - +(mes-use-module (mes scm)) (mes-use-module (mes psyntax-0)) (include-from-path "mes/psyntax.pp") (mes-use-module (mes psyntax-1)) diff --git a/scripts/repl.mes b/scripts/repl.mes index d086e58f..56f4d385 100755 --- a/scripts/repl.mes +++ b/scripts/repl.mes @@ -10,7 +10,7 @@ exit $? !# ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -27,6 +27,10 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . +(mes-use-module (mes repl)) +(mes-use-module (mes syntax)) +(primitive-load 0) + (let* ((files (cdr (command-line))) (file (if (pair? files) (car files))) (file (if (and (equal? file "--") (pair? files) (pair? (cdr files))) (cadr files) file))) @@ -37,9 +41,6 @@ exit $? (format (current-error-port) "mescc.mes (mes) ~a\n" %version) (exit 0)))) -;;(mes-use-module (mes scm)) -(mes-use-module (mes syntax)) -(mes-use-module (mes repl)) - (repl) () + diff --git a/src/mes.c b/src/mes.c index 8788bc5d..11b828b0 100644 --- a/src/mes.c +++ b/src/mes.c @@ -189,13 +189,25 @@ struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0}; struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0}; struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0}; -struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0}; +struct scm scm_vm_eval_macro_expand_eval = {TSPECIAL, "*vm:eval-macro-expand-eval*",0}; +struct scm scm_vm_eval_macro_expand_expand = {TSPECIAL, "*vm:eval-macro-expand-expand*",0}; struct scm scm_vm_eval_check_func = {TSPECIAL, "*vm-eval-check-func*",0}; struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0}; struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0}; +struct scm scm_vm_macro_expand_define = {TSPECIAL, "*vm:core:macro-expand-define*",0}; +struct scm scm_vm_macro_expand_define_macro = {TSPECIAL, "*vm:core:macro-expand-define-macro*",0}; +struct scm scm_vm_macro_expand_lambda = {TSPECIAL, "*vm:core:macro-expand-lambda*",0}; +struct scm scm_vm_macro_expand_set_x = {TSPECIAL, "*vm:core:macro-expand-set!*",0}; +struct scm scm_vm_begin_expand_primitive_load = {TSPECIAL, "*vm:core:begin-expand-primitive-load*",0}; +struct scm scm_vm_begin_primitive_load = {TSPECIAL, "*vm:core:begin-primitive-load*",0}; +struct scm scm_vm_macro_expand_car = {TSPECIAL, "*vm:core:macro-expand-car*",0}; +struct scm scm_vm_macro_expand_cdr = {TSPECIAL, "*vm:macro-expand-cdr*",0}; +struct scm scm_vm_begin_expand = {TSPECIAL, "*vm:begin-expand*",0}; +struct scm scm_vm_begin_expand_eval = {TSPECIAL, "*vm:begin-expand-eval*",0}; +struct scm scm_vm_begin_expand_macro = {TSPECIAL, "*vm:begin-expand-macro*",0}; struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0}; struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0}; -struct scm scm_vm_begin2 = {TSPECIAL, "*vm-begin2*",0}; +struct scm scm_vm_begin_eval = {TSPECIAL, "*vm:begin-eval*",0}; struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0}; struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0}; struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0}; @@ -741,6 +753,7 @@ gc_pop_frame () ///((internal)) SCM eval_apply () { + int expanding_p = 0; eval_apply: gc_check (); switch (r3) @@ -759,13 +772,24 @@ eval_apply () #endif case cell_vm_eval_define: goto eval_define; case cell_vm_eval_set_x: goto eval_set_x; - case cell_vm_eval_macro: goto eval_macro; + case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval; + case cell_vm_eval_macro_expand_expand: goto eval_macro_expand_expand; case cell_vm_eval_check_func: goto eval_check_func; case cell_vm_eval2: goto eval2; case cell_vm_macro_expand: goto macro_expand; + case cell_vm_macro_expand_define: goto macro_expand_define; + case cell_vm_macro_expand_define_macro: goto macro_expand_define_macro; + case cell_vm_macro_expand_lambda: goto macro_expand_lambda; + case cell_vm_macro_expand_set_x: goto macro_expand_set_x; + case cell_vm_macro_expand_car: goto macro_expand_car; + case cell_vm_macro_expand_cdr: goto macro_expand_cdr; case cell_vm_begin: goto begin; - case cell_vm_begin_read_input_file: goto begin_read_input_file; - case cell_vm_begin2: goto begin2; + case cell_vm_begin_eval: goto begin_eval; + case cell_vm_begin_primitive_load: goto begin_primitive_load; + case cell_vm_begin_expand: goto begin_expand; + case cell_vm_begin_expand_eval: goto begin_expand_eval; + case cell_vm_begin_expand_macro: goto begin_expand_macro; + case cell_vm_begin_expand_primitive_load: goto begin_expand_primitive_load; case cell_vm_if: goto vm_if; case cell_vm_if_expr: goto if_expr; case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2; @@ -914,6 +938,12 @@ eval_apply () eval_null_p: x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply; } +#else + eval_car:; + eval_cdr:; + eval_cons:; + eval_null_p:; + #endif // MES_FIXED_PRIMITIVES case cell_symbol_quote: { @@ -937,8 +967,15 @@ eval_apply () } case cell_vm_macro_expand: { - push_cc (CADR (r1), r1, r0, cell_vm_macro_expand); + push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval); goto eval; + eval_macro_expand_eval: + push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand); + expanding_p++; + goto macro_expand; + eval_macro_expand_expand: + expanding_p--; + goto vm_return; } default: { @@ -978,10 +1015,10 @@ eval_apply () } push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval; eval_check_func: - push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis; + push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis; eval2: - r1 = cons (CAR (r2), r1); - goto apply; + r1 = cons (CAR (r2), r1); + goto apply; } } } @@ -993,74 +1030,186 @@ eval_apply () default: goto vm_return; } - SCM macro; - SCM expanders; macro_expand: - if (TYPE (r1) == TPAIR - && (macro = lookup_macro_ (CAR (r1), r0)) != cell_f) - { - r1 = cons (macro, CDR (r1)); - goto apply; - } - else if (TYPE (r1) == TPAIR - && TYPE (CAR (r1)) == TSYMBOL - && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined) - && ((macro = assq (CAR (r1), expanders)) != cell_f)) - { - SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0); - if (sc_expand != cell_undefined && sc_expand != cell_f) - { - r1 = cons (sc_expand, cons (r1, cell_nil)); - goto apply; - } - } - goto vm_return; + { + SCM macro; + SCM expanders; + + if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote) + goto vm_return; + + if (TYPE (r1) == TPAIR + && (macro = lookup_macro_ (CAR (r1), r0)) != cell_f) + { + r1 = cons (macro, CDR (r1)); + push_cc (r1, cell_nil, r0, cell_vm_macro_expand); + goto apply; + } + if (CAR (r1) == cell_symbol_define + || CAR (r1) == cell_symbol_define_macro) + { + push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_define); + goto macro_expand; + macro_expand_define: + CDDR (r2) = r1; + r1 = r2; + if (CAR (r1) == cell_symbol_define_macro) + { + push_cc (r1, r1, r0, cell_vm_macro_expand_define_macro); + goto eval; + macro_expand_define_macro: + r1 = r2; + } + goto vm_return; + } + + if (CAR (r1) == cell_symbol_lambda) + { + push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda); + goto macro_expand; + macro_expand_lambda: + CDDR (r2) = r1; + r1 = r2; + goto vm_return; + } + + if (CAR (r1) == cell_symbol_set_x) + { + push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x); + goto macro_expand; + macro_expand_set_x: + CDDR (r2) = r1; + r1 = r2; + goto vm_return; + } + + if (TYPE (r1) == TPAIR + && TYPE (CAR (r1)) == TSYMBOL + && CAR (r1) != cell_symbol_begin + && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined) + && ((macro = assq (CAR (r1), expanders)) != cell_f)) + { + SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0); + r2 = r1; + if (sc_expand != cell_undefined && sc_expand != cell_f) + { + r1 = cons (sc_expand, cons (r1, cell_nil)); + goto apply; + } + } + + push_cc (CAR (r1), r1, r0, cell_vm_macro_expand_car); + goto macro_expand; + + macro_expand_car: + CAR (r2) = r1; + r1 = r2; + if (CDR (r1) == cell_nil) + goto vm_return; + + push_cc (CDR (r1), r1, r0, cell_vm_macro_expand_cdr); + goto macro_expand; + + macro_expand_cdr: + CDR (r2) = r1; + r1 = r2; + + goto vm_return; + } begin: x = cell_unspecified; - while (r1 != cell_nil) { - gc_check (); - if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR) - { - if (CAAR (r1) == cell_symbol_begin) - r1 = append2 (CDAR (r1), CDR (r1)); - else if (CAAR (r1) == cell_symbol_primitive_load) - { - // push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file); - // goto apply; + while (r1 != cell_nil) + { + gc_check (); + if (TYPE (r1) == TPAIR) + { + if (CAAR (r1) == cell_symbol_primitive_load) + { + SCM program = cons (CAR (r1), cell_nil); + push_cc (program, r1, r0, cell_vm_begin_primitive_load); + goto begin_expand; + begin_primitive_load: + CAR (r2) = r1; + r1 = r2; + } + } - push_cc (CAR (CDAR (r1)), r1, r0, cell_vm_begin_read_input_file); - goto eval; // FIXME: expand too?! - begin_read_input_file:; - SCM input = r1; - if ((TYPE (r1) == TNUMBER && VALUE (r1) == 0)) - ; - else - input = set_current_input_port (open_input_file (r1)); - push_cc (input, r2, r0, cell_vm_return); - x = read_input_file_env (r0); - gc_pop_frame (); - r1 = x; - input = r1; -#if DEBUG - eputs (" ..2.r2="); write_error_ (r2); eputs ("\n"); - eputs (" => result r1="); write_error_ (r1); eputs ("\n"); -#endif - set_current_input_port (input); - r1 = append2 (r1, cons (cell_t, CDR (r2))); - } - } - if (CDR (r1) == cell_nil) - { - r1 = CAR (r1); - goto eval; - } - push_cc (CAR (r1), r1, r0, cell_vm_begin2); - goto eval; - begin2: - x = r1; - r1 = CDR (r2); - } + if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR) + { + if (CAAR (r1) == cell_symbol_begin) + r1 = append2 (CDAR (r1), CDR (r1)); + } + if (CDR (r1) == cell_nil) + { + r1 = CAR (r1); + goto eval; + } + push_cc (CAR (r1), r1, r0, cell_vm_begin_eval); + goto eval; + begin_eval: + x = r1; + r1 = CDR (r2); + } + r1 = x; + goto vm_return; + + + begin_expand: + x = cell_unspecified; + while (r1 != cell_nil) + { + gc_check (); + + if (TYPE (r1) == TPAIR) + { + if (TYPE (CAR (r1)) == TPAIR && CAAR (r1) == cell_symbol_begin) + r1 = append2 (CDAR (r1), CDR (r1)); + if (CAAR (r1) == cell_symbol_primitive_load) + { + push_cc (CADR (CAR (r1)), r1, r0, cell_vm_begin_expand_primitive_load); + goto eval; // FIXME: expand too?! + begin_expand_primitive_load:; + SCM input; // = current_input_port (); + if (TYPE (r1) == TNUMBER && VALUE (r1) == 0) + ; + else if (TYPE (r1) == TSTRING) + input = set_current_input_port (open_input_file (r1)); + else + assert (0); + + push_cc (input, r2, r0, cell_vm_return); + x = read_input_file_env (r0); + gc_pop_frame (); + input = r1; + r1 = x; + set_current_input_port (input); + r1 = cons (cell_symbol_begin, r1); + CAR (r2) = r1; + r1 = r2; + continue; + } + } + + push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro); + expanding_p++; + goto macro_expand; + begin_expand_macro: + expanding_p--; + if (r1 != CAR (r2)) + { + CAR (r2) = r1; + r1 = r2; + continue; + } + r1 = r2; + + push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval); + goto eval; + begin_expand_eval: + x = r1; + r1 = CDR (r2); + } r1 = x; goto vm_return; @@ -1481,6 +1630,7 @@ main (int argc, char *argv[]) SCM lst = cell_nil; for (int i=argc-1; i>=0; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst); + r0 = acons (cell_symbol_argv, lst, r0); // FIXME r0 = acons (cell_symbol_argv, lst, r0); push_cc (r2, cell_unspecified, r0, cell_unspecified); if (g_debug > 1) @@ -1489,14 +1639,14 @@ main (int argc, char *argv[]) write_error_ (r1); eputs ("\n"); } - r3 = cell_vm_begin; + r3 = cell_vm_begin_expand; r1 = eval_apply (); write_error_ (r1); eputs ("\n"); gc (g_stack); if (g_debug) { - eputs ("\nstats: ["); + eputs ("\ngc stats: ["); eputs (itoa (g_free)); eputs ("]\n"); } diff --git a/src/posix.c b/src/posix.c index 95b4df73..fe7c9b38 100644 --- a/src/posix.c +++ b/src/posix.c @@ -1,6 +1,6 @@ /* -*-comment-start: "//";comment-end:""-*- * Mes --- Maxwell Equations of Software - * Copyright © 2016,2017 Jan Nieuwenhuizen + * Copyright © 2016,2017,2018 Jan Nieuwenhuizen * * This file is part of Mes. * @@ -156,8 +156,9 @@ open_input_file (SCM file_name) SCM set_current_input_port (SCM port) { + int prev = g_stdin; g_stdin = VALUE (port) ? VALUE (port) : STDIN; - return current_input_port (); + return MAKE_NUMBER (prev); } SCM diff --git a/tests/psyntax.test b/tests/psyntax.test index 701f0b05..71ef46c1 100755 --- a/tests/psyntax.test +++ b/tests/psyntax.test @@ -9,7 +9,7 @@ exit $? ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen +;;; Copyright © 2016,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -46,17 +46,19 @@ exit $? (pass-if "first dummy" #t) (pass-if-not "second dummy" #f) -(when (not guile?) - (pass-if "andmap" - (seq? (andmap (lambda (x) (> x 0)) '(3 2 1)) #t)) +(cond-expand + (guile) + (mes + (pass-if "andmap" + (seq? (andmap (lambda (x) (> x 0)) '(3 2 1)) #t)) - (pass-if "andmap 2" - (seq? (andmap (lambda (x) (> x 0)) '(3 2 1 0)) #f)) + (pass-if "andmap 2" + (seq? (andmap (lambda (x) (> x 0)) '(3 2 1 0)) #f)) - (pass-if "putprop" (putprop 'foo '*sc-expander 'bar)) + (pass-if "putprop" (putprop 'foo '*sc-expander 'bar)) - (pass-if "getprop" - (seq? (getprop 'foo '*sc-expander) 'bar)) + (pass-if "getprop" + (seq? (getprop 'foo '*sc-expander) 'bar))) ) (pass-if "syntax-case" @@ -76,84 +78,97 @@ exit $? (sequal? (syntax-object->datum (syntax (set! a b))) '(set! a b))) -(pass-if "syntax-case swap!" - (sequal? (syntax-object->datum - (let ((exp '(set! a b))) - (syntax-case exp () - ((swap! a b) - (syntax - (let ((temp a)) - (set! a b) - (set! b temp))))))) - '(let ((temp a)) (set! a b) (set! b temp)))) +(pass-if-equal "syntax-case swap!" + '((lambda (temp) + (set! a b) + (set! b temp)) + a) + (syntax-object->datum + (let ((exp '(set! a b))) + (syntax-case exp () + ((swap! a b) + (syntax + ((lambda (temp) + (set! a b) + (set! b temp)) + a))))))) -(when (not guile?) - (pass-if "syntax-case manual swap!" - (sequal? - (let* ((sc (sc-expand '(syntax-case exp () ((swap! a b) (syntax (let ((temp a)) (set! a b) (set! b temp))))))) - (exp '(swap foo bar)) - (foo "foo") - (bar "bar") - (s (eval sc (current-module))) - (d (syntax-object->datum s))) - (eval d (current-module)) - (list foo bar)) - '("bar" "foo")))) +(pass-if-equal "syntax-case swap! let" + '(let ((temp a)) (set! a b) (set! b temp)) + (syntax-object->datum + (let ((exp '(set! a b))) + (syntax-case exp () + ((swap! a b) + (syntax + (let ((temp a)) + (set! a b) + (set! b temp)))))))) -(pass-if "define-syntax swap! [syntax-case]" - (sequal? - (let () - (define-syntax swap! - (lambda (exp) - (syntax-case exp () - ((swap! a b) - (syntax - ((lambda (temp) - (set! a b) - (set! b temp)) a)))))) - (let ((foo "foo") - (bar "bar")) - (swap! foo bar) - (list foo bar))) - (list "bar" "foo"))) +(cond-expand + (guile) + (mes + (pass-if-equal "syntax-case manual swap!" + '("bar" "foo") + (let* ((sc (sc-expand '(syntax-case exp () ((swap! a b) (syntax (let ((temp a)) (set! a b) (set! b temp))))))) + (exp '(swap foo bar)) + (foo "foo") + (bar "bar") + (s (eval sc (current-module))) + (d (syntax-object->datum s)) + (e (core:macro-expand d))) + (eval e (current-module)) + (list foo bar))))) -(pass-if "define-syntax swap! [syntax-case+let]" - (sequal? - (let () - (define-syntax swap! - (lambda (exp) - (syntax-case exp () - ((swap! a b) - (syntax - (let ((temp a)) +(pass-if-equal "define-syntax swap! [syntax-case]" + (list "bar" "foo") + (let () + (define-syntax swap! + (lambda (exp) + (syntax-case exp () + ((swap! a b) + (syntax + ((lambda (temp) (set! a b) - (set! b temp))))))) - (let ((foo "foo") - (bar "bar")) - (swap! foo bar) - (list foo bar))) - (list "bar" "foo"))) + (set! b temp)) a)))))) + (let ((foo "foo") + (bar "bar")) + (swap! foo bar) + (list foo bar)))) -(pass-if "define-syntax sr:when [syntax-rules]" - (sequal? - (let () - (define-syntax sr:when - (syntax-rules () - ((sc:when condition exp ...) - (if condition - (begin exp ...))))) - (let () - (sr:when #t "if not now, then?"))) - "if not now, then?")) +(pass-if-equal "define-syntax swap! [syntax-case+let]" + (list "bar" "foo") + (let () + (define-syntax swap! + (lambda (exp) + (syntax-case exp () + ((swap! a b) + (syntax + (let ((temp a)) + (set! a b) + (set! b temp))))))) + (let ((foo "foo") + (bar "bar")) + (swap! foo bar) + (list foo bar)))) -(pass-if "define-syntax-rule" - (sequal? - (let () - (define-syntax-rule (sre:when c e ...) - (if c (begin e ...))) - (let () - (sre:when #t "if not now, then?"))) - "if not now, then?")) +(pass-if-equal "define-syntax sr:when [syntax-rules]" + "if not now, then?" + (let () + (define-syntax sr:when + (syntax-rules () + ((sc:when condition exp ...) + (if condition + (begin exp ...))))) + (let () + (sr:when #t "if not now, then?")))) + +(pass-if-equal "define-syntax-rule" + "if not now, then?" + (let () + (define-syntax-rule (sre:when c e ...) + (if c (begin e ...))) + (let () + (sre:when #t "if not now, then?")))) (pass-if-equal "syntax-rules plus" (+ 1 2 3) @@ -163,7 +178,8 @@ exit $? ((plus x ...) (+ x ...)))) (plus 1 2 3))) -(when guile? +(cond-expand + (guile (pass-if-equal "macro with quasisyntax" '("foo" "foo") (let () @@ -174,6 +190,7 @@ exit $? #`(let ((id #,(symbol->string (syntax->datum #'id)))) body ...))))) (string-let foo (list foo foo))))) + (mes)) ;; (pass-if-equal "custom ellipsis within normal ellipsis" ;; '((((a x) (a y) (a …))