module/mes/base.mes

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of Mes.
   7 ;;;
   8 ;;; Mes is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; Mes is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  20
  21
  22 ;;; Commentary:
  23
  24 ;;; base.mes is being loaded after base-0.mes.  It provides the minimal
  25 ;;; set of scheme primitives to run lib/test.mes.  It is safe to be
  26 ;;; run by Guile.
  27
  28 ;;; Code:
  29
  30 (define (identity x) x)
  31
  32 (define-macro (or . x)
  33   (if (null? x) #f
  34       (if (null? (cdr x)) (car x)
  35           (list 'if (car x) (car x)
  36                 (cons 'or (cdr x))))))
  37
  38 (define-macro (and . x)
  39   (if (null? x) #t
  40       (if (null? (cdr x)) (car x)
  41           (list 'if (car x) (cons 'and (cdr x))
  42                 #f))))
  43
  44 (define (equal? a b) ;; FIXME: only 2 arg
  45   (if (and (null? a) (null? b)) #t
  46       (if (and (pair? a) (pair? b))
  47           (and (equal? (car a) (car b))
  48                (equal? (cdr a) (cdr b)))
  49           (if (and (string? a) (string? b))
  50               (eq? (string->symbol a) (string->symbol b))
  51               (if (and (vector? a) (vector? b))
  52                   (equal? (vector->list a) (vector->list b))
  53                   (eq? a b))))))
  54
  55 (define (list? x)
  56   (or (null? x)
  57       (and (pair? x) (list? (cdr x)))))
  58
  59 (define (procedure? p)
  60   (cond ((builtin? p) #t)
  61         ((and (pair? p) (eq? (car p) 'lambda)))
  62         ((and (pair? p) (eq? (car p) '*closure*)))
  63         (#t #f)))