Move optional type predicates to type.c.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 22 Oct 2016 10:16:19 +0000 (12:16 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 22 Oct 2016 10:16:19 +0000 (12:16 +0200)
* 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.

GNUmakefile
build-aux/mes-snarf.scm
mes.c
module/mes/loop-0.mes
module/mes/mes-0.mes [new file with mode: 0644]
module/mes/type-0.mes [new file with mode: 0644]
scripts/include.mes
type.c [new file with mode: 0644]

index bdb316173dc0c4c02f4bcb0077de75538e86a1c2..a939d8e50e29bdd654c0fc1dee8fed2d45fe0f2d 100644 (file)
@@ -22,7 +22,9 @@ include make/install.make
 
 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:
        rm -f mes mes.o mes.environment.i mes.symbols.i mes.environment.h *.cat a.out
@@ -30,7 +32,7 @@ clean:
 distclean: clean
        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 $<
 
 check: all guile-check mes-check
index 048917540d6ea891fc84a40e776ccd4c40836f6b..bc5456ea8a28dc0cfd90cfd9eed8c4b097631017 100755 (executable)
@@ -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)))
          matches)))
 
+(define (content? f)
+  ((compose not string-null? .content) f))
+
 (define (internal? 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)
   (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))
 
diff --git a/mes.c b/mes.c
index ca446bf11aba96cdd90864df3fa326ebf9e422a1..dbf4a7e7412d19dd9536670b56bb23973c3dc941 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -62,6 +62,7 @@ typedef struct scm_t {
 
 scm temp_number = {NUMBER, .name="nul", .value=0};
 
+#include "type.environment.h"
 #include "mes.environment.h"
 
 scm *display_ (FILE* f, scm *x);
@@ -113,13 +114,6 @@ scm char_space = {CHAR, .name="space", .value=32};
 
 // PRIMITIVES
 
-#define ATOM_P(x) (x->type == PAIR ? &scm_f : &scm_t)
-scm *
-atom_p (scm *x)
-{
-  return ATOM_P(x);
-}
-
 scm *
 car (scm *x)
 {
@@ -144,37 +138,15 @@ cons (scm *x, scm *y)
   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 *
 eq_p (scm *x, scm *y)
 {
-  return EQ_P (x, y);
-}
-
-scm *
-macro_p (scm *x)
-{
-  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);
+  return (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 *
@@ -219,6 +191,8 @@ quasisyntax (scm *x)
   return cons (&symbol_quasisyntax, x);
 }
 
+#include "type.c"
+
 #if BUILTIN_QUASIQUOTE
 scm *
 unquote (scm *x) ///((no-environment))
@@ -271,7 +245,7 @@ pairlis (scm *x, scm *y, scm *a)
 {
   if (x == &scm_nil)
     return a;
-  if (atom_p (x) == &scm_t)
+  if (pair_p (x) == &scm_f)
     return cons (cons (x, y), a);
   return cons (cons (car (x), car (y)),
                pairlis (cdr (x), cdr (y), a));
@@ -280,7 +254,7 @@ pairlis (scm *x, scm *y, scm *a)
 scm *
 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;
 }
 
@@ -432,7 +406,7 @@ scm *
 builtin_eval (scm *e, scm *a)
 {
   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);
 
@@ -558,59 +532,6 @@ scm*eval_quasisyntax (scm *e, scm *a){}
 
 //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 *
 display (scm *x) ///((args . n))
 {
@@ -623,7 +544,7 @@ display (scm *x) ///((args . n))
 }
 
 scm *
-display_ (FILE* f, scm *x) ///((internal))
+display_ (FILE* f, scm *x)
 {
   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, ")");
   }
   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;
 }
@@ -1471,6 +1392,7 @@ mes_environment () ///((internal))
   a = cons (cons (&symbol_syntax, &scm_syntax), a);
 
 #include "mes.environment.i"
+#include "type.environment.i"
 
   a = cons (cons (&scm_closure, a), a);
   return a;
index dd406984933e1712ad8c8a1e3555dced9d39f521..6fbf654cb52b5fc14862ab7cbec2f11f3d7d8a6e 100644 (file)
 ()
 ;; enter reading loop-0
 (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
diff --git a/module/mes/mes-0.mes b/module/mes/mes-0.mes
new file mode 100644 (file)
index 0000000..e5fbe0a
--- /dev/null
@@ -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
diff --git a/module/mes/type-0.mes b/module/mes/type-0.mes
new file mode 100644 (file)
index 0000000..522b4a4
--- /dev/null
@@ -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 '()))
index 3638d04b074e5ad6bbabbb796d5e25767f02ac76..3b17f49c2e58207dd0a72b779f071400c916db1a 100755 (executable)
@@ -12,6 +12,10 @@ done
 
 if [ -n "$BOOT" ]; then
     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
 cat $1 \
   | grep -Eo '(mes-use-module \([^()]+ [^()]+))' \
diff --git a/type.c b/type.c
new file mode 100644 (file)
index 0000000..ddf4e01
--- /dev/null
+++ b/type.c
@@ -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);
+}
+