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

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

60
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,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))

144
module/mes/read-0.mes
View File

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