mes: Resurrect define, define-macro in C core.
* 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
parent
065cee9bda
commit
30efe5ffbc
3
make.scm
3
make.scm
|
|
@ -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 "\"")
|
||||
|
|
|
|||
|
|
@ -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+)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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,33 +27,33 @@
|
|||
|
||||
(mes-use-module (mes base))
|
||||
|
||||
(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) (quasiquote-expand (quasiquote-expand
|
||||
(if (null? (cddr x)) (cadr x)
|
||||
(cons 'list (cdr x))))))
|
||||
((eq? (car x) 'unquote) (if (null? (cddr x)) (cadr x)
|
||||
(cons 'list (cdr x))))
|
||||
((and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
|
||||
((lambda (d)
|
||||
(if (null? (cddar x)) (list 'append (cadar x) d)
|
||||
(list 'quote (append (cdar x) d))))
|
||||
(quasiquote-expand (cdr x))))
|
||||
(else ((lambda (a d)
|
||||
(if (pair? d)
|
||||
(if (eq? (car d) 'quote)
|
||||
(if (and (pair? a) (eq? (car a) 'quote))
|
||||
(list 'quote (cons (cadr a) (cadr d)))
|
||||
(if (null? (cadr d))
|
||||
(list 'list a)
|
||||
(list 'cons* a d)))
|
||||
(if (memq (car d) '(list cons*))
|
||||
(cons (car d) (cons a (cdr d)))
|
||||
(list 'cons* a d)))
|
||||
(list 'cons* a d)))
|
||||
(quasiquote-expand (car x))
|
||||
(quasiquote-expand (cdr x))))))
|
||||
|
||||
(define-macro (quasiquote x)
|
||||
(define (loop x)
|
||||
(cond ((vector? x) (list 'list->vector (loop (vector->list x))))
|
||||
((not (pair? x)) (cons 'quote (cons x '())))
|
||||
;;((eq? (car x) 'quasiquote) (loop (loop (cadr x))))
|
||||
((eq? (car x) 'quasiquote) (loop (loop
|
||||
(if (null? (cddr x)) (cadr x)
|
||||
(cons 'list (cdr x))))))
|
||||
((eq? (car x) 'unquote) (if (null? (cddr x)) (cadr x)
|
||||
(cons 'list (cdr x))))
|
||||
((and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
|
||||
((lambda (d)
|
||||
(if (null? (cddar x)) (list 'append (cadar x) d)
|
||||
(list 'quote (append (cdar x) d))))
|
||||
(loop (cdr x))))
|
||||
(else ((lambda (a d)
|
||||
(if (pair? d)
|
||||
(if (eq? (car d) 'quote)
|
||||
(if (and (pair? a) (eq? (car a) 'quote))
|
||||
(list 'quote (cons (cadr a) (cadr d)))
|
||||
(if (null? (cadr d))
|
||||
(list 'list a)
|
||||
(list 'cons* a d)))
|
||||
(if (memq (car d) '(list cons*))
|
||||
(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 x))
|
||||
|
|
|
|||
|
|
@ -27,82 +27,88 @@
|
|||
;;; 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+)
|
||||
(set-cdr! (assq (quote *closure*) a) a+)
|
||||
(car a+))
|
||||
(cons (cons (quote env:define) #f) (list))
|
||||
(current-module))
|
||||
|
||||
((lambda (a+ a)
|
||||
(set-cdr! a+ (cdr a))
|
||||
(set-cdr! a a+)
|
||||
(set-cdr! (assq (quote *closure*) a) a+)
|
||||
(car a+))
|
||||
(cons (cons (quote env:define) #f) (list))
|
||||
(current-module))
|
||||
(set! env:define
|
||||
(lambda (a+ a)
|
||||
(set-cdr! a+ (cdr a))
|
||||
(set-cdr! a a+)
|
||||
(set-cdr! (assq (quote *closure*) a) a+)
|
||||
(car a+)))
|
||||
|
||||
(set! env:define
|
||||
(lambda (a+ a)
|
||||
(set-cdr! a+ (cdr a))
|
||||
(set-cdr! a a+)
|
||||
(set-cdr! (assq (quote *closure*) a) a+)
|
||||
(car a+)))
|
||||
(env:define (cons (cons (quote <cell:macro>) 5) (list)) (current-module))
|
||||
(env:define (cons (cons (quote <cell:pair>) 7) (list)) (current-module))
|
||||
(env:define (cons (cons (quote sexp:define) #f) (list)) (current-module))
|
||||
(env:define (cons (cons (quote env:macro) #f) (list)) (current-module))
|
||||
(env:define (cons (cons (quote cons*) #f) (list)) (current-module))
|
||||
(env:define (cons (cons (quote not)
|
||||
(lambda (x) (if x #f #t)))
|
||||
(list)) (current-module))
|
||||
(env:define (cons (cons (quote pair?)
|
||||
(lambda (x) (eq? (core:type x) <cell:pair>)))
|
||||
(list)) (current-module))
|
||||
(env:define (cons (cons (quote atom?)
|
||||
(lambda (x) (not (pair? x))))
|
||||
(list)) (current-module))
|
||||
|
||||
(env:define (cons (cons (quote <cell:macro>) 5) (list)) (current-module))
|
||||
(env:define (cons (cons (quote <cell:pair>) 7) (list)) (current-module))
|
||||
(env:define (cons (cons (quote sexp:define) #f) (list)) (current-module))
|
||||
(env:define (cons (cons (quote env:macro) #f) (list)) (current-module))
|
||||
(env:define (cons (cons (quote cons*) #f) (list)) (current-module))
|
||||
(env:define (cons (cons (quote not)
|
||||
(lambda (x) (if x #f #t)))
|
||||
(list)) (current-module))
|
||||
(env:define (cons (cons (quote pair?)
|
||||
(lambda (x) (eq? (core:type x) <cell:pair>)))
|
||||
(list)) (current-module))
|
||||
(env:define (cons (cons (quote atom?)
|
||||
(lambda (x) (not (pair? x))))
|
||||
(list)) (current-module))
|
||||
(set! sexp:define
|
||||
(lambda (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)))))
|
||||
|
||||
(set! sexp:define
|
||||
(lambda (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)))))
|
||||
(set! env:macro
|
||||
(lambda (name+entry)
|
||||
(cons
|
||||
(cons (car name+entry)
|
||||
(core:make-cell <cell:macro> (core:car (car name+entry)) (cdr name+entry)))
|
||||
(list))))
|
||||
|
||||
(set! env:macro
|
||||
(lambda (name+entry)
|
||||
(cons
|
||||
(cons (car name+entry)
|
||||
(core:make-cell <cell:macro> (core:car (car name+entry)) (cdr name+entry)))
|
||||
(list))))
|
||||
(set! cons*
|
||||
(lambda (. rest)
|
||||
(if (null? (cdr rest)) (car rest)
|
||||
(cons (car rest) (core:apply cons* (cdr rest) (current-module))))))
|
||||
|
||||
(set! cons*
|
||||
(lambda (. rest)
|
||||
(if (null? (cdr rest)) (car rest)
|
||||
(cons (car rest) (core:apply cons* (cdr rest) (current-module))))))
|
||||
(env:define
|
||||
(env:macro
|
||||
(sexp:define
|
||||
(quote
|
||||
(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))))))
|
||||
(current-module))) (current-module))
|
||||
|
||||
(env:define
|
||||
(env:macro
|
||||
(sexp:define
|
||||
(quote
|
||||
(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))))))
|
||||
(current-module))) (current-module))
|
||||
|
||||
(env:define
|
||||
(env:macro
|
||||
(sexp:define
|
||||
(quote
|
||||
(define-macro (define-macro ARGS . BODY)
|
||||
(cons* (quote env:define)
|
||||
(list (quote env:macro)
|
||||
(cons* (quote sexp:define)
|
||||
(list (quote quote)
|
||||
(cons (quote DEFINE-MACRO) (cons ARGS BODY)))
|
||||
(quote ((current-module)))))
|
||||
(quote ((current-module))))))
|
||||
(current-module))) (current-module))
|
||||
(env:define
|
||||
(env:macro
|
||||
(sexp:define
|
||||
(quote
|
||||
(define-macro (define-macro ARGS . BODY)
|
||||
(cons* (quote env:define)
|
||||
(list (quote env:macro)
|
||||
(cons* (quote sexp:define)
|
||||
(list (quote quote)
|
||||
(cons (quote DEFINE-MACRO) (cons ARGS BODY)))
|
||||
(quote ((current-module)))))
|
||||
(quote ((current-module))))))
|
||||
(current-module))) (current-module))))
|
||||
|
||||
(define <cell:character> 0)
|
||||
(define <cell:keyword> 4)
|
||||
|
|
|
|||
59
src/mes.c
59
src/mes.c
|
|
@ -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;
|
||||
|
|
|
|||
Loading…
Reference in a new issue