5f0ee3c502e98e928eafb1e90fcdab3a0f7adf46
[mes.git] / module / mes / base-0.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 ;;; 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) "0.3")
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) (eval-env e (current-module)))
36 (define eval eval-env)
37 (define (macro-expand e) (macro-expand-env e (current-module)))
38
39 (define quotient /)
40
41 (define-macro (defined? x)
42   (list 'assq x '(cddr (current-module))))
43
44 (if (defined? 'current-input-port) #t
45     (define (current-input-port) 0))
46
47 (define (current-output-port) 1)
48 (define (current-error-port) 2)
49 (define (port-filename port) "<stdin>")
50 (define (port-line port) 0)
51 (define (port-column port) 0)
52 (define (ftell port) 0)
53 (define (false-if-exception x) x)
54
55 (define (cons* . rest)
56   (if (null? (cdr rest)) (car rest)
57       (cons (car rest) (apply-env cons* (cdr rest) (current-module)))))
58
59 (define (apply f h . t) (apply-env f (cons h t) (current-module)))
60 (define (apply f h . t)
61   (if (null? t) (apply-env f h (current-module))
62       (apply f (apply cons* (cons h t)))))
63
64 (define-macro (cond . clauses)
65   (list 'if (pair? clauses)
66         (list (cons
67                'lambda
68                (cons
69                 '(test)
70                 (list (list 'if 'test
71                             (if (pair? (cdar clauses))
72                                 (if (eq? (cadar clauses) '=>)
73                                     (append2 (cddar clauses) '(test))
74                                     (list (cons 'lambda (cons '() (car clauses)))))
75                                 (list (cons 'lambda (cons '() (car clauses)))))
76                             (if (pair? (cdr clauses))
77                                 (cons 'cond (cdr clauses)))))))
78               (car (car clauses)))))
79
80 (define else #t)
81
82 (define (map f l . r)
83   (if (null? l) '()
84       (if (null? r) (cons (f (car l)) (map f (cdr l)))
85           (if (null? (cdr r))
86               (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))
87               (if (null? (cddr r))
88                   (cons (f (car l) (caar r) (caadr r)) (map f (cdr l) (cdar r) (cdadr r)))
89                   '*MAP-4-NOT-SUPPORTED)))))
90
91 (define-macro (simple-let bindings . rest)
92   (cons (cons 'lambda (cons (map car bindings) rest))
93         (map cadr bindings)))
94
95 (define-macro (let bindings . rest)
96   (cons 'simple-let (cons bindings rest)))
97
98 (define *input-ports* '())
99 (define-macro (push! stack o)
100   (cons
101    'begin
102    (list
103     (list 'set! stack (list cons o stack))
104     stack)))
105 (define-macro (pop! stack)
106   (list 'let (list (list 'o (list car stack)))
107         (list 'set! stack (list cdr stack))
108         'o))
109 (define-macro (load file)
110   (list 'begin
111           (list core:stderr "read ")
112           (list core:stderr file)
113           (list core:stderr "\n")
114      (list 'push! '*input-ports* (list current-input-port))
115      (list 'set-current-input-port (list open-input-file file))
116      (list 'primitive-load)
117      (list 'set-current-input-port (list 'pop! '*input-ports*))))
118
119 (define include load)
120 (define-macro (include-from-path file)
121   (list 'load (list string-append "module/" file)))
122
123 (include "module/mes/type-0.mes")
124
125 (define (memq x lst)
126   (if (null? lst) #f
127       (if (eq? x (car lst)) lst
128           (memq x (cdr lst)))))
129
130 (define (string-join lst infix)
131   (if (null? (cdr lst)) (car lst)
132       (string-append (car lst) infix (string-join (cdr lst) infix))))
133
134 (define *mes-prefix* "module/")
135 (define (module->file o)
136   (string-append (string-join (map symbol->string o) "/") ".mes"))
137
138 (define *modules* '(mes/base-0.mes))
139 (define (mes-load-module-env module a)
140   (push! *input-ports* (current-input-port))
141   (set-current-input-port (open-input-file (string-append *mes-prefix* (module->file module))))
142   (let ((x (eval-env (append (cons 'begin (read-input-file-env a))
143                              '((current-module)))
144                      a)))
145     (set-current-input-port (pop! *input-ports*))
146     x))
147 (define (not x)
148   (if x #f #t))
149 (define-macro (mes-use-module module)
150   (list
151    'begin
152    (list 'if (list 'not (list 'memq (list string->symbol (module->file module)) '*modules*))
153          (list
154           'begin
155           (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*))
156           ;; (list core:stderr "read ")
157           ;; (list core:stderr file)
158           ;; (list core:stderr "\n")
159           (list 'load (list string-append '*mes-prefix* (module->file module)))))))
160
161 (mes-use-module (srfi srfi-0))
162 (mes-use-module (mes base))
163 (mes-use-module (mes quasiquote))
164 (mes-use-module (mes scm))
165 (mes-use-module (mes display))