b61874fa46a24c2ee40ac77960799ce84d137bed
[mes.git] / mes / module / mes / boot-03.scm
1 ;;; -*-scheme-*-
2
3 ;;; GNU Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of GNU Mes.
7 ;;;
8 ;;; GNU 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 ;;; GNU 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 GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; read-0.mes - bootstrap reader.  This file is read by a minimal
24 ;;; core reader.  It only supports s-exps and line-comments; quotes,
25 ;;; character literals, string literals cannot be used here.
26
27 ;;; Code:
28
29 ;; boot-00.scm
30 (define mes %version)
31
32 (define (defined? x)
33   (module-variable (current-module) x))
34
35 (define (cond-expand-expander clauses)
36   (if (defined? (car (car clauses)))
37       (cdr (car clauses))
38       (cond-expand-expander (cdr clauses))))
39
40 (define-macro (cond-expand . clauses)
41   (cons 'begin (cond-expand-expander clauses)))
42 ;; end boot-00.scm
43
44 ;; boot-01.scm
45 (define (not x) (if x #f #t))
46
47 (define (display x . rest)
48   (if (null? rest) (core:display x)
49       (core:display-port x (car rest))))
50
51 (define (write x . rest)
52   (if (null? rest) (core:write x)
53       (core:write-port x (car rest))))
54
55 (define (integer->char x)
56   (core:make-cell <cell:char> 0 x))
57
58 (define (newline . rest)
59   (core:display (list->string (list (integer->char 10)))))
60
61 (define (cadr x) (car (cdr x)))
62
63 (define (map1 f lst)
64   (if (null? lst) (list)
65       (cons (f (car lst)) (map1 f (cdr lst)))))
66
67 (define (map f lst)
68   (if (null? lst) (list)
69       (cons (f (car lst)) (map f (cdr lst)))))
70
71 (define (cons* . rest)
72   (if (null? (cdr rest)) (car rest)
73       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
74
75 (define (apply f h . t)
76   (if (null? t) (core:apply f h (current-module))
77       (apply f (apply cons* (cons h t)))))
78
79 (define (append . rest)
80   (if (null? rest) '()
81       (if (null? (cdr rest)) (car rest)
82           (append2 (car rest) (apply append (cdr rest))))))
83 ;; end boot-01.scm
84
85 ;; boot-02.scm
86 (define-macro (and . x)
87   (if (null? x) #t
88       (if (null? (cdr x)) (car x)
89           (list (quote if) (car x) (cons (quote and) (cdr x))
90                 #f))))
91
92 (define-macro (or . x)
93   (if (null? x) #f
94       (if (null? (cdr x)) (car x)
95           (list (list (quote lambda) (list (quote r))
96                       (list (quote if) (quote r) (quote r)
97                             (cons (quote or) (cdr x))))
98                 (car x)))))
99
100 (define-macro (mes-use-module module)
101   #t)
102 ;; end boot-02.scm
103
104 ;; boot-03.scm
105 (define guile? #f)
106 (define mes? #t)
107 (define (primitive-eval e) (core:eval e (current-module)))
108 (define eval core:eval)
109
110 (define (port-filename port) "<stdin>")
111 (define (port-line port) 0)
112 (define (port-column port) 0)
113 (define (ftell port) 0)
114 (define (false-if-exception x) x)
115
116 (define (cons* . rest)
117   (if (null? (cdr rest)) (car rest)
118       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
119
120 (define (apply f h . t)
121   (if (null? t) (core:apply f h (current-module))
122       (apply f (apply cons* (cons h t)))))
123
124 (define-macro (load file)
125   (list 'begin
126         (list 'if (list 'and (list getenv "MES_DEBUG")
127                         (list not (list equal2? (list getenv "MES_DEBUG") "0"))
128                         (list not (list equal2? (list getenv "MES_DEBUG") "1")))
129               (list 'begin
130                     (list core:display-error ";;; read ")
131                     (list core:display-error file)
132                     (list core:display-error "\n")))
133      (list 'primitive-load file)))
134
135 (define-macro (include file) (list 'load file))
136
137 (define (append . rest)
138   (if (null? rest) '()
139       (if (null? (cdr rest)) (car rest)
140           (append2 (car rest) (apply append (cdr rest))))))
141
142 (define %prefix (getenv "MES_PREFIX"))
143 (define %moduledir
144   (if (not %prefix) "boe /share/mes/module/"
145       (list->string
146        (append (string->list %prefix) (string->list "/module/" )))))
147
148 (include (list->string
149           (append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
150
151 (if (and (getenv "MES_DEBUG")
152           (not (equal2? (getenv "MES_DEBUG") "0"))
153           (not (equal2? (getenv "MES_DEBUG") "1")))
154     (begin
155       (core:display-error ";;; %moduledir=")
156       (core:display-error %moduledir)
157       (core:display-error "\n")))
158
159 (define-macro (include-from-path file)
160   (list 'load (list string-append %moduledir file)))
161
162 (define (string-join lst infix)
163   (if (null? lst) ""
164       (if (null? (cdr lst)) (car lst)
165           (string-append (car lst) infix (string-join (cdr lst) infix)))))
166
167 (include-from-path "mes/module.mes")
168
169 (mes-use-module (mes base))
170 (mes-use-module (mes quasiquote))
171 (mes-use-module (mes let))
172 (mes-use-module (mes scm))
173
174 (define-macro (define-module module . rest)
175   `(if ,(and (pair? module)
176              (= 1 (length module))
177              (symbol? (car module)))
178        (define (,(car module) . arguments) (main (command-line)))))
179
180 (define-macro (use-modules . rest) #t)
181 ;; end boot-03.scm
182 (primitive-load 0)
183 (primitive-load 0)