3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;; This file is part of Mes.
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.
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.
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/>.
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.
29 #f ;; FIXME -- needed for --dump, then --load
31 (define (primitive-eval e) (eval-env e (current-module)))
32 (define eval eval-env)
33 (define (expand-macro e) (expand-macro-env e (current-module)))
37 (define-macro (defined? x)
38 (list 'assq x '(cddr (current-module))))
40 (if (defined? 'current-input-port) #t
41 (define (current-input-port) 0))
43 (define (current-output-port) 1)
44 (define (current-error-port) 2)
45 (define (port-filename port) "<stdin>")
46 (define (port-line port) 0)
47 (define (port-column port) 0)
48 (define (ftell port) 0)
49 (define (false-if-exception x) x)
51 (define (cons* x . rest)
53 (if (null? (cdr rest)) (car rest)
54 (cons (car rest) (loop (cdr rest)))))
57 (define (apply f h . t) (apply-env f (cons h t) (current-module)))
58 (define (apply f h . t)
59 (if (null? t) (apply-env f h (current-module))
60 (apply f (apply cons* (cons h t)))))
62 (define-macro (cond . clauses)
63 (list 'if (null? clauses) *unspecified*
64 (if (null? (cdr clauses))
65 (list 'if (car (car clauses))
66 (list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
68 (if (eq? (car (cadr clauses)) 'else)
69 (list 'if (car (car clauses))
70 (list (cons 'lambda (cons '() (car clauses))))
71 (list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
72 (list 'if (car (car clauses))
73 (list (cons 'lambda (cons '() (car clauses))))
74 (cons 'cond (cdr clauses)))))))
80 (if (null? r) (cons (f (car l)) (map f (cdr l)))
82 (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))
84 (define-macro (simple-let bindings . rest)
85 (cons (cons 'lambda (cons (map car bindings) rest))
88 (define-macro (let bindings . rest)
89 (cons 'simple-let (cons bindings rest)))
91 (define *input-ports* '())
92 (define-macro (push! stack o)
94 (set! ,stack (cons ,o ,stack))
96 (define-macro (pop! stack)
97 `(let ((o (car ,stack)))
98 (set! ,stack (cdr ,stack))
100 (define-macro (load file)
102 (push! *input-ports* (current-input-port))
103 (set-current-input-port (open-input-file ,file))
105 (set-current-input-port (pop! *input-ports*))))
109 (if (eq? x (car lst)) lst
110 (memq x (cdr lst)))))
112 (define (string-join lst infix)
113 (if (null? (cdr lst)) (car lst)
114 (string-append (car lst) infix (string-join (cdr lst) infix))))
116 (define *mes-prefix* "module/")
117 (define (module->file o)
118 (string-append (string-join (map symbol->string o) "/") ".mes"))
120 (define *modules* '(mes/base-0.mes))
121 (define (mes-load-module-env module a)
122 (push! *input-ports* (current-input-port))
123 (set-current-input-port (open-input-file (string-append *mes-prefix* (module->file module))))
124 (let ((x (eval-env (append (cons 'begin (read-input-file-env #f a))
127 (set-current-input-port (pop! *input-ports*))
129 (define-macro (mes-use-module module)
131 (if (not (memq (string->symbol ,(module->file module)) *modules*))
133 (set! *modules* (cons (string->symbol ,(module->file module)) *modules*))
134 ;; (display "loading file=" (current-error-port))
135 ;; (display ,(module->file module) (current-error-port))
136 ;; (newline (current-error-port))
137 (load ,(string-append *mes-prefix* (module->file module)))))))
142 (mes-use-module (srfi srfi-0))
143 (mes-use-module (mes base))
144 (mes-use-module (mes scm))