andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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.
This commit is contained in:
Jan Nieuwenhuizen 2018-03-04 10:05:55 +01:00
parent 4986549f34
commit 4c9690996c
10 changed files with 391 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
check-mescc.sh
View File

@ -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}

12
module/mes/catch.mes
View File

@ -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)

16
module/mes/display.mes
View File

@ -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 "#<eof>" 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)

39
module/mes/guile.mes
View File

@ -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)

7
module/mes/peg.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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")

17
module/mes/psyntax.mes
View File

@ -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))

11
scripts/repl.mes
View File

@ -10,7 +10,7 @@ exit $?
!#
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
(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)
()

298
src/mes.c
View File

@ -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");
}

5
src/posix.c
View File

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software
* Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
* Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
*
* 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

181
tests/psyntax.test
View File

@ -9,7 +9,7 @@ exit $?
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 …))