Move optional type predicates to type.c.
* mes.c (char_p, macro_p, number_p, pair_p, string_p, symbol_p, vector_p, builtin_p, boolean_p): Move to type.c * type.c: New file. * GNUmakefile (mes.o): Depend on type snarf output. * module/mes/loop-0.mes (cond, map, let, or, and not, evlis-env, apply-env, eval-expand, uquote, add-unquoters, eval, expand-macro-env, eval-begin-env, eval-if-env, sexp:define, env:define, env:macro): Move to mes-0.mes. * module/mes/mes-0.mes: New file. * module/mes/type-0.mes: New file. * scripts/include.mes: If BOOT, also include mes-0.mes. If TYPE0, also include type-0.mes.
This commit is contained in:
Jan Nieuwenhuizen
parent
c8fdae40d9
commit
2586f0bb2c
|
|
@ -22,7 +22,9 @@ include make/install.make
|
||||||
|
|
||||||
all: mes
|
all: mes
|
||||||
|
|
||||||
mes.o: mes.c mes.environment.h mes.symbols.i mes.environment.i
|
mes.o: mes.c
|
||||||
|
mes.o: mes.c mes.environment.h mes.environment.i mes.symbols.i
|
||||||
|
mes.o: type.c type.environment.h type.environment.i
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
rm -f mes mes.o mes.environment.i mes.symbols.i mes.environment.h *.cat a.out
|
rm -f mes mes.o mes.environment.i mes.symbols.i mes.environment.h *.cat a.out
|
||||||
|
|
@ -30,7 +32,7 @@ clean:
|
||||||
distclean: clean
|
distclean: clean
|
||||||
rm -f .config.make
|
rm -f .config.make
|
||||||
|
|
||||||
mes.environment.h mes.environment.i mes.symbols.i: mes.c build-aux/mes-snarf.scm
|
%.environment.h %.environment.i %.symbols.i: %.c build-aux/mes-snarf.scm
|
||||||
build-aux/mes-snarf.scm $<
|
build-aux/mes-snarf.scm $<
|
||||||
|
|
||||||
check: all guile-check mes-check
|
check: all guile-check mes-check
|
||||||
|
|
|
||||||
|
|
@ -94,6 +94,9 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
|
||||||
#:annotation (with-input-from-string (match:substring m 4) read)))
|
#:annotation (with-input-from-string (match:substring m 4) read)))
|
||||||
matches)))
|
matches)))
|
||||||
|
|
||||||
|
(define (content? f)
|
||||||
|
((compose not string-null? .content) f))
|
||||||
|
|
||||||
(define (internal? f)
|
(define (internal? f)
|
||||||
((compose (cut assoc-ref <> 'internal) .annotation) f))
|
((compose (cut assoc-ref <> 'internal) .annotation) f))
|
||||||
|
|
||||||
|
|
@ -124,7 +127,7 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
|
||||||
|
|
||||||
(define (main args)
|
(define (main args)
|
||||||
(let* ((files (cdr args)))
|
(let* ((files (cdr args)))
|
||||||
(map file-write (append-map generate-includes files))))
|
(map file-write (filter content? (append-map generate-includes files)))))
|
||||||
|
|
||||||
;;(define string (with-input-from-file "../mes.c" read-string))
|
;;(define string (with-input-from-file "../mes.c" read-string))
|
||||||
|
|
||||||
|
|
|
||||||
108
mes.c
108
mes.c
|
|
@ -62,6 +62,7 @@ typedef struct scm_t {
|
||||||
|
|
||||||
scm temp_number = {NUMBER, .name="nul", .value=0};
|
scm temp_number = {NUMBER, .name="nul", .value=0};
|
||||||
|
|
||||||
|
#include "type.environment.h"
|
||||||
#include "mes.environment.h"
|
#include "mes.environment.h"
|
||||||
|
|
||||||
scm *display_ (FILE* f, scm *x);
|
scm *display_ (FILE* f, scm *x);
|
||||||
|
|
@ -113,13 +114,6 @@ scm char_space = {CHAR, .name="space", .value=32};
|
||||||
|
|
||||||
// PRIMITIVES
|
// PRIMITIVES
|
||||||
|
|
||||||
#define ATOM_P(x) (x->type == PAIR ? &scm_f : &scm_t)
|
|
||||||
scm *
|
|
||||||
atom_p (scm *x)
|
|
||||||
{
|
|
||||||
return ATOM_P(x);
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
scm *
|
||||||
car (scm *x)
|
car (scm *x)
|
||||||
{
|
{
|
||||||
|
|
@ -144,37 +138,15 @@ cons (scm *x, scm *y)
|
||||||
return p;
|
return p;
|
||||||
}
|
}
|
||||||
|
|
||||||
#define EQ_P(x, y)\
|
|
||||||
((x == y \
|
|
||||||
|| (x->type == CHAR && y->type == CHAR \
|
|
||||||
&& x->value == y->value) \
|
|
||||||
|| (x->type == NUMBER && y->type == NUMBER \
|
|
||||||
&& x->value == y->value)) \
|
|
||||||
? &scm_t : &scm_f)
|
|
||||||
|
|
||||||
scm *
|
scm *
|
||||||
eq_p (scm *x, scm *y)
|
eq_p (scm *x, scm *y)
|
||||||
{
|
{
|
||||||
return EQ_P (x, y);
|
return (x == y
|
||||||
}
|
|| (x->type == CHAR && y->type == CHAR
|
||||||
|
&& x->value == y->value)
|
||||||
scm *
|
|| (x->type == NUMBER && y->type == NUMBER
|
||||||
macro_p (scm *x)
|
&& x->value == y->value))
|
||||||
{
|
? &scm_t : &scm_f;
|
||||||
return x->type == MACRO ? &scm_t : &scm_f;
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
|
||||||
null_p (scm *x)
|
|
||||||
{
|
|
||||||
return x == &scm_nil ? &scm_t : &scm_f;
|
|
||||||
}
|
|
||||||
|
|
||||||
#define PAIR_P(x) (x->type == PAIR ? &scm_t : &scm_f)
|
|
||||||
scm *
|
|
||||||
pair_p (scm *x)
|
|
||||||
{
|
|
||||||
return PAIR_P(x);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
scm *
|
scm *
|
||||||
|
|
@ -219,6 +191,8 @@ quasisyntax (scm *x)
|
||||||
return cons (&symbol_quasisyntax, x);
|
return cons (&symbol_quasisyntax, x);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
#include "type.c"
|
||||||
|
|
||||||
#if BUILTIN_QUASIQUOTE
|
#if BUILTIN_QUASIQUOTE
|
||||||
scm *
|
scm *
|
||||||
unquote (scm *x) ///((no-environment))
|
unquote (scm *x) ///((no-environment))
|
||||||
|
|
@ -271,7 +245,7 @@ pairlis (scm *x, scm *y, scm *a)
|
||||||
{
|
{
|
||||||
if (x == &scm_nil)
|
if (x == &scm_nil)
|
||||||
return a;
|
return a;
|
||||||
if (atom_p (x) == &scm_t)
|
if (pair_p (x) == &scm_f)
|
||||||
return cons (cons (x, y), a);
|
return cons (cons (x, y), a);
|
||||||
return cons (cons (car (x), car (y)),
|
return cons (cons (car (x), car (y)),
|
||||||
pairlis (cdr (x), cdr (y), a));
|
pairlis (cdr (x), cdr (y), a));
|
||||||
|
|
@ -280,7 +254,7 @@ pairlis (scm *x, scm *y, scm *a)
|
||||||
scm *
|
scm *
|
||||||
assq (scm *x, scm *a)
|
assq (scm *x, scm *a)
|
||||||
{
|
{
|
||||||
while (a != &scm_nil && EQ_P (x, a->car->car) == &scm_f) a = a->cdr;
|
while (a != &scm_nil && eq_p (x, a->car->car) == &scm_f) a = a->cdr;
|
||||||
return a != &scm_nil ? a->car : &scm_f;
|
return a != &scm_nil ? a->car : &scm_f;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -432,7 +406,7 @@ scm *
|
||||||
builtin_eval (scm *e, scm *a)
|
builtin_eval (scm *e, scm *a)
|
||||||
{
|
{
|
||||||
if (builtin_p (e) == &scm_t) return e;
|
if (builtin_p (e) == &scm_t) return e;
|
||||||
if (internal_p (e) == &scm_t) return e;
|
if (e->type == SCM) return e;
|
||||||
|
|
||||||
e = expand_macro_env (e, a);
|
e = expand_macro_env (e, a);
|
||||||
|
|
||||||
|
|
@ -558,59 +532,6 @@ scm*eval_quasisyntax (scm *e, scm *a){}
|
||||||
|
|
||||||
//Helpers
|
//Helpers
|
||||||
|
|
||||||
scm *
|
|
||||||
builtin_p (scm *x)
|
|
||||||
{
|
|
||||||
return (x->type == FUNCTION0
|
|
||||||
|| x->type == FUNCTION1
|
|
||||||
|| x->type == FUNCTION2
|
|
||||||
|| x->type == FUNCTION3
|
|
||||||
|| x->type == FUNCTIONn)
|
|
||||||
? &scm_t : &scm_f;
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
|
||||||
boolean_p (scm *x)
|
|
||||||
{
|
|
||||||
return (x == &scm_t || x == &scm_f) ? &scm_t : &scm_f;
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
|
||||||
char_p (scm *x)
|
|
||||||
{
|
|
||||||
return x->type == CHAR ? &scm_t : &scm_f;
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
|
||||||
number_p (scm *x)
|
|
||||||
{
|
|
||||||
return x->type == NUMBER ? &scm_t : &scm_f;
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
|
||||||
string_p (scm *x)
|
|
||||||
{
|
|
||||||
return x->type == STRING ? &scm_t : &scm_f;
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
|
||||||
internal_p (scm *x)
|
|
||||||
{
|
|
||||||
return x->type == SCM ? &scm_t : &scm_f;
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
|
||||||
symbol_p (scm *x)
|
|
||||||
{
|
|
||||||
return x->type == SYMBOL ? &scm_t : &scm_f;
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
|
||||||
vector_p (scm *x)
|
|
||||||
{
|
|
||||||
return x->type == VECTOR ? &scm_t : &scm_f;
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
scm *
|
||||||
display (scm *x) ///((args . n))
|
display (scm *x) ///((args . n))
|
||||||
{
|
{
|
||||||
|
|
@ -623,7 +544,7 @@ display (scm *x) ///((args . n))
|
||||||
}
|
}
|
||||||
|
|
||||||
scm *
|
scm *
|
||||||
display_ (FILE* f, scm *x) ///((internal))
|
display_ (FILE* f, scm *x)
|
||||||
{
|
{
|
||||||
return display_helper (f, x, false, "", false);
|
return display_helper (f, x, false, "", false);
|
||||||
}
|
}
|
||||||
|
|
@ -1080,7 +1001,7 @@ display_helper (FILE* f, scm *x, bool cont, char const *sep, bool quote)
|
||||||
fprintf (f, ")");
|
fprintf (f, ")");
|
||||||
}
|
}
|
||||||
else if (builtin_p (x) == &scm_t) fprintf (f, "#<procedure %s>", x->name);
|
else if (builtin_p (x) == &scm_t) fprintf (f, "#<procedure %s>", x->name);
|
||||||
else if (atom_p (x) == &scm_t) fprintf (f, "%s", x->name);
|
else if (pair_p (x) == &scm_f) fprintf (f, "%s", x->name);
|
||||||
|
|
||||||
return &scm_unspecified;
|
return &scm_unspecified;
|
||||||
}
|
}
|
||||||
|
|
@ -1471,6 +1392,7 @@ mes_environment () ///((internal))
|
||||||
a = cons (cons (&symbol_syntax, &scm_syntax), a);
|
a = cons (cons (&symbol_syntax, &scm_syntax), a);
|
||||||
|
|
||||||
#include "mes.environment.i"
|
#include "mes.environment.i"
|
||||||
|
#include "type.environment.i"
|
||||||
|
|
||||||
a = cons (cons (&scm_closure, a), a);
|
a = cons (cons (&scm_closure, a), a);
|
||||||
return a;
|
return a;
|
||||||
|
|
|
||||||
|
|
@ -73,161 +73,3 @@
|
||||||
()
|
()
|
||||||
;; enter reading loop-0
|
;; enter reading loop-0
|
||||||
(display "loop-0 ...\n")
|
(display "loop-0 ...\n")
|
||||||
|
|
||||||
(define-macro (cond . clauses)
|
|
||||||
(list 'if (null? clauses) *unspecified*
|
|
||||||
(if (null? (cdr clauses))
|
|
||||||
(list 'if (car (car clauses))
|
|
||||||
(list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
|
|
||||||
*unspecified*)
|
|
||||||
(if (eq? (car (cadr clauses)) 'else)
|
|
||||||
(list 'if (car (car clauses))
|
|
||||||
(list (cons 'lambda (cons '() (car clauses))))
|
|
||||||
(list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
|
|
||||||
(list 'if (car (car clauses))
|
|
||||||
(list (cons 'lambda (cons '() (car clauses))))
|
|
||||||
(cons 'cond (cdr clauses)))))))
|
|
||||||
|
|
||||||
(define (map f l . r)
|
|
||||||
(if (null? l) '()
|
|
||||||
(if (null? r) (cons (f (car l)) (map f (cdr l)))
|
|
||||||
(if (null? (cdr r))
|
|
||||||
(cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))
|
|
||||||
|
|
||||||
(define-macro (simple-let bindings . rest)
|
|
||||||
(cons (cons 'lambda (cons (map car bindings) rest))
|
|
||||||
(map cadr bindings)))
|
|
||||||
|
|
||||||
(define-macro (let bindings . rest)
|
|
||||||
(cons 'simple-let (cons bindings rest)))
|
|
||||||
|
|
||||||
(define-macro (or . x)
|
|
||||||
(if (null? x) #f
|
|
||||||
(if (null? (cdr x)) (car x)
|
|
||||||
(list 'if (car x) (car x)
|
|
||||||
(cons 'or (cdr x))))))
|
|
||||||
|
|
||||||
(define-macro (and . x)
|
|
||||||
(if (null? x) #t
|
|
||||||
(if (null? (cdr x)) (car x)
|
|
||||||
(list 'if (car x) (cons 'and (cdr x))
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
(define (not x)
|
|
||||||
(if x #f #t))
|
|
||||||
|
|
||||||
(define (evlis-env m a)
|
|
||||||
(cond
|
|
||||||
((null? m) '())
|
|
||||||
((not (pair? m)) (eval m a))
|
|
||||||
(#t (cons (eval (car m) a) (evlis-env (cdr m) a)))))
|
|
||||||
|
|
||||||
(define (apply-env fn x a)
|
|
||||||
(cond
|
|
||||||
((atom? fn)
|
|
||||||
(cond
|
|
||||||
((builtin? fn) (call fn x))
|
|
||||||
((eq? fn 'call-with-values) (c:apply-env 'call-with-values x a))
|
|
||||||
((eq? fn 'current-module) a)
|
|
||||||
(#t (apply-env (eval fn a) x a))))
|
|
||||||
((eq? (car fn) 'lambda)
|
|
||||||
(let ((p (pairlis (cadr fn) x a)))
|
|
||||||
(cache-invalidate-range p (cdr a))
|
|
||||||
(let ((r (eval (cons 'begin (cddr fn)) (cons (cons '*closure* p) p))))
|
|
||||||
(cache-invalidate-range p (cdr a))
|
|
||||||
r)))
|
|
||||||
((eq? (car fn) '*closure*)
|
|
||||||
(let ((args (caddr fn))
|
|
||||||
(body (cdddr fn))
|
|
||||||
(a (cddr (cadr fn))))
|
|
||||||
(let ((p (pairlis args x a)))
|
|
||||||
(cache-invalidate-range p (cdr a))
|
|
||||||
(let ((r (eval (cons 'begin body) (cons (cons '*closure* p) p))))
|
|
||||||
(cache-invalidate-range p (cdr a))
|
|
||||||
r))))
|
|
||||||
;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
|
|
||||||
(#t (apply-env (eval fn a) x a))))
|
|
||||||
|
|
||||||
(define (eval-expand e a)
|
|
||||||
(cond
|
|
||||||
((internal? e) e)
|
|
||||||
((builtin? e) e)
|
|
||||||
((char? e) e)
|
|
||||||
((number? e) e)
|
|
||||||
((string? e) e)
|
|
||||||
((vector? e) e)
|
|
||||||
((symbol? e) (assq-ref-cache e a))
|
|
||||||
((atom? (car e))
|
|
||||||
(cond
|
|
||||||
((eq? (car e) 'quote) (cadr e))
|
|
||||||
((eq? (car e) 'syntax) (cadr e))
|
|
||||||
((eq? (car e) 'begin) (eval-begin-env e a))
|
|
||||||
((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
|
|
||||||
((eq? (car e) '*closure*) e)
|
|
||||||
((eq? (car e) 'if) (eval-if-env (cdr e) a))
|
|
||||||
((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
|
|
||||||
((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
|
|
||||||
((eq? (car e) 'set!) (set-env! (cadr e) (eval (caddr e) a) a))
|
|
||||||
((eq? (car e) 'apply-env) (apply-env (eval (cadr e) a) (evlis-env (caddr e) a) a))
|
|
||||||
((eq? (car e) 'unquote) (eval (cadr e) a))
|
|
||||||
((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
|
|
||||||
(#t (apply-env (car e) (evlis-env (cdr e) a) a))))
|
|
||||||
(#t (apply-env (car e) (evlis-env (cdr e) a) a))))
|
|
||||||
|
|
||||||
(define (unquote x) (cons 'unquote x))
|
|
||||||
(define (unquote-splicing x) (cons 'quasiquote x))
|
|
||||||
|
|
||||||
(define (add-unquoters a)
|
|
||||||
(cons (cons 'unquote unquote)
|
|
||||||
(cons (cons 'unquote-splicing unquote-splicing) a)))
|
|
||||||
|
|
||||||
(define (eval e a)
|
|
||||||
(eval-expand (expand-macro-env e a) a))
|
|
||||||
|
|
||||||
(define (expand-macro-env e a)
|
|
||||||
(if (pair? e) ((lambda (macro)
|
|
||||||
(if macro (expand-macro-env (apply-env macro (cdr e) a) a)
|
|
||||||
e))
|
|
||||||
(lookup-macro (car e) a))
|
|
||||||
e))
|
|
||||||
|
|
||||||
(define (eval-begin-env e a)
|
|
||||||
(if (null? e) *unspecified*
|
|
||||||
(if (null? (cdr e)) (eval (car e) a)
|
|
||||||
(begin
|
|
||||||
(eval (car e) a)
|
|
||||||
(eval-begin-env (cdr e) a)))))
|
|
||||||
|
|
||||||
(define (eval-if-env e a)
|
|
||||||
(if (eval (car e) a) (eval (cadr e) a)
|
|
||||||
(if (pair? (cddr e)) (eval (caddr e) a))))
|
|
||||||
|
|
||||||
(define (eval-quasiquote e a)
|
|
||||||
(cond ((null? e) e)
|
|
||||||
((atom? e) e)
|
|
||||||
((eq? (car e) 'unquote) (eval (cadr e) a))
|
|
||||||
((and (pair? (car e))
|
|
||||||
(eq? (caar e) 'unquote-splicing))
|
|
||||||
(append2 (eval (cadar e) a) (eval-quasiquote (cdr e) a)))
|
|
||||||
(#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
|
|
||||||
|
|
||||||
(define (sexp:define e a)
|
|
||||||
(if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
|
|
||||||
(cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a))))
|
|
||||||
|
|
||||||
(define (env:define a+ a)
|
|
||||||
(set-cdr! a+ (cdr a))
|
|
||||||
(set-cdr! a a+)
|
|
||||||
(set-cdr! (assq '*closure* a) a))
|
|
||||||
|
|
||||||
(define (env:macro name+entry)
|
|
||||||
(cons
|
|
||||||
(cons (car name+entry)
|
|
||||||
(make-macro (car name+entry)
|
|
||||||
(cdr name+entry)))
|
|
||||||
'()))
|
|
||||||
|
|
||||||
;; boot into loop-0
|
|
||||||
(cache-invalidate-range (current-module) '())
|
|
||||||
()
|
|
||||||
ignored
|
|
||||||
|
|
|
||||||
188
module/mes/mes-0.mes
Normal file
188
module/mes/mes-0.mes
Normal file
|
|
@ -0,0 +1,188 @@
|
||||||
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
|
;;; Mes --- Maxwell Equations of Software
|
||||||
|
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; mes-0.mes: 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/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;;; mes-0.mes - bootstrap into Scheme, re
|
||||||
|
|
||||||
|
;;; When compiling mes.c with -DBOOT=1, eval/apply et al. are lacking
|
||||||
|
;;; features wrt the fat-c variant, e.g., define and define-macro are
|
||||||
|
;;; not available; instead label is supplied. Before loading
|
||||||
|
;;; boot-0.mes, loop-0.mes is loaded to provide a richer eval/apply.
|
||||||
|
|
||||||
|
;;; This might enable moving more functionality from C to Scheme,
|
||||||
|
;;; making the entirely-from-source bootstrap process more feasible.
|
||||||
|
;;; However, currently performance is 400x worse. Also several tests
|
||||||
|
;;; in the test suite fail and the REPL does not work yet.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-macro (cond . clauses)
|
||||||
|
(list 'if (null? clauses) *unspecified*
|
||||||
|
(if (null? (cdr clauses))
|
||||||
|
(list 'if (car (car clauses))
|
||||||
|
(list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
|
||||||
|
*unspecified*)
|
||||||
|
(if (eq? (car (cadr clauses)) 'else)
|
||||||
|
(list 'if (car (car clauses))
|
||||||
|
(list (cons 'lambda (cons '() (car clauses))))
|
||||||
|
(list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
|
||||||
|
(list 'if (car (car clauses))
|
||||||
|
(list (cons 'lambda (cons '() (car clauses))))
|
||||||
|
(cons 'cond (cdr clauses)))))))
|
||||||
|
|
||||||
|
(define (map f l . r)
|
||||||
|
(if (null? l) '()
|
||||||
|
(if (null? r) (cons (f (car l)) (map f (cdr l)))
|
||||||
|
(if (null? (cdr r))
|
||||||
|
(cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))
|
||||||
|
|
||||||
|
(define-macro (simple-let bindings . rest)
|
||||||
|
(cons (cons 'lambda (cons (map car bindings) rest))
|
||||||
|
(map cadr bindings)))
|
||||||
|
|
||||||
|
(define-macro (let bindings . rest)
|
||||||
|
(cons 'simple-let (cons bindings rest)))
|
||||||
|
|
||||||
|
(define-macro (or . x)
|
||||||
|
(if (null? x) #f
|
||||||
|
(if (null? (cdr x)) (car x)
|
||||||
|
(list 'if (car x) (car x)
|
||||||
|
(cons 'or (cdr x))))))
|
||||||
|
|
||||||
|
(define-macro (and . x)
|
||||||
|
(if (null? x) #t
|
||||||
|
(if (null? (cdr x)) (car x)
|
||||||
|
(list 'if (car x) (cons 'and (cdr x))
|
||||||
|
#f))))
|
||||||
|
|
||||||
|
(define (not x)
|
||||||
|
(if x #f #t))
|
||||||
|
|
||||||
|
(define (evlis-env m a)
|
||||||
|
(cond
|
||||||
|
((null? m) '())
|
||||||
|
((not (pair? m)) (eval m a))
|
||||||
|
(#t (cons (eval (car m) a) (evlis-env (cdr m) a)))))
|
||||||
|
|
||||||
|
(define (apply-env fn x a)
|
||||||
|
(cond
|
||||||
|
((atom? fn)
|
||||||
|
(cond
|
||||||
|
((builtin? fn) (call fn x))
|
||||||
|
((eq? fn 'call-with-values) (c:apply-env 'call-with-values x a))
|
||||||
|
((eq? fn 'current-module) a)
|
||||||
|
(#t (apply-env (eval fn a) x a))))
|
||||||
|
((eq? (car fn) 'lambda)
|
||||||
|
(let ((p (pairlis (cadr fn) x a)))
|
||||||
|
(cache-invalidate-range p (cdr a))
|
||||||
|
(let ((r (eval (cons 'begin (cddr fn)) (cons (cons '*closure* p) p))))
|
||||||
|
(cache-invalidate-range p (cdr a))
|
||||||
|
r)))
|
||||||
|
((eq? (car fn) '*closure*)
|
||||||
|
(let ((args (caddr fn))
|
||||||
|
(body (cdddr fn))
|
||||||
|
(a (cddr (cadr fn))))
|
||||||
|
(let ((p (pairlis args x a)))
|
||||||
|
(cache-invalidate-range p (cdr a))
|
||||||
|
(let ((r (eval (cons 'begin body) (cons (cons '*closure* p) p))))
|
||||||
|
(cache-invalidate-range p (cdr a))
|
||||||
|
r))))
|
||||||
|
;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
|
||||||
|
(#t (apply-env (eval fn a) x a))))
|
||||||
|
|
||||||
|
(define (eval-expand e a)
|
||||||
|
(cond
|
||||||
|
((symbol? e) (assq-ref-cache e a))
|
||||||
|
((atom? e) e)
|
||||||
|
((atom? (car e))
|
||||||
|
(cond
|
||||||
|
((eq? (car e) 'quote) (cadr e))
|
||||||
|
((eq? (car e) 'syntax) (cadr e))
|
||||||
|
((eq? (car e) 'begin) (eval-begin-env e a))
|
||||||
|
((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
|
||||||
|
((eq? (car e) '*closure*) e)
|
||||||
|
((eq? (car e) 'if) (eval-if-env (cdr e) a))
|
||||||
|
((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
|
||||||
|
((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
|
||||||
|
((eq? (car e) 'set!) (set-env! (cadr e) (eval (caddr e) a) a))
|
||||||
|
((eq? (car e) 'apply-env) (apply-env (eval (cadr e) a) (evlis-env (caddr e) a) a))
|
||||||
|
((eq? (car e) 'unquote) (eval (cadr e) a))
|
||||||
|
((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
|
||||||
|
(#t (apply-env (car e) (evlis-env (cdr e) a) a))))
|
||||||
|
(#t (apply-env (car e) (evlis-env (cdr e) a) a))))
|
||||||
|
|
||||||
|
(define (unquote x) (cons 'unquote x))
|
||||||
|
(define (unquote-splicing x) (cons 'quasiquote x))
|
||||||
|
|
||||||
|
(define (add-unquoters a)
|
||||||
|
(cons (cons 'unquote unquote)
|
||||||
|
(cons (cons 'unquote-splicing unquote-splicing) a)))
|
||||||
|
|
||||||
|
(define (eval e a)
|
||||||
|
(eval-expand (expand-macro-env e a) a))
|
||||||
|
|
||||||
|
(define (expand-macro-env e a)
|
||||||
|
(if (pair? e) ((lambda (macro)
|
||||||
|
(if macro (expand-macro-env (apply-env macro (cdr e) a) a)
|
||||||
|
e))
|
||||||
|
(lookup-macro (car e) a))
|
||||||
|
e))
|
||||||
|
|
||||||
|
(define (eval-begin-env e a)
|
||||||
|
(if (null? e) *unspecified*
|
||||||
|
(if (null? (cdr e)) (eval (car e) a)
|
||||||
|
(begin
|
||||||
|
(eval (car e) a)
|
||||||
|
(eval-begin-env (cdr e) a)))))
|
||||||
|
|
||||||
|
(define (eval-if-env e a)
|
||||||
|
(if (eval (car e) a) (eval (cadr e) a)
|
||||||
|
(if (pair? (cddr e)) (eval (caddr e) a))))
|
||||||
|
|
||||||
|
(define (eval-quasiquote e a)
|
||||||
|
(cond ((null? e) e)
|
||||||
|
((atom? e) e)
|
||||||
|
((eq? (car e) 'unquote) (eval (cadr e) a))
|
||||||
|
((and (pair? (car e))
|
||||||
|
(eq? (caar e) 'unquote-splicing))
|
||||||
|
(append2 (eval (cadar e) a) (eval-quasiquote (cdr e) a)))
|
||||||
|
(#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
|
||||||
|
|
||||||
|
(define (sexp:define e a)
|
||||||
|
(if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
|
||||||
|
(cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a))))
|
||||||
|
|
||||||
|
(define (env:define a+ a)
|
||||||
|
(set-cdr! a+ (cdr a))
|
||||||
|
(set-cdr! a a+)
|
||||||
|
(set-cdr! (assq '*closure* a) a))
|
||||||
|
|
||||||
|
(define (env:macro name+entry)
|
||||||
|
(cons
|
||||||
|
(cons (car name+entry)
|
||||||
|
(make-macro (car name+entry)
|
||||||
|
(cdr name+entry)))
|
||||||
|
'()))
|
||||||
|
|
||||||
|
;; boot into loop-0
|
||||||
|
(cache-invalidate-range (current-module) '())
|
||||||
|
()
|
||||||
|
ignored
|
||||||
95
module/mes/type-0.mes
Normal file
95
module/mes/type-0.mes
Normal file
|
|
@ -0,0 +1,95 @@
|
||||||
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
|
;;; Mes --- Maxwell Equations of Software
|
||||||
|
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; type-0.mes: 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/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;;; type-0.mes - to be loaded after loop-0.mes if type.i is not
|
||||||
|
;;; included in core.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;; two copies of enum type, with manual numbering FIXME
|
||||||
|
(define <char> 0)
|
||||||
|
(define <macro> 1)
|
||||||
|
(define <number> 2)
|
||||||
|
(define <pair> 3)
|
||||||
|
(define <scm> 4)
|
||||||
|
(define <string> 5)
|
||||||
|
(define <symbol> 6)
|
||||||
|
(define <values> 7)
|
||||||
|
(define <vector> 8)
|
||||||
|
(define <function0> 8)
|
||||||
|
(define <function1> 9)
|
||||||
|
(define <function2> 10)
|
||||||
|
(define <function3> 11)
|
||||||
|
(define <functionn> 12)
|
||||||
|
|
||||||
|
(define mes-type-alist
|
||||||
|
`((,<char> . <char>)
|
||||||
|
(,<macro> . <macro>)
|
||||||
|
(,<number> . <number>)
|
||||||
|
(,<pair> . <pair>)
|
||||||
|
(,<scm> . <scm>)
|
||||||
|
(,<string> . <string>)
|
||||||
|
(,<symbol> . <symbol>)
|
||||||
|
(,<char> . <char>)
|
||||||
|
(,<values> . <values>)
|
||||||
|
(,<function0> . <function0>)
|
||||||
|
(,<function1> . <function1>)
|
||||||
|
(,<function2> . <function2>)
|
||||||
|
(,<function3> . <function3>)
|
||||||
|
(,<functionn> . <functionn>)))
|
||||||
|
|
||||||
|
(define (class-of x)
|
||||||
|
(assq (mes-type-of x) mes-type-alist))
|
||||||
|
|
||||||
|
(define (atom? x)
|
||||||
|
(not (pair? x)))
|
||||||
|
|
||||||
|
(define (boolean? x)
|
||||||
|
(if (eq? x #f) #t
|
||||||
|
(if (eq? x #t) #t
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(define (char? x)
|
||||||
|
(eq? (mes-type-of x) <char>))
|
||||||
|
|
||||||
|
;; pair? is not needed as a primitive from C
|
||||||
|
;; but it gives a factor 2 speedup
|
||||||
|
;; (define (pair? x)
|
||||||
|
;; (eq? (mes-type-of x) <pair>))
|
||||||
|
|
||||||
|
(define (number? x)
|
||||||
|
(eq? (mes-type-of x) <number>))
|
||||||
|
|
||||||
|
(define (internal? x)
|
||||||
|
(eq? (mes-type-of x) <scm>))
|
||||||
|
|
||||||
|
(define (string? x)
|
||||||
|
(eq? (mes-type-of x) <string>))
|
||||||
|
|
||||||
|
(define (symbol? x)
|
||||||
|
(eq? (mes-type-of x) <symbol>))
|
||||||
|
|
||||||
|
(define (vector? x)
|
||||||
|
(eq? (mes-type-of x) <vector>))
|
||||||
|
|
||||||
|
(define (null? x)
|
||||||
|
(eq? x '()))
|
||||||
|
|
@ -12,6 +12,10 @@ done
|
||||||
|
|
||||||
if [ -n "$BOOT" ]; then
|
if [ -n "$BOOT" ]; then
|
||||||
echo $prefix/module/mes/loop-0.mes
|
echo $prefix/module/mes/loop-0.mes
|
||||||
|
if [ -n "$TYPE0" ]; then
|
||||||
|
echo $prefix/module/mes/type-0.mes
|
||||||
|
fi
|
||||||
|
echo $prefix/module/mes/mes-0.mes
|
||||||
fi
|
fi
|
||||||
cat $1 \
|
cat $1 \
|
||||||
| grep -Eo '(mes-use-module \([^()]+ [^()]+))' \
|
| grep -Eo '(mes-use-module \([^()]+ [^()]+))' \
|
||||||
|
|
|
||||||
102
type.c
Normal file
102
type.c
Normal file
|
|
@ -0,0 +1,102 @@
|
||||||
|
/* -*-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 !TYPE0
|
||||||
|
|
||||||
|
scm *
|
||||||
|
char_p (scm *x)
|
||||||
|
{
|
||||||
|
return x->type == CHAR ? &scm_t : &scm_f;
|
||||||
|
}
|
||||||
|
|
||||||
|
scm *
|
||||||
|
macro_p (scm *x)
|
||||||
|
{
|
||||||
|
return x->type == MACRO ? &scm_t : &scm_f;
|
||||||
|
}
|
||||||
|
|
||||||
|
scm *
|
||||||
|
number_p (scm *x)
|
||||||
|
{
|
||||||
|
return x->type == NUMBER ? &scm_t : &scm_f;
|
||||||
|
}
|
||||||
|
|
||||||
|
scm *
|
||||||
|
pair_p (scm *x)
|
||||||
|
{
|
||||||
|
return x->type == PAIR ? &scm_t : &scm_f;
|
||||||
|
}
|
||||||
|
|
||||||
|
scm *
|
||||||
|
string_p (scm *x)
|
||||||
|
{
|
||||||
|
return x->type == STRING ? &scm_t : &scm_f;
|
||||||
|
}
|
||||||
|
|
||||||
|
scm *
|
||||||
|
symbol_p (scm *x)
|
||||||
|
{
|
||||||
|
return x->type == SYMBOL ? &scm_t : &scm_f;
|
||||||
|
}
|
||||||
|
|
||||||
|
scm *
|
||||||
|
vector_p (scm *x)
|
||||||
|
{
|
||||||
|
return x->type == VECTOR ? &scm_t : &scm_f;
|
||||||
|
}
|
||||||
|
|
||||||
|
scm *
|
||||||
|
builtin_p (scm *x)
|
||||||
|
{
|
||||||
|
return (x->type == FUNCTION0
|
||||||
|
|| x->type == FUNCTION1
|
||||||
|
|| x->type == FUNCTION2
|
||||||
|
|| x->type == FUNCTION3
|
||||||
|
|| x->type == FUNCTIONn)
|
||||||
|
? &scm_t : &scm_f;
|
||||||
|
}
|
||||||
|
|
||||||
|
// Non-types
|
||||||
|
scm *
|
||||||
|
null_p (scm *x)
|
||||||
|
{
|
||||||
|
return x == &scm_nil ? &scm_t : &scm_f;
|
||||||
|
}
|
||||||
|
|
||||||
|
scm *
|
||||||
|
atom_p (scm *x)
|
||||||
|
{
|
||||||
|
return (x->type == PAIR ? &scm_f : &scm_t);
|
||||||
|
}
|
||||||
|
|
||||||
|
scm *
|
||||||
|
boolean_p (scm *x)
|
||||||
|
{
|
||||||
|
return (x == &scm_t || x == &scm_f) ? &scm_t : &scm_f;
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
scm*make_number (int);
|
||||||
|
scm *
|
||||||
|
mes_type_of (scm *x)
|
||||||
|
{
|
||||||
|
return make_number (x->type);
|
||||||
|
}
|
||||||
|
|
||||||
Loading…
Reference in a new issue