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