b5629a6c7177addeeefa10abc30dece31de9ecad
[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 (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) "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
183 (define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git"
184                      "@VERSION@"))
185 (define (effective-version) %version)
186
187 (mes-use-module (srfi srfi-1))
188 (mes-use-module (srfi srfi-13))
189 (mes-use-module (mes fluids))
190 (mes-use-module (mes catch))
191 (mes-use-module (mes posix))
192
193 (define-macro (include-from-path file)
194   (let loop ((path (cons* %moduledir "@srcdir@/module" (string-split (or (getenv "GUILE_LOAD_PATH")) #\:))))
195     (cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 2)) string->number))
196            (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
197           ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number))
198            (core:display-error (string-append "include-from-path: " file "\n"))))
199     (if (null? path) (error "include-from-path: not found: " file)
200         (let ((file (string-append (car path) "/" file)))
201           (if (access? file R_OK) `(load ,file)
202               (loop (cdr path)))))))
203
204 (define-macro (define-module module . rest)
205   `(if ,(and (pair? module)
206              (= 1 (length module))
207              (symbol? (car module)))
208        (define (,(car module) . arguments) (main (command-line)))))
209
210 (define-macro (use-modules . rest) #t)
211
212 (mes-use-module (mes getopt-long))
213
214 (define %main #f)
215 (primitive-load 0)
216 (let ((tty? (isatty? 0)))
217   (define (parse-opts args)
218     (let* ((option-spec
219             '((no-auto-compile)
220               (compiled-path (single-char #\C) (value #t))
221               (help (single-char #\h))
222               (load-path (single-char #\L) (value #t))
223               (main (single-char #\e) (value #t))
224               (source (single-char #\s) (value #t))
225               (version (single-char #\V)))))
226       (getopt-long args option-spec #:stop-at-first-non-option #t)))
227   (define (source-arg? o)
228     (equal? "-s" o))
229   (let* ((s-index (list-index source-arg? %argv))
230          (args (if s-index (list-head %argv (+ s-index 2)) %argv))
231          (options (parse-opts args))
232          (main (option-ref options 'main #f))
233          (source (option-ref options 'source #f))
234          (files (if s-index (list-tail %argv (+ s-index 1))
235                     (option-ref options '() '())))
236          (help? (option-ref options 'help #f))
237          (usage? #f)
238          (version? (option-ref options 'version #f)))
239     (or
240      (and version?
241           (display (string-append "mes (GNU Mes) " %version "\n"))
242           (exit 0))
243      (and (or help? usage?)
244           (display "Usage: mes [OPTION]... [FILE]...
245 Evaluate code with Mes, interactively or from a script.
246
247   [-s] FILE           load source code from FILE, and exit
248   --                  stop scanning arguments; run interactively
249
250 The above switches stop argument processing, and pass all
251 remaining arguments as the value of (command-line).
252
253   -e,--main=MAIN      after reading script, apply MAIN to command-line arguments
254   -h, --help          display this help and exit
255   -L,--load-path=DIR  add DIR to the front of the module load path
256   -v, --version       display version information and exit
257
258 Ignored for Guile compatibility:
259   --auto-compile
260   --fresh-auto-compile
261   --no-auto-compile
262   -C,--compiled-path=DIR
263
264 Report bugs to: bug-mes@gnu.org
265 GNU Mes home page: <http://gnu.org/software/mes/>
266 General help using GNU software: <http://gnu.org/gethelp/>
267 " (or (and usage? (current-error-port)) (current-output-port)))
268           (exit (or (and usage? 2) 0)))
269      options)
270     (if main (set! %main main))
271     (and=> (option-ref options 'load-path #f)
272            (lambda (dir)
273              (setenv "GUILE_LOAD_PATH" (string-append dir ":" (getenv "GUILE_LOAD_PATH")))))
274     (cond ((pair? files)
275            (let* ((file (car files))
276                   (port (if (equal? file "-") 0
277                             (open-input-file file))))
278              (set! %argv files)
279              (set-current-input-port port)))
280           ((and (null? files) tty?)
281
282            (mes-use-module (mes repl))
283            (set-current-input-port 0)
284            (repl))
285           (else #t))))
286 (primitive-load 0)
287 (primitive-load (open-input-string %main))