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 MES=${MES-src/mes.gcc}
export MESCC=${MESCC-scripts/mescc.mes} export MESCC=${MESCC-scripts/mescc.mes}
#export MES_ARENA=${MES_ARENA-200000000} #9GiB #export MES_ARENA=${MES_ARENA-200000000} > 12GB mem
GUILE=${GUILE-guile} GUILE=${GUILE-guile}
MES=${MES-./mes} MES=${MES-./mes}

12
module/mes/catch.mes
View File

@ -23,14 +23,14 @@
(define %eh (make-fluid (define %eh (make-fluid
(lambda (key . args) (lambda (key . args)
(if (defined? 'simple-format) (if #f ;;(defined? 'simple-format)
(simple-format (current-error-port) "unhandled exception:~a:~a\n" key args) (simple-format (current-error-port) "unhandled exception:~a:~a\n" key args)
(begin (begin
(display "unhandled exception:" (current-error-port)) (core:display-error "unhandled exception:")
(display key (current-error-port)) (core:display-error key)
(display ":" (current-error-port)) (core:display-error ":")
(write args (current-error-port)) (core:write-error args)
(newline (current-error-port)))) (core:display-error "\n")))
(exit 1)))) (exit 1))))
(define (catch key thunk handler) (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)))) (and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e))))
(lambda (a) (xassq x (cdr a))))))) (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) (define (display x . rest)
(let* ((port (if (null? rest) (current-output-port) (car rest))) (let* ((port (if (null? rest) (current-output-port) (car rest)))
(write? (and (pair? rest) (pair? (cdr rest)) (cadr 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?) (define (display-char x port write?)
(cond ((and write? (or (eq? x #\") (eq? x #\\))) (cond ((and write? (or (eq? x #\") (eq? x #\\)))
(write-char #\\ port) (write-char #\\ port)
@ -60,7 +60,7 @@
(#t (write-char x port)))) (#t (write-char x port))))
(define (d x cont? sep) (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 (cond
((eof-object? x) ((eof-object? x)
(display "#<eof>" port)) (display "#<eof>" port))
@ -114,7 +114,7 @@
((or (keyword? x) (special? x) (string? x) (symbol? x)) ((or (keyword? x) (special? x) (string? x) (symbol? x))
(if (and (string? x) write?) (write-char #\" port)) (if (and (string? x) write?) (write-char #\" port))
(if (keyword? x) (display "#:" 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))) (if (and (string? x) write?) (write-char #\" port)))
((vector? x) ((vector? x)
(display "#(" port) (display "#(" port)

39
module/mes/guile.mes
View File

@ -28,7 +28,7 @@
(define-macro (include-from-path file) (define-macro (include-from-path file)
(let loop ((path (cons %moduledir (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:)))) (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) ;;(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"))) (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
(if (null? path) (error "include-from-path: not found: " file) (if (null? path) (error "include-from-path: not found: " file)
@ -175,3 +175,40 @@
(let ((lst (filter (negate string-null?) (string-split file-name #\/)))) (let ((lst (filter (negate string-null?) (string-split file-name #\/))))
(if (<= (length lst) 1) "." (if (<= (length lst) 1) "."
(string-join (list-head lst (1- (length lst))) "/")))) (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-*- ;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; 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. ;;; This file is part of Mes.
;;; ;;;
@ -25,11 +25,14 @@
;;; Code: ;;; Code:
(mes-use-module (mes let))
(mes-use-module (mes scm))
(mes-use-module (mes guile)) (mes-use-module (mes guile))
(mes-use-module (mes pretty-print)) (mes-use-module (mes pretty-print))
(mes-use-module (mes psyntax)) (mes-use-module (mes psyntax))
(mes-use-module (srfi srfi-13)) (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)) (mes-use-module (mes pmatch))
(include-from-path "mes/peg/cache.scm") (include-from-path "mes/peg/cache.scm")
(include-from-path "mes/peg/codegen.scm") (include-from-path "mes/peg/codegen.scm")

17
module/mes/psyntax.mes
View File

@ -22,22 +22,7 @@
;;; Code: ;;; Code:
(define (env:define a+ a) (mes-use-module (mes scm))
(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 psyntax-0)) (mes-use-module (mes psyntax-0))
(include-from-path "mes/psyntax.pp") (include-from-path "mes/psyntax.pp")
(mes-use-module (mes psyntax-1)) (mes-use-module (mes psyntax-1))

11
scripts/repl.mes
View File

@ -10,7 +10,7 @@ exit $?
!# !#
;;; Mes --- Maxwell Equations of Software ;;; 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. ;;; This file is part of Mes.
;;; ;;;
@ -27,6 +27,10 @@ exit $?
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; 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))) (let* ((files (cdr (command-line)))
(file (if (pair? files) (car files))) (file (if (pair? files) (car files)))
(file (if (and (equal? file "--") (pair? files) (pair? (cdr files))) (cadr files) file))) (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) (format (current-error-port) "mescc.mes (mes) ~a\n" %version)
(exit 0)))) (exit 0))))
;;(mes-use-module (mes scm))
(mes-use-module (mes syntax))
(mes-use-module (mes repl))
(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_define = {TSPECIAL, "*vm-eval-define*",0};
struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",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_eval_check_func = {TSPECIAL, "*vm-eval-check-func*",0};
struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",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 = {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 = {TSPECIAL, "*vm-begin*",0};
struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",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 = {TSPECIAL, "*vm-if*",0};
struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",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}; struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0};
@ -741,6 +753,7 @@ gc_pop_frame () ///((internal))
SCM SCM
eval_apply () eval_apply ()
{ {
int expanding_p = 0;
eval_apply: eval_apply:
gc_check (); gc_check ();
switch (r3) switch (r3)
@ -759,13 +772,24 @@ eval_apply ()
#endif #endif
case cell_vm_eval_define: goto eval_define; case cell_vm_eval_define: goto eval_define;
case cell_vm_eval_set_x: goto eval_set_x; 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_eval_check_func: goto eval_check_func;
case cell_vm_eval2: goto eval2; case cell_vm_eval2: goto eval2;
case cell_vm_macro_expand: goto macro_expand; 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: goto begin;
case cell_vm_begin_read_input_file: goto begin_read_input_file; case cell_vm_begin_eval: goto begin_eval;
case cell_vm_begin2: goto begin2; 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: goto vm_if;
case cell_vm_if_expr: goto if_expr; case cell_vm_if_expr: goto if_expr;
case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2; case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
@ -914,6 +938,12 @@ eval_apply ()
eval_null_p: eval_null_p:
x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply; 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 #endif // MES_FIXED_PRIMITIVES
case cell_symbol_quote: case cell_symbol_quote:
{ {
@ -937,8 +967,15 @@ eval_apply ()
} }
case cell_vm_macro_expand: 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; 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: default:
{ {
@ -978,10 +1015,10 @@ eval_apply ()
} }
push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval; push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval;
eval_check_func: 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: eval2:
r1 = cons (CAR (r2), r1); r1 = cons (CAR (r2), r1);
goto apply; goto apply;
} }
} }
} }
@ -993,74 +1030,186 @@ eval_apply ()
default: goto vm_return; default: goto vm_return;
} }
SCM macro;
SCM expanders;
macro_expand: macro_expand:
if (TYPE (r1) == TPAIR {
&& (macro = lookup_macro_ (CAR (r1), r0)) != cell_f) SCM macro;
{ SCM expanders;
r1 = cons (macro, CDR (r1));
goto apply; if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
} goto vm_return;
else if (TYPE (r1) == TPAIR
&& TYPE (CAR (r1)) == TSYMBOL if (TYPE (r1) == TPAIR
&& ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined) && (macro = lookup_macro_ (CAR (r1), r0)) != cell_f)
&& ((macro = assq (CAR (r1), expanders)) != cell_f)) {
{ r1 = cons (macro, CDR (r1));
SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0); push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
if (sc_expand != cell_undefined && sc_expand != cell_f) goto apply;
{ }
r1 = cons (sc_expand, cons (r1, cell_nil)); if (CAR (r1) == cell_symbol_define
goto apply; || CAR (r1) == cell_symbol_define_macro)
} {
} push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_define);
goto vm_return; 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: begin:
x = cell_unspecified; x = cell_unspecified;
while (r1 != cell_nil) { while (r1 != cell_nil)
gc_check (); {
if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR) gc_check ();
{ if (TYPE (r1) == TPAIR)
if (CAAR (r1) == cell_symbol_begin) {
r1 = append2 (CDAR (r1), CDR (r1)); if (CAAR (r1) == cell_symbol_primitive_load)
else if (CAAR (r1) == cell_symbol_primitive_load) {
{ SCM program = cons (CAR (r1), cell_nil);
// push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file); push_cc (program, r1, r0, cell_vm_begin_primitive_load);
// goto apply; goto begin_expand;
begin_primitive_load:
CAR (r2) = r1;
r1 = r2;
}
}
push_cc (CAR (CDAR (r1)), r1, r0, cell_vm_begin_read_input_file); if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
goto eval; // FIXME: expand too?! {
begin_read_input_file:; if (CAAR (r1) == cell_symbol_begin)
SCM input = r1; r1 = append2 (CDAR (r1), CDR (r1));
if ((TYPE (r1) == TNUMBER && VALUE (r1) == 0)) }
; if (CDR (r1) == cell_nil)
else {
input = set_current_input_port (open_input_file (r1)); r1 = CAR (r1);
push_cc (input, r2, r0, cell_vm_return); goto eval;
x = read_input_file_env (r0); }
gc_pop_frame (); push_cc (CAR (r1), r1, r0, cell_vm_begin_eval);
r1 = x; goto eval;
input = r1; begin_eval:
#if DEBUG x = r1;
eputs (" ..2.r2="); write_error_ (r2); eputs ("\n"); r1 = CDR (r2);
eputs (" => result r1="); write_error_ (r1); eputs ("\n"); }
#endif r1 = x;
set_current_input_port (input); goto vm_return;
r1 = append2 (r1, cons (cell_t, CDR (r2)));
}
} begin_expand:
if (CDR (r1) == cell_nil) x = cell_unspecified;
{ while (r1 != cell_nil)
r1 = CAR (r1); {
goto eval; gc_check ();
}
push_cc (CAR (r1), r1, r0, cell_vm_begin2); if (TYPE (r1) == TPAIR)
goto eval; {
begin2: if (TYPE (CAR (r1)) == TPAIR && CAAR (r1) == cell_symbol_begin)
x = r1; r1 = append2 (CDAR (r1), CDR (r1));
r1 = CDR (r2); 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; r1 = x;
goto vm_return; goto vm_return;
@ -1481,6 +1630,7 @@ main (int argc, char *argv[])
SCM lst = cell_nil; SCM lst = cell_nil;
for (int i=argc-1; i>=0; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst); 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); r0 = acons (cell_symbol_argv, lst, r0);
push_cc (r2, cell_unspecified, r0, cell_unspecified); push_cc (r2, cell_unspecified, r0, cell_unspecified);
if (g_debug > 1) if (g_debug > 1)
@ -1489,14 +1639,14 @@ main (int argc, char *argv[])
write_error_ (r1); write_error_ (r1);
eputs ("\n"); eputs ("\n");
} }
r3 = cell_vm_begin; r3 = cell_vm_begin_expand;
r1 = eval_apply (); r1 = eval_apply ();
write_error_ (r1); write_error_ (r1);
eputs ("\n"); eputs ("\n");
gc (g_stack); gc (g_stack);
if (g_debug) if (g_debug)
{ {
eputs ("\nstats: ["); eputs ("\ngc stats: [");
eputs (itoa (g_free)); eputs (itoa (g_free));
eputs ("]\n"); eputs ("]\n");
} }

5
src/posix.c
View File

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*- /* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software * 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. * This file is part of Mes.
* *
@ -156,8 +156,9 @@ open_input_file (SCM file_name)
SCM SCM
set_current_input_port (SCM port) set_current_input_port (SCM port)
{ {
int prev = g_stdin;
g_stdin = VALUE (port) ? VALUE (port) : STDIN; g_stdin = VALUE (port) ? VALUE (port) : STDIN;
return current_input_port (); return MAKE_NUMBER (prev);
} }
SCM SCM

181
tests/psyntax.test
View File

@ -9,7 +9,7 @@ exit $?
;;; -*-scheme-*- ;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; 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. ;;; This file is part of Mes.
;;; ;;;
@ -46,17 +46,19 @@ exit $?
(pass-if "first dummy" #t) (pass-if "first dummy" #t)
(pass-if-not "second dummy" #f) (pass-if-not "second dummy" #f)
(when (not guile?) (cond-expand
(pass-if "andmap" (guile)
(seq? (andmap (lambda (x) (> x 0)) '(3 2 1)) #t)) (mes
(pass-if "andmap"
(seq? (andmap (lambda (x) (> x 0)) '(3 2 1)) #t))
(pass-if "andmap 2" (pass-if "andmap 2"
(seq? (andmap (lambda (x) (> x 0)) '(3 2 1 0)) #f)) (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" (pass-if "getprop"
(seq? (getprop 'foo '*sc-expander) 'bar)) (seq? (getprop 'foo '*sc-expander) 'bar)))
) )
(pass-if "syntax-case" (pass-if "syntax-case"
@ -76,84 +78,97 @@ exit $?
(sequal? (syntax-object->datum (syntax (set! a b))) (sequal? (syntax-object->datum (syntax (set! a b)))
'(set! a b))) '(set! a b)))
(pass-if "syntax-case swap!" (pass-if-equal "syntax-case swap!"
(sequal? (syntax-object->datum '((lambda (temp)
(let ((exp '(set! a b))) (set! a b)
(syntax-case exp () (set! b temp))
((swap! a b) a)
(syntax (syntax-object->datum
(let ((temp a)) (let ((exp '(set! a b)))
(set! a b) (syntax-case exp ()
(set! b temp))))))) ((swap! a b)
'(let ((temp a)) (set! a b) (set! b temp)))) (syntax
((lambda (temp)
(set! a b)
(set! b temp))
a)))))))
(when (not guile?) (pass-if-equal "syntax-case swap! let"
(pass-if "syntax-case manual swap!" '(let ((temp a)) (set! a b) (set! b temp))
(sequal? (syntax-object->datum
(let* ((sc (sc-expand '(syntax-case exp () ((swap! a b) (syntax (let ((temp a)) (set! a b) (set! b temp))))))) (let ((exp '(set! a b)))
(exp '(swap foo bar)) (syntax-case exp ()
(foo "foo") ((swap! a b)
(bar "bar") (syntax
(s (eval sc (current-module))) (let ((temp a))
(d (syntax-object->datum s))) (set! a b)
(eval d (current-module)) (set! b temp))))))))
(list foo bar))
'("bar" "foo"))))
(pass-if "define-syntax swap! [syntax-case]" (cond-expand
(sequal? (guile)
(let () (mes
(define-syntax swap! (pass-if-equal "syntax-case manual swap!"
(lambda (exp) '("bar" "foo")
(syntax-case exp () (let* ((sc (sc-expand '(syntax-case exp () ((swap! a b) (syntax (let ((temp a)) (set! a b) (set! b temp)))))))
((swap! a b) (exp '(swap foo bar))
(syntax (foo "foo")
((lambda (temp) (bar "bar")
(set! a b) (s (eval sc (current-module)))
(set! b temp)) a)))))) (d (syntax-object->datum s))
(let ((foo "foo") (e (core:macro-expand d)))
(bar "bar")) (eval e (current-module))
(swap! foo bar) (list foo bar)))))
(list foo bar)))
(list "bar" "foo")))
(pass-if "define-syntax swap! [syntax-case+let]" (pass-if-equal "define-syntax swap! [syntax-case]"
(sequal? (list "bar" "foo")
(let () (let ()
(define-syntax swap! (define-syntax swap!
(lambda (exp) (lambda (exp)
(syntax-case exp () (syntax-case exp ()
((swap! a b) ((swap! a b)
(syntax (syntax
(let ((temp a)) ((lambda (temp)
(set! a b) (set! a b)
(set! b temp))))))) (set! b temp)) a))))))
(let ((foo "foo") (let ((foo "foo")
(bar "bar")) (bar "bar"))
(swap! foo bar) (swap! foo bar)
(list foo bar))) (list foo bar))))
(list "bar" "foo")))
(pass-if "define-syntax sr:when [syntax-rules]" (pass-if-equal "define-syntax swap! [syntax-case+let]"
(sequal? (list "bar" "foo")
(let () (let ()
(define-syntax sr:when (define-syntax swap!
(syntax-rules () (lambda (exp)
((sc:when condition exp ...) (syntax-case exp ()
(if condition ((swap! a b)
(begin exp ...))))) (syntax
(let () (let ((temp a))
(sr:when #t "if not now, then?"))) (set! a b)
"if not now, then?")) (set! b temp)))))))
(let ((foo "foo")
(bar "bar"))
(swap! foo bar)
(list foo bar))))
(pass-if "define-syntax-rule" (pass-if-equal "define-syntax sr:when [syntax-rules]"
(sequal? "if not now, then?"
(let () (let ()
(define-syntax-rule (sre:when c e ...) (define-syntax sr:when
(if c (begin e ...))) (syntax-rules ()
(let () ((sc:when condition exp ...)
(sre:when #t "if not now, then?"))) (if condition
"if not now, then?")) (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" (pass-if-equal "syntax-rules plus"
(+ 1 2 3) (+ 1 2 3)
@ -163,7 +178,8 @@ exit $?
((plus x ...) (+ x ...)))) ((plus x ...) (+ x ...))))
(plus 1 2 3))) (plus 1 2 3)))
(when guile? (cond-expand
(guile
(pass-if-equal "macro with quasisyntax" (pass-if-equal "macro with quasisyntax"
'("foo" "foo") '("foo" "foo")
(let () (let ()
@ -174,6 +190,7 @@ exit $?
#`(let ((id #,(symbol->string (syntax->datum #'id)))) #`(let ((id #,(symbol->string (syntax->datum #'id))))
body ...))))) body ...)))))
(string-let foo (list foo foo))))) (string-let foo (list foo foo)))))
(mes))
;; (pass-if-equal "custom ellipsis within normal ellipsis" ;; (pass-if-equal "custom ellipsis within normal ellipsis"
;; '((((a x) (a y) (a …)) ;; '((((a x) (a y) (a …))