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

mes: Resurrect define, define-macro in C core.

Browse source 
* make.scm (bin.gcc, bin.mescc): Use MES_C_READER=1.
* src/mes.c (scm_symbol_define, scm_symbol_define_macro): New symbol.
  (scm_vm_eval_define): New special.
  (scm_symbol_c_define): New symbol.
  (MAKE_MACRO): New define.
  (eval_apply)[MES_C_DEFINE]: Handle define, define-macro.
  (mes_symbols): Define %c-define for use in read-0.mes.
* module/mes/read-0.mes: Do not implement full scheme define if %c-define.
* module/mes/quasiquote.mes (sexp:define, env:define, env:macro): New function.
  (define-macro): New macro.  FIXME
* module/mes/psyntax.mes (define): New macro.  FIXME
This commit is contained in:
Jan Nieuwenhuizen 2017-12-09 08:24:38 +01:00
parent 065cee9bda
commit 30efe5ffbc
6 changed files with 189 additions and 103 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
make.scm
View file

@ -417,6 +417,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
(add-target (bin.gcc "src/mes.c" #:dependencies gcc-snarf-targets
#:defines `("MES_C_READER=1"
"MES_C_DEFINE=1"
"MES_FIXED_PRIMITIVES=1"
"MES_FULL=1"
"POSIX=1"
@ -428,6 +429,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
(add-target (bin.gcc "src/mes.c" #:libc libc-gcc.mlibc-o
#:dependencies mes-snarf-targets
#:defines `("MES_C_READER=1"
"MES_C_DEFINE=1"
"MES_FIXED_PRIMITIVES=1"
"MES_FULL=1"
,(string-append "VERSION=\"" %version "\"")
@ -437,6 +439,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
(add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets
#:defines `("MES_C_READER=1"
"MES_C_DEFINE=1"
"MES_FIXED_PRIMITIVES=1"
"MES_FULL=1"
,(string-append "VERSION=\"" %version "\"")

8
module/mes/fluids.mes
View file

@ -24,6 +24,14 @@
(mes-use-module (mes scm))
(define (sexp:define e a)
(if (atom? (car (cdr e))) (cons (car (cdr e))
(core:eval (car (cdr (cdr e))) a))
(cons (car (car (cdr e)))
(core:eval (cons (quote lambda)
(cons (cdr (car (cdr e))) (cdr (cdr e)))) a))))
(define (f:env:define a+ a)
(set-cdr! a+ (cdr a))
(set-cdr! a a+)

18
module/mes/psyntax.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -22,6 +22,22 @@
;;; 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 psyntax-0))
(include-from-path "mes/psyntax.pp")
(mes-use-module (mes psyntax-1))

20
module/mes/quasiquote.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -27,12 +27,10 @@
(mes-use-module (mes base))
(define-macro (quasiquote x)
(define (loop x)
(cond ((vector? x) (list 'list->vector (loop (vector->list x))))
(define (quasiquote-expand x)
(cond ((vector? x) (list 'list->vector (quasiquote-expand (vector->list x))))
((not (pair? x)) (cons 'quote (cons x '())))
;;((eq? (car x) 'quasiquote) (loop (loop (cadr x))))
((eq? (car x) 'quasiquote) (loop (loop
((eq? (car x) 'quasiquote) (quasiquote-expand (quasiquote-expand
(if (null? (cddr x)) (cadr x)
(cons 'list (cdr x))))))
((eq? (car x) 'unquote) (if (null? (cddr x)) (cadr x)
@ -41,7 +39,7 @@
((lambda (d)
(if (null? (cddar x)) (list 'append (cadar x) d)
(list 'quote (append (cdar x) d))))
(loop (cdr x))))
(quasiquote-expand (cdr x))))
(else ((lambda (a d)
(if (pair? d)
(if (eq? (car d) 'quote)
@ -54,6 +52,8 @@
(cons (car d) (cons a (cdr d)))
(list 'cons* a d)))
(list 'cons* a d)))
(loop (car x))
(loop (cdr x))))))
(loop x))
(quasiquote-expand (car x))
(quasiquote-expand (cdr x))))))
(define-macro (quasiquote x)
(quasiquote-expand x))

10
module/mes/read-0.mes
View file

@ -27,7 +27,13 @@
;;; Code:
(begin
(if %c-define
(begin
(define <cell:pair> 7)
(define (not x) (if x #f #t))
(define (pair? x) (eq? (core:type x) <cell:pair>))
(define (atom? x) (not (pair? x))))
(begin
((lambda (a+ a)
(set-cdr! a+ (cdr a))
(set-cdr! a a+)
@ -102,7 +108,7 @@
(cons (quote DEFINE-MACRO) (cons ARGS BODY)))
(quote ((current-module)))))
(quote ((current-module))))))
(current-module))) (current-module))
(current-module))) (current-module))))
(define <cell:character> 0)
(define <cell:keyword> 4)

59
src/mes.c
View file

@ -131,10 +131,12 @@ struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
struct scm scm_symbol_if = {TSYMBOL, "if",0};
struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
#if 1 //MES_C_DEFINE // snarfing makes these always needed for linking
struct scm scm_symbol_define = {TSYMBOL, "define",0};
struct scm scm_symbol_define_macro = {TSYMBOL, "define-macro",0};
#endif
#if 1
//MES_C_READER
//Only for MES_C_READER; snarfing makes these always needed for linking
#if 1 //MES_C_READER // snarfing makes these always needed for linking
struct scm scm_symbol_quasiquote = {TSYMBOL, "quasiquote", 0};
struct scm scm_symbol_unquote = {TSYMBOL, "unquote", 0};
struct scm scm_symbol_unquote_splicing = {TSYMBOL, "unquote-splicing", 0};
@ -188,6 +190,9 @@ struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0};
struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0};
struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0};
struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0};
#if 1 //MES_C_DEFINE // snarfing makes these always needed for linking
struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0};
#endif
struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0};
@ -206,6 +211,7 @@ struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0};
struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
struct scm scm_symbol_c_reader = {TSYMBOL, "%c-reader",0};
struct scm scm_symbol_c_define = {TSYMBOL, "%c-define",0};
struct scm scm_test = {TSYMBOL, "test",0};
@ -293,6 +299,9 @@ int g_function = 0;
#if MES_C_READER
#define MAKE_KEYWORD(x) make_cell_ (tmp_num_ (TKEYWORD), x, 0)
#endif
#if MES_C_DEFINE
#define MAKE_MACRO(name, x) make_cell_ (tmp_num_ (TMACRO), STRING (name), x)
#endif
#define CAAR(x) CAR (CAR (x))
#define CADR(x) CAR (CDR (x))
@ -744,6 +753,9 @@ eval_apply ()
case cell_vm_eval_cdr: goto eval_cdr;
case cell_vm_eval_cons: goto eval_cons;
case cell_vm_eval_null_p: goto eval_null_p;
#endif
#if MES_C_DEFINE
case cell_vm_eval_define: goto eval_define;
#endif
case cell_vm_eval_set_x: goto eval_set_x;
case cell_vm_eval_macro: goto eval_macro;
@ -940,6 +952,42 @@ eval_apply ()
}
goto eval;
}
#if MES_C_DEFINE
if (TYPE (r1) == TPAIR
&& (CAR (r1) == cell_symbol_define
|| CAR (r1) == cell_symbol_define_macro))
{
r2 = CADR (r1);
if (TYPE (r2) != TPAIR)
{
push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
goto eval;
}
else
{
r2 = CAR (r2);
SCM p = pairlis (CADR (r1), CADR (r1), r0);
SCM args = CDR (CADR (r1));
SCM body = CDDR (r1);
r1 = cons (cell_symbol_lambda, cons (args, body));
push_cc (r1, r2, p, cell_vm_eval_define);
goto eval;
}
eval_define:
if (CAAR (CAAR (g_stack)) == cell_symbol_define_macro
|| CAR (CAAR (g_stack)) == cell_symbol_define_macro)
r1 = MAKE_MACRO (r2, r1);
SCM entry = cons (r2, r1);
SCM aa = cons (entry, cell_nil);
set_cdr_x (aa, cdr (r0));
set_cdr_x (r0, aa);
SCM cl = assq (cell_closure, r0);
set_cdr_x (cl, aa);
r1 = entry;
goto vm_return;
}
#endif // MES_C_DEFINE
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;
@ -1189,6 +1237,11 @@ mes_symbols () ///((internal))
a = acons (cell_symbol_c_reader, cell_f, a);
#endif
#if MES_C_DEFINE
a = acons (cell_symbol_c_define, cell_t, a);
#else
a = acons (cell_symbol_c_define, cell_f, a);
#endif
a = acons (cell_closure, a, a);
return a;