core: Remove define.
* base-0.mes (cons*): Refactor. * module/mes/read-0.mes: Implement define, define-macro using macros. * define.c: Remove. * mes.c: Remove callers. * GNUmakefile (mes.o): Remove dependency on define.
This commit is contained in:
Jan Nieuwenhuizen
parent
1072c7fba9
commit
7bf25a7e17
|
|
@ -29,7 +29,6 @@ all: mes module/mes/read-0.mo
|
|||
mes.o: GNUmakefile
|
||||
mes.o: mes.c
|
||||
mes.o: mes.c mes.h mes.i mes.environment.i mes.symbols.i
|
||||
mes.o: define.c define.h define.i define.environment.i
|
||||
mes.o: display.c display.h display.i display.environment.i
|
||||
mes.o: lib.c lib.h lib.i lib.environment.i
|
||||
mes.o: math.c math.h math.i math.environment.i
|
||||
|
|
|
|||
59
define.c
59
define.c
|
|
@ -1,59 +0,0 @@
|
|||
/* -*-comment-start: "//";comment-end:""-*-
|
||||
* Mes --- Maxwell Equations of Software
|
||||
* Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
*
|
||||
* This file is part of Mes.
|
||||
*
|
||||
* Mes is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation; either version 3 of the License, or (at
|
||||
* your option) any later version.
|
||||
*
|
||||
* Mes is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
#if !BOOT
|
||||
SCM
|
||||
define_env (SCM e, SCM a)
|
||||
{
|
||||
return vm_call (vm_define_env, e, cell_undefined, a);
|
||||
}
|
||||
|
||||
SCM
|
||||
vm_define_env ()
|
||||
{
|
||||
SCM x;
|
||||
r2 = cadr (r1);
|
||||
if (TYPE (r2) != PAIR)
|
||||
x = eval_env (caddr (r1), cons (cons (cadr (r1), cadr (r1)), r0));
|
||||
else {
|
||||
r2 = car (r2);
|
||||
SCM p = pairlis (cadr (r1), cadr (r1), r0);
|
||||
x = eval_env (make_lambda (cdadr (r1), cddr (r1)), p);
|
||||
}
|
||||
if (eq_p (car (r1), cell_symbol_define_macro) == cell_t)
|
||||
x = make_macro (r2, x);
|
||||
|
||||
SCM entry = cons (r2, x);
|
||||
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);
|
||||
return entry;
|
||||
}
|
||||
#else // BOOT
|
||||
SCM define_env (SCM r1, SCM a){}
|
||||
SCM vm_define_env (SCM r1, SCM a){}
|
||||
#endif
|
||||
|
||||
SCM
|
||||
define_macro (SCM r1, SCM a)
|
||||
{
|
||||
}
|
||||
10
mes.c
10
mes.c
|
|
@ -163,7 +163,6 @@ SCM r1 = 0; // param 1
|
|||
SCM r2 = 0; // param 2
|
||||
SCM r3 = 0; // param 3
|
||||
|
||||
#include "define.h"
|
||||
#include "display.h"
|
||||
#include "lib.h"
|
||||
#include "math.h"
|
||||
|
|
@ -453,10 +452,6 @@ vm_eval_env ()
|
|||
return make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
|
||||
case cell_closure: return r1;
|
||||
case cell_symbol_if: return if_env (cdr (r1), r0);
|
||||
#if !BOOT
|
||||
case cell_symbol_define: return define_env (r1, r0);
|
||||
case cell_symbol_define_macro: return define_env (r1, r0);
|
||||
#endif
|
||||
#if 1 //!BOOT
|
||||
case cell_symbol_set_x: {
|
||||
SCM x = eval_env (caddr (r1), r0); return set_env_x (cadr (r1), x, r0);
|
||||
|
|
@ -1102,7 +1097,6 @@ mes_builtins (SCM a)
|
|||
{
|
||||
#include "mes.i"
|
||||
|
||||
#include "define.i"
|
||||
#include "display.i"
|
||||
#include "lib.i"
|
||||
#include "math.i"
|
||||
|
|
@ -1112,7 +1106,6 @@ mes_builtins (SCM a)
|
|||
#include "string.i"
|
||||
#include "type.i"
|
||||
|
||||
#include "define.environment.i"
|
||||
#include "display.environment.i"
|
||||
#include "lib.environment.i"
|
||||
#include "math.environment.i"
|
||||
|
|
@ -1206,7 +1199,7 @@ SCM
|
|||
load_env (SCM a) ///((internal))
|
||||
{
|
||||
r0 =a;
|
||||
#if !READER
|
||||
#if 1 //!READER
|
||||
g_stdin = fopen ("module/mes/read-0.mes", "r");
|
||||
g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mes", "r");
|
||||
#endif
|
||||
|
|
@ -1262,7 +1255,6 @@ dump ()
|
|||
}
|
||||
|
||||
#include "type.c"
|
||||
#include "define.c"
|
||||
#include "display.c"
|
||||
#include "lib.c"
|
||||
#include "math.c"
|
||||
|
|
|
|||
|
|
@ -52,11 +52,9 @@
|
|||
(define (ftell port) 0)
|
||||
(define (false-if-exception x) x)
|
||||
|
||||
(define (cons* x . rest)
|
||||
(define (loop rest)
|
||||
(if (null? (cdr rest)) (car rest)
|
||||
(cons (car rest) (loop (cdr rest)))))
|
||||
(loop (cons x rest)))
|
||||
(define (cons* . rest)
|
||||
(if (null? (cdr rest)) (car rest)
|
||||
(cons (car rest) (apply-env cons* (cdr rest) (current-module)))))
|
||||
|
||||
(define (apply f h . t) (apply-env f (cons h t) (current-module)))
|
||||
(define (apply f h . t)
|
||||
|
|
|
|||
|
|
@ -24,24 +24,19 @@
|
|||
|
||||
(mes-use-module (mes scm))
|
||||
|
||||
(define (env:define a+ a)
|
||||
(define (f:env:define a+ a)
|
||||
(set-cdr! a+ (cdr a))
|
||||
(set-cdr! a a+)
|
||||
;;(set-cdr! (assq '*closure* a) a+)
|
||||
)
|
||||
|
||||
(define (env:escape-closure a)
|
||||
(let loop ((a a) (n 1))
|
||||
(if (eq? (caar a) '*closure*) (if (= 0 n) a
|
||||
(loop (cdr a) (- n 1)))
|
||||
(loop (cdr a) n))))
|
||||
|
||||
(define (sexp:define e a)
|
||||
(if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
|
||||
(cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))))
|
||||
(define (env:escape-closure a n)
|
||||
(if (closure? (car a)) (if (= 0 n) a
|
||||
(env:escape-closure (cdr a) (- n 1)))
|
||||
(env:escape-closure (cdr a) n)))
|
||||
|
||||
(define-macro (module-define! name value a)
|
||||
`(env:define (cons (sexp:define (cons 'define (cons ',name (cons ,value '()))) ,a) '()) (env:escape-closure ,a)))
|
||||
`(f:env:define (cons (sexp:define (cons 'define (cons ',name (cons ,value '()))) ,a) '()) (env:escape-closure ,a 1)))
|
||||
|
||||
(define-macro (make-fluid . default)
|
||||
`(begin
|
||||
|
|
|
|||
|
|
@ -27,10 +27,78 @@
|
|||
;;; to use this reader to read and run the minimal gc-3.test
|
||||
;;; TODO: complete this reader, remove reader from C.
|
||||
|
||||
;;; copy of mes/read-0.mes, comment-out read-input-file
|
||||
|
||||
;;; Code:
|
||||
|
||||
(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))
|
||||
|
||||
(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 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))
|
||||
|
||||
(set! sexp:define
|
||||
(lambda (e a)
|
||||
(if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
|
||||
(cons (caadr e) (eval-env (cons (quote lambda) (cons (cdadr e) (cddr e))) a)))))
|
||||
|
||||
(set! env:macro
|
||||
(lambda (name+entry)
|
||||
(cons
|
||||
(cons (car name+entry)
|
||||
(make-macro (car name+entry)
|
||||
(cdr name+entry)))
|
||||
(list))))
|
||||
|
||||
(set! cons*
|
||||
(lambda (. rest)
|
||||
(if (null? (cdr rest)) (car rest)
|
||||
(cons (car rest) (apply-env 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-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 car (make-function 'car 0))
|
||||
;; (define cdr (make-function 'cdr 1))
|
||||
;; (define cons (make-function 'cons 1))
|
||||
|
|
@ -54,16 +122,16 @@
|
|||
(helper (read)))
|
||||
|
||||
(define-macro (cond . clauses)
|
||||
(list 'if (pair? clauses)
|
||||
(list 'if (car (car clauses))
|
||||
(list (quote if) (pair? clauses)
|
||||
(list (quote if) (car (car clauses))
|
||||
(if (pair? (cdar clauses))
|
||||
(if (eq? (cadar clauses) '=>)
|
||||
(if (eq? (cadar clauses) (quote =>))
|
||||
(append2 (cddar clauses) (list (caar clauses)))
|
||||
(list (cons 'lambda (cons '() (car clauses)))))
|
||||
(list (cons 'lambda (cons '() (car clauses)))))
|
||||
(list (cons (quote lambda) (cons (list) (car clauses)))))
|
||||
(list (cons (quote lambda) (cons (list) (car clauses)))))
|
||||
(if (pair? (cdr clauses))
|
||||
(cons 'cond (cdr clauses))))))
|
||||
|
||||
(cons (quote cond) (cdr clauses))))))
|
||||
|
||||
(define (eat-whitespace)
|
||||
(cond
|
||||
((eq? (peek-byte) 9) (read-byte) (eat-whitespace))
|
||||
|
|
|
|||
Loading…
Reference in a new issue