diff --git a/GNUmakefile b/GNUmakefile index bdb31617..a939d8e5 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -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 diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index 04891754..bc5456ea 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -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 ca446bf1..dbf4a7e7 100644 --- 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, "#", 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; diff --git a/module/mes/loop-0.mes b/module/mes/loop-0.mes index dd406984..6fbf654c 100644 --- a/module/mes/loop-0.mes +++ b/module/mes/loop-0.mes @@ -73,161 +73,3 @@ () ;; 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 index 00000000..e5fbe0af --- /dev/null +++ b/module/mes/mes-0.mes @@ -0,0 +1,188 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +;;; 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 index 00000000..522b4a45 --- /dev/null +++ b/module/mes/type-0.mes @@ -0,0 +1,95 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +;;; 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 0) +(define 1) +(define 2) +(define 3) +(define 4) +(define 5) +(define 6) +(define 7) +(define 8) +(define 8) +(define 9) +(define 10) +(define 11) +(define 12) + +(define mes-type-alist + `((, . ) + (, . ) + (, . ) + (, . ) + (, . ) + (, . ) + (, . ) + (, . ) + (, . ) + (, . ) + (, . ) + (, . ) + (, . ) + (, . ))) + +(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) )) + +;; pair? is not needed as a primitive from C +;; but it gives a factor 2 speedup +;; (define (pair? x) +;; (eq? (mes-type-of x) )) + +(define (number? x) + (eq? (mes-type-of x) )) + +(define (internal? x) + (eq? (mes-type-of x) )) + +(define (string? x) + (eq? (mes-type-of x) )) + +(define (symbol? x) + (eq? (mes-type-of x) )) + +(define (vector? x) + (eq? (mes-type-of x) )) + +(define (null? x) + (eq? x '())) diff --git a/scripts/include.mes b/scripts/include.mes index 3638d04b..3b17f49c 100755 --- a/scripts/include.mes +++ b/scripts/include.mes @@ -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 index 00000000..ddf4e019 --- /dev/null +++ b/type.c @@ -0,0 +1,102 @@ +/* -*-comment-start: "//";comment-end:""-*- + * Mes --- Maxwell Equations of Software + * Copyright © 2016 Jan Nieuwenhuizen + * + * 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 . + */ + +#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); +} +