mes/module/mes/base-0.mes

;;; -*-scheme-*-

;;; 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/>.

;;; Commentary:

;;; base-0.mes is the first file being loaded from the Mes core.  It
;;; provides primitives that use Mes internals to create the illusion
;;; of compatibility with Guile.  It is not safe to be run by Guile.

;;; Code:

(define (effective-version) "0.3")
(define mes? #t)
(define guile? #f)
(define guile-1.8? #f)
(define guile-2? #f)

(define (primitive-eval e) (eval-env e (current-module)))
(define eval eval-env)
(define (macro-expand e) (macro-expand-env e (current-module)))

(define quotient /)

(define-macro (defined? x)
  (list 'assq x '(cddr (current-module))))

(if (defined? 'current-input-port) #t
    (define (current-input-port) 0))

(define (current-output-port) 1)
(define (current-error-port) 2)
(define (port-filename port) "<stdin>")
(define (port-line port) 0)
(define (port-column port) 0)
(define (ftell port) 0)
(define (false-if-exception x) x)

(define (cons* . rest)
  (if (null? (cdr rest)) (car rest)
      (cons (car rest) (apply-env cons* (cdr rest) (current-module)))))

(define (apply f h . t) (apply-env f (cons h t) (current-module)))
(define (apply f h . t)
  (if (null? t) (apply-env f h (current-module))
      (apply f (apply cons* (cons h t)))))

(define-macro (cond . clauses)
  (list 'if (pair? clauses)
        (list (cons
               'lambda
               (cons
                '(test)
                (list (list 'if 'test
                            (if (pair? (cdar clauses))
                                (if (eq? (cadar clauses) '=>)
                                    (append2 (cddar clauses) '(test))
                                    (list (cons 'lambda (cons '() (car clauses)))))
                                (list (cons 'lambda (cons '() (car clauses)))))
                            (if (pair? (cdr clauses))
                                (cons 'cond (cdr clauses)))))))
              (car (car clauses)))))

(define else #t)

(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)))
              (if (null? (cddr r))
                  (cons (f (car l) (caar r) (caadr r)) (map f (cdr l) (cdar r) (cdadr r)))
                  '*MAP-4-NOT-SUPPORTED)))))

(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 *input-ports* '())
(define-macro (push! stack o)
  (cons
   'begin
   (list
    (list 'set! stack (list cons o stack))
    stack)))
(define-macro (pop! stack)
  (list 'let (list (list 'o (list car stack)))
        (list 'set! stack (list cdr stack))
        'o))
(define-macro (load file)
  (list 'begin
     (list 'push! '*input-ports* (list current-input-port))
     (list 'set-current-input-port (list open-input-file file))
     (list 'primitive-load)
     (list 'set-current-input-port (list 'pop! '*input-ports*))))
(define (memq x lst)
  (if (null? lst) #f
      (if (eq? x (car lst)) lst
          (memq x (cdr lst)))))

(define (string-join lst infix)
  (if (null? (cdr lst)) (car lst)
      (string-append (car lst) infix (string-join (cdr lst) infix))))

(define *mes-prefix* "module/")
(define (module->file o)
  (string-append (string-join (map symbol->string o) "/") ".mes"))

(define *modules* '(mes/base-0.mes))
(define (mes-load-module-env module a)
  (push! *input-ports* (current-input-port))
  (set-current-input-port (open-input-file (string-append *mes-prefix* (module->file module))))
  (let ((x (eval-env (append (cons 'begin (read-input-file-env #f a))
                             '((current-module)))
                     a)))
    (set-current-input-port (pop! *input-ports*))
    x))
(define (not x)
  (if x #f #t))
(define-macro (mes-use-module module)
  (list
   'begin
   (list 'if (list 'not (list 'memq (list string->symbol (module->file module)) '*modules*))
         (list
          'begin
          (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*))
          ;; (list display "loading file=" (list current-error-port))
          ;; (list display (module->file module) (list current-error-port))
          ;; (list newline (list current-error-port))
          (list 'load (list string-append '*mes-prefix* (module->file module)))))))

(define include load)
(define-macro (include-from-path file)
  (list 'load (list string-append "module/" file)))

(mes-use-module (srfi srfi-0))
(mes-use-module (mes base))
(mes-use-module (mes scm))