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