b497b0e17d5eaa022dd5a520c865d95fcce2b84f
[mes.git] / mes / module / mes / boot-0.scm.in
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 (list->string lst)
56   (core:make-cell <cell:string> lst 0))
57
58 (define (integer->char x)
59   (core:make-cell <cell:char> 0 x))
60
61 (define (newline . rest)
62   (core:display (list->string (list (integer->char 10)))))
63
64 (define (string->list s)
65   (core:car s))
66
67 (define (cadr x) (car (cdr x)))
68
69 (define (map1 f lst)
70   (if (null? lst) (list)
71       (cons (f (car lst)) (map1 f (cdr lst)))))
72
73 (define (map f lst)
74   (if (null? lst) (list)
75       (cons (f (car lst)) (map f (cdr lst)))))
76
77 (define (cons* . rest)
78   (if (null? (cdr rest)) (car rest)
79       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
80
81 (define (apply f h . t)
82   (if (null? t) (core:apply f h (current-module))
83       (apply f (apply cons* (cons h t)))))
84
85 (define (append . rest)
86   (if (null? rest) '()
87       (if (null? (cdr rest)) (car rest)
88           (append2 (car rest) (apply append (cdr rest))))))
89 ;; end boot-01.scm
90
91 ;; boot-02.scm
92 (define-macro (and . x)
93   (if (null? x) #t
94       (if (null? (cdr x)) (car x)
95           (list (quote if) (car x) (cons (quote and) (cdr x))
96                 #f))))
97
98 (define-macro (or . x)
99   (if (null? x) #f
100       (if (null? (cdr x)) (car x)
101           (list (list (quote lambda) (list (quote r))
102                       (list (quote if) (quote r) (quote r)
103                             (cons (quote or) (cdr x))))
104                 (car x)))))
105
106 (define-macro (mes-use-module module)
107   #t)
108 ;; end boot-02.scm
109
110 ;; boot-0.scm
111 (define (primitive-eval e) (core:eval e (current-module)))
112 (define eval core:eval)
113
114 (define (port-filename port) "<stdin>")
115 (define (port-line port) 0)
116 (define (port-column port) 0)
117 (define (ftell port) 0)
118 (define (false-if-exception x) x)
119
120 (define (cons* . rest)
121   (if (null? (cdr rest)) (car rest)
122       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
123
124 (define (apply f h . t)
125   (if (null? t) (core:apply f h (current-module))
126       (apply f (apply cons* (cons h t)))))
127
128 (define-macro (cond . clauses)
129   (list 'if (pair? clauses)
130         (list (cons
131                'lambda
132                (cons
133                 '(test)
134                 (list (list 'if 'test
135                             (if (pair? (cdr (car clauses)))
136                                 (if (eq? (car (cdr (car clauses))) '=>)
137                                     (append2 (cdr (cdr (car clauses))) '(test))
138                                     (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
139                                 (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
140                             (if (pair? (cdr clauses))
141                                 (cons 'cond (cdr clauses)))))))
142               (car (car clauses)))))
143
144 (define else #t)
145
146 (define-macro (load file)
147   (list 'begin
148         (list 'if (list 'and (list getenv "MES_DEBUG")
149                         (list not (list equal2? (list getenv "MES_DEBUG") "0"))
150                         (list not (list equal2? (list getenv "MES_DEBUG") "1")))
151               (list 'begin
152                     (list core:display-error ";;; read ")
153                     (list core:display-error file)
154                     (list core:display-error "\n")))
155      (list 'primitive-load file)))
156
157 (define-macro (include file) (list 'load file))
158
159 (define (append . rest)
160   (if (null? rest) '()
161       (if (null? (cdr rest)) (car rest)
162           (append2 (car rest) (apply append (cdr rest))))))
163
164 (define (string->list s)
165   (core:car s))
166
167 (define %prefix (getenv "MES_PREFIX"))
168 (define %moduledir
169   (if (not %prefix) "mes/module/"
170       (list->string
171        (append (string->list %prefix) (string->list "/module/" )))))
172
173 (include (list->string
174           (append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
175
176 (define (symbol->string s)
177   (apply string (symbol->list s)))
178
179 (define (string-append . rest)
180   (apply string (apply append (map1 string->list rest))))
181
182 (define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git"
183                      "@VERSION@"))
184 (define (effective-version) %version)
185
186 (if (list 'and (list getenv "MES_DEBUG")
187           (list not (list equal2? (list getenv "MES_DEBUG") "0"))
188           (list not (list equal2? (list getenv "MES_DEBUG") "1")))
189     (begin
190       (core:display-error ";;; %moduledir=")
191       (core:display-error %moduledir)
192       (core:display-error "\n")))
193
194 (define-macro (include-from-path file)
195   (list 'load (list string-append %moduledir file)))
196
197 (define (string-join lst infix)
198   (if (null? lst) ""
199       (if (null? (cdr lst)) (car lst)
200           (string-append (car lst) infix (string-join (cdr lst) infix)))))
201
202 (include-from-path "mes/module.mes")
203
204 (mes-use-module (mes base))
205 (mes-use-module (mes quasiquote))
206 (mes-use-module (mes let))
207 (mes-use-module (mes scm))
208 (mes-use-module (srfi srfi-1))
209 (mes-use-module (srfi srfi-13))
210 (mes-use-module (mes fluids))
211 (mes-use-module (mes catch))
212 (mes-use-module (mes posix))
213
214 (define-macro (include-from-path file)
215   (let loop ((path (cons* %moduledir "@srcdir@/module" (string-split (or (getenv "GUILE_LOAD_PATH")) #\:))))
216     (cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 2)) string->number))
217            (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
218           ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number))
219            (core:display-error (string-append "include-from-path: " file "\n"))))
220     (if (null? path) (error "include-from-path: not found: " file)
221         (let ((file (string-append (car path) "/" file)))
222           (if (access? file R_OK) `(load ,file)
223               (loop (cdr path)))))))
224
225 (define-macro (define-module module . rest)
226   `(if ,(and (pair? module)
227              (= 1 (length module))
228              (symbol? (car module)))
229        (define (,(car module) . arguments) (main (command-line)))))
230
231 (define-macro (use-modules . rest) #t)
232
233 (mes-use-module (mes getopt-long))
234
235 (define %main #f)
236 (primitive-load 0)
237 (let ((tty? (isatty? 0)))
238   (define (parse-opts args)
239     (let* ((option-spec
240             '((no-auto-compile)
241               (compiled-path (single-char #\C) (value #t))
242               (dump)
243               (help (single-char #\h))
244               (load)
245               (load-path (single-char #\L) (value #t))
246               (main (single-char #\e) (value #t))
247               (source (single-char #\s) (value #t))
248               (version (single-char #\V)))))
249       (getopt-long args option-spec #:stop-at-first-non-option #t)))
250   (define (source-arg? o)
251     (equal? "-s" o))
252   (let* ((s-index (list-index source-arg? %argv))
253          (args (if s-index (list-head %argv (+ s-index 2)) %argv))
254          (options (parse-opts args))
255          (main (option-ref options 'main #f))
256          (source (option-ref options 'source #f))
257          (files (if s-index (list-tail %argv (+ s-index 1))
258                     (option-ref options '() '())))
259          (help? (option-ref options 'help #f))
260          (usage? (and (not help?) (null? files) (not tty?) (not main)))
261          (version? (option-ref options 'version #f)))
262     (or
263      (and version?
264           (display (string-append "mes (GNU Mes) " %version "\n"))
265           (exit 0))
266      (and (or help? usage?)
267           (display "Usage: mes [OPTION]... [FILE]...
268 Evaluate code with Mes, interactively or from a script.
269
270   [-s] FILE           load source code from FILE, and exit
271   --                  stop scanning arguments; run interactively
272
273 The above switches stop argument processing, and pass all
274 remaining arguments as the value of (command-line).
275
276   --dump              dump binary program to stdout
277   -e,--main=MAIN      after reading script, apply MAIN to command-line arguments
278   -h, --help          display this help and exit
279   --load              load binary program [module/mes/boot-0.32-mo]
280   -L,--load-path=DIR  add DIR to the front of the module load path
281   -v, --version       display version information and exit
282
283 Ignored for Guile compatibility:
284   --auto-compile
285   --fresh-auto-compile
286   --no-auto-compile
287   -C,--compiled-path=DIR
288 " (or (and usage? (current-error-port)) (current-output-port)))
289           (exit (or (and usage? 2) 0)))
290      options)
291     (if main (set! %main main))
292     (and=> (option-ref options 'load-path #f)
293            (lambda (dir)
294              (setenv "GUILE_LOAD_PATH" (string-append dir ":" (getenv "GUILE_LOAD_PATH")))))
295     (cond ((pair? files)
296            (let* ((file (car files))
297                   (port (if (equal? file "-") 0
298                             (open-input-file file))))
299              (set! %argv files)
300              (set-current-input-port port)))
301           ((and (null? files) tty?)
302
303            (mes-use-module (mes repl))
304            (set-current-input-port 0)
305            (repl))
306           (else #t))))
307 (primitive-load 0)
308 (primitive-load (open-input-string %main))