module/mes/base-0.mes

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016,2017 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 ;;; Commentary:
  22
  23 ;;; base-0.mes is the first file being loaded from the Mes core.  It
  24 ;;; provides primitives that use Mes internals to create the illusion
  25 ;;; of compatibility with Guile.  It is not safe to be run by Guile.
  26
  27 ;;; Code:
  28
  29 (define (effective-version) %version)
  30 (define mes? #t)
  31 (define guile? #f)
  32 (define guile-1.8? #f)
  33 (define guile-2? #f)
  34
  35 (define (primitive-eval e) (core:eval e (current-module)))
  36 (define eval core:eval)
  37
  38 (define-macro (defined? x)
  39   (list 'assq x '(cdr (cdr (current-module)))))
  40
  41 (if (defined? 'current-input-port) #t
  42     (define (current-input-port) 0))
  43
  44 (define (current-output-port) 1)
  45 (define (current-error-port) 2)
  46 (define (port-filename port) "<stdin>")
  47 (define (port-line port) 0)
  48 (define (port-column port) 0)
  49 (define (ftell port) 0)
  50 (define (false-if-exception x) x)
  51
  52 (define (cons* . rest)
  53   (if (null? (cdr rest)) (car rest)
  54       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
  55
  56 (define (apply f h . t)
  57   (if (null? t) (core:apply f h (current-module))
  58       (apply f (apply cons* (cons h t)))))
  59
  60 (define-macro (cond . clauses)
  61   (list 'if (pair? clauses)
  62         (list (cons
  63                'lambda
  64                (cons
  65                 '(test)
  66                 (list (list 'if 'test
  67                             (if (pair? (cdr (car clauses)))
  68                                 (if (eq? (car (cdr (car clauses))) '=>)
  69                                     (append2 (cdr (cdr (car clauses))) '(test))
  70                                     (list (cons 'lambda (cons '() (car clauses)))))
  71                                 (list (cons 'lambda (cons '() (car clauses)))))
  72                             (if (pair? (cdr clauses))
  73                                 (cons 'cond (cdr clauses)))))))
  74               (car (car clauses)))))
  75
  76 (define else #t)
  77
  78 (define (cadr x) (car (cdr x)))
  79 (define-macro (simple-let bindings . rest)
  80   (cons (cons 'lambda (cons (map1 car bindings) rest))
  81         (map1 cadr bindings)))
  82
  83 (define-macro (let bindings . rest)
  84   (cons 'simple-let (cons bindings rest)))
  85
  86 (define *input-ports* '())
  87 (define-macro (push! stack o)
  88   (cons
  89    'begin
  90    (list
  91     (list 'set! stack (list cons o stack))
  92     stack)))
  93 (define-macro (pop! stack)
  94   (list 'let (list (list 'o (list car stack)))
  95         (list 'set! stack (list cdr stack))
  96         'o))
  97 (define-macro (load file)
  98   (list 'begin
  99         (list 'if (list getenv "MES_DEBUG")
 100               (list 'begin
 101                     (list core:display-error "read ")
 102                     (list core:display-error file)
 103                     (list core:display-error "\n")))
 104      (list 'push! '*input-ports* (list current-input-port))
 105      (list 'set-current-input-port (list open-input-file file))
 106      (list 'primitive-load)
 107      (list 'set-current-input-port (list 'pop! '*input-ports*))))
 108
 109 (define include load)
 110 (define-macro (include-from-path file)
 111   (list 'load (list string-append "module/" file)))
 112
 113 (define (append . rest)
 114   (if (null? rest) '()
 115       (if (null? (cdr rest)) (car rest)
 116           (append2 (car rest) (apply append (cdr rest))))))
 117
 118 (include "module/mes/type-0.mes")
 119
 120 (define (memq x lst)
 121   (if (null? lst) #f
 122       (if (eq? x (car lst)) lst
 123           (memq x (cdr lst)))))
 124
 125 (define (string-join lst infix)
 126   (if (null? (cdr lst)) (car lst)
 127       (string-append (car lst) infix (string-join (cdr lst) infix))))
 128
 129 (define *mes-prefix* "module/")
 130 (define (module->file o)
 131   (string-append (string-join (map1 symbol->string o) "/") ".mes"))
 132
 133 (define *modules* '(mes/base-0.mes))
 134 (define (mes-load-module-env module a)
 135   (push! *input-ports* (current-input-port))
 136   (set-current-input-port (open-input-file (string-append *mes-prefix* (module->file module))))
 137   (let ((x (core:eval (append2 (cons 'begin (read-input-file-env a))
 138                                '((current-module)))
 139                       a)))
 140     (set-current-input-port (pop! *input-ports*))
 141     x))
 142 (define (not x)
 143   (if x #f #t))
 144 (define-macro (mes-use-module module)
 145   (list
 146    'begin
 147    (list 'if (list 'not (list 'memq (list string->symbol (module->file module)) '*modules*))
 148          (list
 149           'begin
 150           (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*))
 151           (list 'load (list string-append '*mes-prefix* (module->file module)))))))
 152
 153 (mes-use-module (mes base))
 154 (mes-use-module (srfi srfi-0))
 155 (mes-use-module (mes quasiquote))
 156 (mes-use-module (mes let))
 157 (mes-use-module (mes scm))
 158 (mes-use-module (srfi srfi-13))
 159 (mes-use-module (mes display))
 160 (mes-use-module (mes catch))